module Physics.Vector2D

public export
Vector2D : Type
Vector2D = (Double, Double)

export
Num Vector2D where
  (a1, b1) + (a2, b2) = (a1+a2, b1+b2)
  (a1, b1) * (a2, b2) = (a1*a2, b1*b2)
  fromInteger a = (cast a, cast a)

export
Neg Vector2D where
  negate (x, y) = (-x, -y)
  (x2, y2) - (x1, y1) = (x2-x1, y2-y1)

export
Abs Vector2D where
  abs (x, y) = (abs x, abs y)

export
norm : Vector2D -> Double
norm (x, y) = sqrt $ x*x + y*y

export
scale : Double -> Vector2D -> Vector2D
scale a (x, y) = (a*x, a*y)

infix 7 `scale`

public export
Cast (Integer, Integer) Vector2D where
  cast (x, y) = (the Double (cast x), the Double (cast y))

public export
Cast Vector2D (Int, Int) where
  cast (x, y) = (cast x, cast y)

export
nullVector : Vector2D
nullVector = (0, 0)

export
magnitude : Vector2D -> Double
magnitude (a, b) = sqrt(a*a + b*b)

export
normed : Vector2D -> Vector2D
normed x = let magnitude' = 1.0/(magnitude x) in magnitude' `scale` x

export
angle : Vector2D -> Double
angle (x, y) = atan2 y x


data EqNat : Nat -> Nat -> Type where
     Same : (x : Nat) -> EqNat x x

total
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              Just eq => Just (sameS _ _ eq)


twoplustwo_not_five : 2 + 2 = 5 -> Void
twoplustwo_not_five Refl impossible

value_not_suc : (x : Nat) -> x = S x -> Void
value_not_suc _ Refl impossible

zero_not_succ : (0 = S k) -> Void
zero_not_succ Refl impossible

succ_not_zero : (S k = 0) -> Void
succ_not_zero Refl impossible

no_rec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
no_rec contra Refl = contra Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zero_not_succ
checkEqNat (S k) Z = No succ_not_zero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              (Yes prf) => Yes (cong prf)
                              (No contra) => No (no_rec contra)


module Prelude.Types

import Builtin
import PrimIO
import Prelude.Basics
import Prelude.EqOrd
import Prelude.Interfaces
import Prelude.Num
import Prelude.Uninhabited

%default total

-----------
-- NATS ---
-----------

||| Natural numbers: unbounded, unsigned integers which can be pattern matched.
public export
data Nat =
  ||| Zero.
    Z
  | ||| Successor.
  S Nat

%name Nat k, j, i

-- This is used in the compiler as an efficient substitute for integerToNat.
prim__integerToNat : Integer -> Nat
prim__integerToNat i
  = if intToBool (prim__lte_Integer 0 i)
      then believe_me i
      else Z

public export
integerToNat : Integer -> Nat
integerToNat 0 = Z -- Force evaluation and hence caching of x at compile time
integerToNat x
  = if intToBool (prim__lte_Integer x 0)
       then Z
       else S (assert_total (integerToNat (prim__sub_Integer x 1)))

-- %builtin IntegerToNatural Prelude.Types.integerToNat

-- Define separately so we can spot the name when optimising Nats
||| Add two natural numbers.
||| @ x the number to case-split on
||| @ y the other numberpublic export
public export
plus : (x : Nat) -> (y : Nat) -> Nat
plus Z y = y
plus (S k) y = S (plus k y)

||| Subtract natural numbers.  If the second number is larger than the first,
||| return 0.
public export
minus : (left : Nat) -> Nat -> Nat
minus Z        right     = Z
minus left     Z         = left
minus (S left) (S right) = minus left right

||| Multiply natural numbers.
public export
mult : (x : Nat) -> Nat -> Nat
mult Z y = Z
mult (S k) y = plus y (mult k y)

public export
Num Nat where
  (+) = plus
  (*) = mult

  fromInteger x = integerToNat x

-- used for nat hack
public export
equalNat : (m, n : Nat) -> Bool
equalNat Z Z = True
equalNat (S j) (S k) = equalNat j k
equalNat _ _ = False

public export
Eq Nat where
  (==) = equalNat

-- used for nat hack
public export
compareNat : (m, n : Nat) -> Ordering
compareNat Z Z = EQ
compareNat Z (S k) = LT
compareNat (S k) Z = GT
compareNat (S j) (S k) = compareNat j k

public export
Ord Nat where
  compare = compareNat

public export
natToInteger : Nat -> Integer
natToInteger Z = 0
natToInteger (S k) = 1 + natToInteger k
                         -- integer (+) may be non-linear in second
                         -- argument

-- %builtin NaturalToInteger Prelude.Types.natToInteger

||| Counts the number of elements that satify a predicate.
public export
count : (Foldable t) => (predicate : a -> Bool) -> (t a) -> Nat
count predicate = foldMap @{%search} @{Additive} (\x => if predicate x then 1 else 0)

-----------
-- PAIRS --
-----------

%inline
public export
Bifunctor Pair where
  bimap f g (x, y) = (f x, g y)

%inline
public export
Bifoldable Pair where
  bifoldr f g acc (x, y) = f x (g y acc)
  bifoldl f g acc (x, y) = g (f acc x) y
  binull _ = False

%inline
public export
Bitraversable Pair where
  bitraverse f g (a,b) = [| (,) (f a) (g b) |]

%inline
public export
Functor (Pair a) where
  map = mapSnd

%inline
public export
Monoid a => Applicative (Pair a) where
  pure = (neutral,)
  (a1,f) <*> (a2,v) = (a1 <+> a2, f v)

%inline
public export
Monoid a => Monad (Pair a) where
  (a1,a) >>= f = let (a2,b) = f a in (a1 <+> a2, b)

-----------
-- MAYBE --
-----------

||| An optional value.  This can be used to represent the possibility of
||| failure, where a function may return a value, or not.
public export
data Maybe : (ty : Type) -> Type where
  ||| No value stored
  Nothing : Maybe ty

  ||| A value of type `ty` is stored
  Just : (x : ty) -> Maybe ty

public export
Uninhabited (Nothing = Just x) where
  uninhabited Refl impossible

public export
Uninhabited (Just x = Nothing) where
  uninhabited Refl impossible

public export
maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b
maybe n j Nothing  = n
maybe n j (Just x) = j x

||| Execute an applicative expression when the Maybe is Just
%inline public export
whenJust : Applicative f => Maybe a -> (a -> f ()) -> f ()
whenJust (Just a) k = k a
whenJust Nothing k = pure ()

public export
Eq a => Eq (Maybe a) where
  Nothing  == Nothing  = True
  Nothing  == (Just _) = False
  (Just _) == Nothing  = False
  (Just a) == (Just b) = a == b

public export
Ord a => Ord (Maybe a) where
  compare Nothing  Nothing  = EQ
  compare Nothing  (Just _) = LT
  compare (Just _) Nothing  = GT
  compare (Just a) (Just b) = compare a b

public export
Semigroup (Maybe a) where
  Nothing   <+> m = m
  (Just x)  <+> _ = Just x

public export
Monoid (Maybe a) where
  neutral = Nothing

public export
Functor Maybe where
  map f (Just x) = Just (f x)
  map f Nothing  = Nothing

public export
Applicative Maybe where
  pure = Just

  Just f <*> Just a = Just (f a)
  _      <*> _      = Nothing

public export
Alternative Maybe where
  empty = Nothing

  (Just x) <|> _ = Just x
  Nothing  <|> v = v

public export
Monad Maybe where
  Nothing  >>= k = Nothing
  (Just x) >>= k = k x

public export
Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = f x z
  null Nothing = True
  null (Just _) = False

public export
Traversable Maybe where
  traverse f Nothing = pure Nothing
  traverse f (Just x) = Just <$> f x

---------
-- DEC --
---------

||| Decidability.  A decidable property either holds or is a contradiction.
public export
data Dec : Type -> Type where
  ||| The case where the property holds.
  ||| @ prf the proof
  Yes : (prf : prop) -> Dec prop

  ||| The case where the property holding would be a contradiction.
  ||| @ contra a demonstration that prop would be a contradiction
  No  : (contra : Not prop) -> Dec prop

export Uninhabited (Yes p === No q) where uninhabited eq impossible
export Uninhabited (No p === Yes q) where uninhabited eq impossible

------------
-- EITHER --
------------

||| A sum type.
public export
data Either : (a : Type) -> (b : Type) -> Type where
  ||| One possibility of the sum, conventionally used to represent errors.
  Left : forall a, b. (x : a) -> Either a b

  ||| The other possibility, conventionally used to represent success.
  Right : forall a, b. (x : b) -> Either a b

export Uninhabited (Left p === Right q) where uninhabited eq impossible
export Uninhabited (Right p === Left q) where uninhabited eq impossible

export
Either (Uninhabited a) (Uninhabited b) => Uninhabited (a, b) where
  uninhabited (x, _) @{Left  _} = uninhabited x
  uninhabited (_, y) @{Right _} = uninhabited y

export
Uninhabited a => Uninhabited b => Uninhabited (Either a b) where
  uninhabited (Left l)  = uninhabited l
  uninhabited (Right r) = uninhabited r

||| Simply-typed eliminator for Either.
||| @ f the action to take on Left
||| @ g the action to take on Right
||| @ e the sum to analyze
public export
either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c
either l r (Left x) = l x
either l r (Right x) = r x

public export
(Eq a, Eq b) => Eq (Either a b) where
  Left x == Left x' = x == x'
  Right x == Right x' = x == x'
  _ == _ = False

public export
(Ord a, Ord b) => Ord (Either a b) where
  compare (Left x) (Left x') = compare x x'
  compare (Left _) (Right _) = LT
  compare (Right _) (Left _) = GT
  compare (Right x) (Right x') = compare x x'

%inline
public export
Functor (Either e) where
  map f (Left x) = Left x
  map f (Right x) = Right (f x)

%inline
public export
Bifunctor Either where
  bimap f _ (Left x) = Left (f x)
  bimap _ g (Right y) = Right (g y)

%inline
public export
Bifoldable Either where
  bifoldr f _ acc (Left a)  = f a acc
  bifoldr _ g acc (Right b) = g b acc

  bifoldl f _ acc (Left a)  = f acc a
  bifoldl _ g acc (Right b) = g acc b

  binull _ = False

%inline
public export
Bitraversable Either where
  bitraverse f _ (Left a)  = Left <$> f a
  bitraverse _ g (Right b) = Right <$> g b

%inline
public export
Applicative (Either e) where
  pure = Right

  (Left a) <*> _          = Left a
  (Right f) <*> (Right r) = Right (f r)
  (Right _) <*> (Left l)  = Left l

public export
Monad (Either e) where
  (Left n) >>= _ = Left n
  (Right r) >>= f = f r

public export
Foldable (Either e) where
  foldr f acc (Left _) = acc
  foldr f acc (Right x) = f x acc
  null (Left _) = True
  null (Right _) = False

public export
Traversable (Either e) where
  traverse f (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x

-----------
-- LISTS --
-----------

public export
Eq a => Eq (List a) where
  [] == [] = True
  x :: xs == y :: ys = x == y && xs == ys
  _ == _ = False

public export
Ord a => Ord (List a) where
  compare [] [] = EQ
  compare [] (x :: xs) = LT
  compare (x :: xs) [] = GT
  compare (x :: xs) (y ::ys)
     = case compare x y of
            EQ => compare xs ys
            c => c

namespace List
  public export
  (++) : (xs, ys : List a) -> List a
  [] ++ ys = ys
  (x :: xs) ++ ys = x :: xs ++ ys

  public export
  length : List a -> Nat
  length []        = Z
  length (x :: xs) = S (length xs)

  public export
  reverseOnto : List a -> List a -> List a
  reverseOnto acc [] = acc
  reverseOnto acc (x::xs) = reverseOnto (x::acc) xs

  public export
  reverse : List a -> List a
  reverse = reverseOnto []

  ||| Tail-recursive append. Uses of (++) are automatically transformed to
  ||| this. The only reason this is exported is that the proof of equivalence
  ||| lives in a different module.
  public export
  tailRecAppend : (xs, ys : List a) -> List a
  tailRecAppend xs ys = reverseOnto ys (reverse xs)

  -- Always use tailRecAppend at runtime. Data.List.tailRecAppendIsAppend
  -- proves these are equivalent.
  %transform "tailRecAppend" (++) = tailRecAppend

public export
Functor List where
  map f [] = []
  map f (x :: xs) = f x :: map f xs

public export
Semigroup (List a) where
  (<+>) = (++)

public export
Monoid (List a) where
  neutral = []

public export
Foldable List where
  foldr c n [] = n
  foldr c n (x::xs) = c x (foldr c n xs)

  foldl f q [] = q
  foldl f q (x::xs) = foldl f (f q x) xs

  null [] = True
  null (_::_) = False

  toList = id

  foldMap f = foldl (\acc, elem => acc <+> f elem) neutral

public export
Applicative List where
  pure x = [x]
  fs <*> vs = concatMap (\f => map f vs) fs

public export
Alternative List where
  empty = []
  xs <|> ys = xs ++ ys

public export
Monad List where
  m >>= f = concatMap f m

public export
Traversable List where
  traverse f [] = pure []
  traverse f (x::xs) = [| f x :: traverse f xs |]

-- This works quickly because when string-concat builds the result, it allocates
-- enough room in advance so there's only one allocation, rather than lots!
--
-- Like fastUnpack, this function won't reduce at compile time.
-- If you need to concatenate strings at compile time, use Prelude.concat.
%foreign
  "scheme:string-concat"
  "RefC:fastConcat"
  "javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
  "jvm:concat(io/github/mmhelloworld/idrisjvm/runtime/IdrisList java/lang/String),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastConcat : List String -> String

%transform "fastConcat" concat {t = List} {a = String} = fastConcat

||| Check if something is a member of a list using the default Boolean equality.
public export
elem : Eq a => a -> List a -> Bool
x `elem` [] = False
x `elem` (y :: ys) = x == y ||  elem x ys

||| Lookup a value at a given position
export
getAt : Nat -> List a -> Maybe a
getAt Z     (x :: xs) = Just x
getAt (S k) (x :: xs) = getAt k xs
getAt _     []        = Nothing

-------------
-- STREAMS --
-------------

namespace Stream
  ||| An infinite stream.
  public export
  data Stream : Type -> Type where
       (::) : a -> Inf (Stream a) -> Stream a

%name Stream xs, ys, zs

public export
Functor Stream where
  map f (x :: xs) = f x :: map f xs

||| The first element of an infinite stream.
public export
head : Stream a -> a
head (x :: xs) = x

||| All but the first element.
public export
tail : Stream a -> Stream a
tail (x :: xs) = xs

||| Take precisely n elements from the stream.
||| @ n how many elements to take
||| @ xs the stream
public export
take : (n : Nat) -> (xs : Stream a) -> List a
take Z xs = []
take (S k) (x :: xs) = x :: take k xs

-------------
-- STRINGS --
-------------

namespace String
  public export
  (++) : (x : String) -> (y : String) -> String
  x ++ y = prim__strAppend x y

  ||| Returns the length of the string.
  |||
  ||| ```idris example
  ||| length ""
  ||| ```
  ||| ```idris example
  ||| length "ABC"
  ||| ```
  public export
  length : String -> Nat
  length str = fromInteger (prim__cast_IntInteger (prim__strLength str))

||| Reverses the elements within a string.
|||
||| ```idris example
||| reverse "ABC"
||| ```
||| ```idris example
||| reverse ""
||| ```
public export
reverse : String -> String
reverse = prim__strReverse

||| Returns a substring of a given string
|||
||| @ index The (zero based) index of the string to extract.  If this is beyond
|||         the end of the string, the function returns the empty string.
||| @ len The desired length of the substring.  Truncated if this exceeds the
|||       length of the input
||| @ subject The string to return a portion of
public export
substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String
substr s e subj
    = if natToInteger s < natToInteger (length subj)
         then prim__strSubstr (prim__cast_IntegerInt (natToInteger s))
                              (prim__cast_IntegerInt (natToInteger e))
                              subj
         else ""

||| Adds a character to the front of the specified string.
|||
||| ```idris example
||| strCons 'A' "B"
||| ```
||| ```idris example
||| strCons 'A' ""
||| ```
public export
strCons : Char -> String -> String
strCons = prim__strCons

public export
strUncons : String -> Maybe (Char, String)
strUncons "" = Nothing
strUncons str = assert_total $ Just (prim__strHead str, prim__strTail str)

||| Turns a list of characters into a string.
public export
pack : List Char -> String
pack [] = ""
pack (x :: xs) = strCons x (pack xs)

%foreign
    "scheme:string-pack"
    "RefC:fastPack"
    "javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
    "jvm:pack(io/github/mmhelloworld/idrisjvm/runtime/IdrisList java/lang/String),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastPack : List Char -> String

-- always use 'fastPack' at run time
%transform "fastPack" pack = fastPack

||| Turns a string into a list of characters.
|||
||| ```idris example
||| unpack "ABC"
||| ```
public export
unpack : String -> List Char
unpack str = unpack' (prim__cast_IntegerInt (natToInteger (length str)) - 1) str []
  where
    unpack' : Int -> String -> List Char -> List Char
    unpack' pos str acc
        = if pos < 0
             then acc
             else unpack' (assert_smaller pos (pos - 1)) str $ (assert_total $ prim__strIndex str pos) :: acc

-- This function runs fast when compiled but won't compute at compile time.
-- If you need to unpack strings at compile time, use Prelude.unpack.
%foreign
  "scheme:string-unpack"
  "RefC:fastUnpack"
  "javascript:lambda:(str)=>__prim_js2idris_array(Array.from(str))"
  "jvm:unpack(java/lang/String io/github/mmhelloworld/idrisjvm/runtime/IdrisList),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastUnpack : String -> List Char

-- always use 'fastPack' at run time
%transform "fastUnpack" unpack = fastUnpack

public export
Semigroup String where
  (<+>) = (++)

public export
Monoid String where
  neutral = ""

----------------
-- CHARACTERS --
----------------

||| Returns true if the character is in the range [A-Z].
public export
isUpper : Char -> Bool
isUpper x = x >= 'A' && x <= 'Z'

||| Returns true if the character is in the range [a-z].
public export
isLower : Char -> Bool
isLower x = x >= 'a' && x <= 'z'

||| Returns true if the character is in the ranges [A-Z][a-z].
public export
isAlpha : Char -> Bool
isAlpha x = isUpper x || isLower x

||| Returns true if the character is in the range [0-9].
public export
isDigit : Char -> Bool
isDigit x = (x >= '0' && x <= '9')

||| Returns true if the character is in the ranges [A-Z][a-z][0-9].
public export
isAlphaNum : Char -> Bool
isAlphaNum x = isDigit x || isAlpha x

||| Returns true if the character is a whitespace character.
public export
isSpace : Char -> Bool
isSpace x
    = x == ' '  || x == '\t' || x == '\r' ||
      x == '\n' || x == '\f' || x == '\v' ||
      x == '\xa0'

||| Returns true if the character represents a new line.
public export
isNL : Char -> Bool
isNL x = x == '\r' || x == '\n'

||| Convert a letter to the corresponding upper-case letter, if any.
||| Non-letters are ignored.
public export
toUpper : Char -> Char
toUpper x
    = if (isLower x)
         then prim__cast_IntChar (prim__cast_CharInt x - 32)
         else x

||| Convert a letter to the corresponding lower-case letter, if any.
||| Non-letters are ignored.
public export
toLower : Char -> Char
toLower x
    = if (isUpper x)
         then prim__cast_IntChar (prim__cast_CharInt x + 32)
         else x

||| Returns true if the character is a hexadecimal digit i.e. in the range
||| [0-9][a-f][A-F].
public export
isHexDigit : Char -> Bool
isHexDigit x = elem (toUpper x) hexChars where
  hexChars : List Char
  hexChars
      = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
         'A', 'B', 'C', 'D', 'E', 'F']

||| Returns true if the character is an octal digit.
public export
isOctDigit : Char -> Bool
isOctDigit x = (x >= '0' && x <= '7')

||| Returns true if the character is a control character.
public export
isControl : Char -> Bool
isControl x
    = (x >= '\x0000' && x <= '\x001f')
       || (x >= '\x007f' && x <= '\x009f')

||| Convert the number to its backend dependent (usually Unicode) Char
||| equivalent.
public export
chr : Int -> Char
chr = prim__cast_IntChar

||| Return the backend dependent (usually Unicode) numerical equivalent of the Char.
public export
ord : Char -> Int
ord = prim__cast_CharInt

-----------------------
-- DOUBLE PRIMITIVES --
-----------------------

public export
pi : Double
pi = 3.14159265358979323846

public export
euler : Double
euler = 2.7182818284590452354

public export
exp : Double -> Double
exp x = prim__doubleExp x

public export
log : Double -> Double
log x = prim__doubleLog x

public export
pow : Double -> Double -> Double
pow x y = exp (y * log x) -- prim__doublePow x y

public export
sin : Double -> Double
sin x = prim__doubleSin x

public export
cos : Double -> Double
cos x = prim__doubleCos x

public export
tan : Double -> Double
tan x = prim__doubleTan x

public export
asin : Double -> Double
asin x = prim__doubleASin x

public export
acos : Double -> Double
acos x = prim__doubleACos x

public export
atan : Double -> Double
atan x = prim__doubleATan x

public export
sinh : Double -> Double
sinh x = (exp x - exp (-x)) / 2

public export
cosh : Double -> Double
cosh x = (exp x + exp (-x)) / 2

public export
tanh : Double -> Double
tanh x = sinh x / cosh x

public export
sqrt : Double -> Double
sqrt x = prim__doubleSqrt x

public export
floor : Double -> Double
floor x = prim__doubleFloor x

public export
ceiling : Double -> Double
ceiling x = prim__doubleCeiling x

------------
-- RANGES --
------------

-- These functions are here to support the range syntax:
-- range expressions like `[a..b]` are desugared to `rangeFromXXX` calls.

public export
countFrom : n -> (n -> n) -> Stream n
countFrom start diff = start :: countFrom (diff start) diff

public export
covering
takeUntil : (n -> Bool) -> Stream n -> List n
takeUntil p (x :: xs)
    = if p x
         then [x]
         else x :: takeUntil p xs

public export
covering
takeBefore : (n -> Bool) -> Stream n -> List n
takeBefore p (x :: xs)
    = if p x
         then []
         else x :: takeBefore p xs

public export
interface Range a where
  constructor MkRange
  rangeFromTo : a -> a -> List a
  rangeFromThenTo : a -> a -> a -> List a

  rangeFrom : a -> Stream a
  rangeFromThen : a -> a -> Stream a

-- Idris 1 went to great lengths to prove that these were total. I don't really
-- think it's worth going to those lengths! Let's keep it simple and assert.
public export
Range Nat where
  rangeFromTo x y = case compare x y of
    LT => assert_total $ takeUntil (>= y) (countFrom x S)
    EQ => pure x
    GT => assert_total $ takeUntil (<= y) (countFrom x (\n => minus n 1))
  rangeFromThenTo x y z = case compare x y of
    LT => if z >= x
             then assert_total $ takeBefore (> z) (countFrom x (plus (minus y x)))
             else Nil
    EQ => if x == z then pure x else Nil
    GT => assert_total $ takeBefore (< z) (countFrom x (\n => minus n (minus x y)))
  rangeFrom x = countFrom x S
  rangeFromThen x y
      = if y > x
           then countFrom x (plus (minus y x))
           else countFrom x (\n => minus n (minus x y))

public export
(Integral a, Ord a, Neg a) => Range a where
  rangeFromTo x y = case compare x y of
    LT => assert_total $ takeUntil (>= y) (countFrom x (+1))
    EQ => pure x
    GT => assert_total $ takeUntil (<= y) (countFrom x (\x => x-1))
  rangeFromThenTo x y z = case compare (z - x) (z - y) of
    -- Go down
    LT => assert_total $ takeBefore (< z) (countFrom x (\n => n - (x - y)))
    -- Meaningless
    EQ => if x == y && y == z then pure x else Nil
    -- Go up
    GT => assert_total $ takeBefore (> z) (countFrom x (+ (y-x)))
  rangeFrom x = countFrom x (1+)
  rangeFromThen x y
      = if y > x
           then countFrom x (+ (y - x))
           else countFrom x (\n => n - (x - y))


import Data.Vect

my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + my_length xs

my_reverse : List a -> List a
my_reverse [] = []
my_reverse (x :: xs) = reverse xs ++ [x]

my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: map f xs

my_vect_map : (a -> b) -> Vect k a -> Vect k b
my_vect_map f [] = []
my_vect_map f (x :: xs) = f x :: map f xs

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith (\x, y => x :: y) x xsTrans

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (\x, y => x + y) x y :: addMatrix xs ys

multMatrix : Num a => Vect n (Vect m a) ->
                      Vect m (Vect p a) ->
                      Vect n (Vect p a)
multMatrix xs ys = multHelper xs (transposeMat ys)
  where
        dot : Num a => Vect k a -> Vect k a -> a
        dot xs ys = sum $ map (\ (s1, s2) => s1 * s2) (zip xs ys)

        multHelper : Num a => Vect n (Vect m a) ->
                              Vect p (Vect m a) ->
                              Vect n (Vect p a)
        multHelper [] _ = []
        multHelper (x :: xs) ys = map (dot x) ys :: multHelper xs ys


> module Isomorphism.Properties

> import Control.Isomorphism

> -- import Isomorphism.Operations
> import Fun.Properties
> import Basic.Operations

> %default total
> %access public export

> |||
> isoEq : {A, B : Type} -> A = B -> Iso A B
> isoEq Refl = isoRefl
> %freeze isoEq

> |||
> isoCong : {A : Type} -> {x : A} -> {y : A} -> {P : A -> Type} -> x = y -> Iso (P x) (P y)
> isoCong {x} {P} prf = replace {P = \ z => Iso (P x) (P z)} prf isoRefl
> %freeze isoCong

Injectivity of to and from

> injectiveFrom : {A, B : Type} -> (iso : Iso A B) -> Injective1 (from iso)
> injectiveFrom {A} {B} (MkIso to from toFrom fromTo) b1 b2 p = s3 where
>   s1 : from b1 = from b2
>   s1 = p
>   s2 : to (from b1) = to (from b2)
>   s2 = cong s1
>   s3 : b1 = b2
>   s3 = replace2 {a = B} {a1 = to (from b1)} {a2 = b1}
>                 {b = B} {b1 = to (from b2)} {b2 = b2}
>                 {P = \ a => \b => a = b}
>                 (toFrom b1) (toFrom b2) s2
> %freeze injectiveFrom

> {-

> ---}


import Data.Vect
import Data.Vect.Elem
import Decidable.Equality

removeElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a
removeElem_v1 value (x :: xs) = case decEq value x of
                                     Yes prf => xs
                                     No contra => ?removeElem_v1_rhs -- x :: removeElem_v1 value xs

Uninhabited (2 + 2 = 5) where
    uninhabited Refl impossible

{-}
removeElem : (value : a) -> (xs : Vect (S n) a) ->
             Elem value xs ->
             Vect n a
removeElem value (value :: ys) Here = ys
removeElem {n = Z} value (y :: []) (There later) = absurd later
removeElem {n = (S k)} value (y :: ys) (There later)
                                          = y :: removeElem value ys later

removeElem_auto : (value : a) -> (xs : Vect (S n) a) ->
                  {auto prf : Elem value xs} -> Vect n a
removeElem_auto value xs {prf} = removeElem value xs prf
-}

removeElem : {n : _} ->
             (value : a) -> (xs : Vect (S n) a) ->
             {auto prf : Elem value xs} ->
             Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later}
                                          = y :: removeElem value ys

my_elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool
my_elem value [] = False
my_elem value (x :: xs) = case value == x of
                               False => my_elem value xs
                               True => True

not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible

not_in_tail : (contra1 : Elem value xs -> Void) -> (contra : (value = x) -> Void) -> Elem value (x :: xs) -> Void
not_in_tail contra1 contra Here = contra Refl
not_in_tail contra1 contra (There later) = contra1 later

my_decElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
my_decElem value [] = No not_in_nil
my_decElem value (x :: xs)
      = case decEq value x of
            (Yes Refl) => Yes Here
            (No contra) => case my_decElem value xs of
                                (Yes prf) => Yes (There prf)
                                (No contra1) => No (not_in_tail contra1 contra)


module Lists

%elim data NatPair = MkPair Nat Nat

natFst : NatPair -> Nat
natFst (MkPair a b) = a

natSnd : NatPair -> Nat
natSnd (MkPair a b) = b

pairIsSurjective : (a:Nat) -> (b:Nat) -> (MkPair a b) = (MkPair (natFst (MkPair a b)) (natSnd (MkPair a b)))
pairIsSurjective = ?pairIsSurjectiveCase

pairIsSurjective2 : (p:NatPair) -> p = MkPair (natFst p) (natSnd p)
pairIsSurjective2 = ?pairSurCase

Lists.pairSurCase = proof
  intro
  induction p
  intros
  compute
  trivial

mkNatPair : NatPair -> (Nat,Nat)
mkNatPair (MkPair a b) = (a,b)

surjectivePairingStuck : (a:NatPair) -> a = (MkPair (natFst a) (natSnd a))
surjectivePairingStuck = ?surjectivePairingStuckCase

Lists.surjectivePairingStuckCase = proof
  intros
  induction a
  compute
  intros
  trivial

%elim data NatList =
  Nil
  | Cons Nat NatList

repeat : (n:Nat) -> (count:Nat) -> NatList
repeat n Z = Nil
repeat n (S k) = Cons n (repeat n k)

length : (n:NatList) -> Nat
length Nil = Z
length (Cons x xs) = S (length xs)

app : (a:NatList) -> (b:NatList) -> NatList
app Nil b = b
app (Cons x xs) b = Cons x (app xs b)

syntax [x] "::" [xs] = Cons x xs
syntax "[ ]" = Nil
syntax "[" [x] "]" = (Cons x Nil)
syntax "[" [x] "," rem "," [y] "]" = (Cons x (app rem (Cons y Nil)))
syntax [a] "++" [b] = app a b

head : (default:Nat) -> NatList -> Nat
head n Nil = n
head n (Cons x xs) = x

tail : NatList -> NatList
tail Nil = Nil
tail (Cons x xs) = xs

filterZeros : NatList -> NatList
filterZeros Nil = Nil
filterZeros (Cons Z xs) = filterZeros xs
filterZeros (Cons n xs) = Cons n (filterZeros xs)

testFilterZeros : filterZeros $ Cons 0 (Cons 1 Nil) = (Cons 1 Nil)
testFilterZeros  = refl

oddMembers : NatList -> NatList
oddMembers Nil = Nil
oddMembers (Cons Z xs) = oddMembers xs
oddMembers (Cons x xs) = if (mod x 2) == 1
                            then Cons x (oddMembers xs)
                            else oddMembers xs

testOddMembers : oddMembers $ Cons Z (Cons 1 (Cons 2 Nil)) = (Cons 1 Nil)
testOddMembers = refl

countOddMembers : NatList -> Nat
countOddMembers xs = Lists.length $ oddMembers xs

testCountOddMembers : countOddMembers (Cons Z (Cons 1 (Cons 2 Nil))) = (S Z)
testCountOddMembers = refl

appNilEnd : (xs:NatList) -> app xs Lists.Nil = xs
appNilEnd xs = ?appNilProof

Lists.appNilProof = proof
  intro
  induction xs
  trivial
  intros
  compute
  rewrite ihn__1
  trivial

rCons : (xs:NatList) -> (i:Nat) -> NatList
rCons Nil i = Cons i Lists.Nil
rCons (Cons x xs) i = Cons x (rCons xs i)

rev : NatList -> NatList
rev Nil = Nil
rev (Cons x xs) = rCons xs x

lengthRCons : (n:Nat) -> (xs:NatList) -> length (rCons xs n) = S (length xs)
lengthRCons n xs = ?lengthRConsProof

Lists.lengthRConsProof = proof
  intros
  induction xs
  trivial
  intros
  compute
  rewrite ihn__1
  trivial

revLengthRefl : (xs:NatList) -> length (rev xs) = length xs
revLengthRefl = ?revLengthReflProof

Lists.revLengthReflProof = proof
  intros
  induction xs
  trivial
  intros
  compute
  rewrite (lengthRCons n__0 n__1)
  trivial

revRCons : (xs:NatList) -> (n:Nat) -> rev (rCons xs n) = Cons n (rev xs)
revRCons Lists.Nil n = ?revRConsBaseProof
revRCons xs n = ?revRConsSuccProof

Lists.revRConsBaseProof = proof
  intros
  trivial

revInvolutive : rev $ rev xs = xs
revInvolutive = ?revInvolutiveProof


module OfficialCrashCourse.DepTypes

import Data.Vect

-- isSingle : Type
isSingleton : Bool -> Type
isSingleton True = Nat
isSingleton False = List Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle True = 0
mkSingle False = []

-- Vect is like a List having length Nat elements
data Vector : Nat -> Type -> Type where
    NilVec  : Vector Z a
    (::) : a -> Vector k a -> Vector (S k) a

-- Defining a set of Nat many elems like above
data FinSet : Nat -> Type where
    FZ : FinSet (S k) -- zeroth element
    FS : FinSet k -> FinSet (S k) -- k + 1 th element from k th element

-- using implicit arguments and proofs
appVec: Ord a => Vector n a -> Vector m a -> Vector (n + m) a
appVec NilVec vecm = vecm -- 0 + left  = left
appVec {n} vecn NilVec = rewrite plusZeroRightNeutral n in vecn -- left + 0 = left
appVec {n=(S n)} {m=(S m)} ( x :: xs) (y :: ys) =
    rewrite sym $ plusSuccRightSucc n m in -- using sym to flip args, S (left + right) = left + S right
    x :: y :: (appVec xs ys)

-- what is the i th element in a n sized Vector with i <= n?
indexer : Fin n -> Vect n a -> a
indexer FZ (x :: _) = x
indexer (FS i) (_ :: xs) = indexer i xs

isEmpty : {n: Nat} -> Vect n a -> Bool
isEmpty {n = Z} _ = True
isEmpty _ = False


module Universality

import public Category
import public Isomorphism

%default total

public export
IsUnique : {cat : Category} -> {a, b : Object cat} ->
  (property : Morphism cat a b -> Type) -> (f : Morphism cat a b) -> Type
IsUnique {cat} {a} {b} property f =
    (property f, (g : Morphism cat a b) -> property g -> g = f)

public export
IsOnlyMorphism : {cat : Category} -> {a, b : Object cat} ->
    Morphism cat a b -> Type
IsOnlyMorphism f = IsUnique (\_ => ()) f

public export
OnlyMorphismIsUnique : {cat : Category} -> {a, b : Object cat} ->
    {f : Morphism cat a b} -> IsOnlyMorphism {cat} {a} {b} f ->
    (g, h : Morphism cat a b) -> g = h
OnlyMorphismIsUnique (_, onlyAB) g h = rewrite (onlyAB h ()) in (onlyAB g ())

public export
IsTerminal : {cat : Category} -> (a : Object cat) -> Type
IsTerminal {cat} a = (b : Object cat) -> DPair (Morphism cat b a) IsOnlyMorphism

public export
IdOnlyTerminalEndomorphism : {cat : Category} -> {a : Object cat} ->
  (aIsTerminal : IsTerminal {cat} a) -> (f : Morphism cat a a) ->
  f = Identity cat a
IdOnlyTerminalEndomorphism {cat} {a} aIsTerminal f =
  OnlyMorphismIsUnique (snd (aIsTerminal a)) f (Identity cat a)

public export
IsInitial : {cat : Category} -> (a : Object cat) -> Type
IsInitial {cat} a = (b : Object cat) -> DPair (Morphism cat a b) IsOnlyMorphism

public export
IdOnlyInitialEndomorphism : {cat : Category} -> {a : Object cat} ->
  (aIsInitial : IsInitial {cat} a) -> (f : Morphism cat a a) ->
  f = Identity cat a
IdOnlyInitialEndomorphism {cat} {a} aIsInitial f =
  OnlyMorphismIsUnique (snd (aIsInitial a)) f (Identity cat a)

public export
IsUniqueMorphismWithProperty : {cat : Category} -> {a, b : Object cat} ->
  (property : Morphism cat a b -> Type) -> (m : Morphism cat a b) -> Type
IsUniqueMorphismWithProperty property m =
  (property m, (m' : Morphism cat a b) -> property m' -> m' = m)

public export
AreUniquelyIsomorphic : {cat : Category} -> (a, b : Object cat) -> Type
AreUniquelyIsomorphic {cat} a b =
  (iso : Isomorphic a b **
   IsUniqueMorphismWithProperty IsIsomorphism (fst iso))

public export
IsUniqueUpToUniqueIsomorphism : {cat : Category} ->
  (property : Object cat -> Type) -> Object cat -> Type
IsUniqueUpToUniqueIsomorphism {cat} property a =
  (property a,
   (b : Object cat) -> property b -> AreUniquelyIsomorphic a b)


module Solutions.Dependent

%default total

--------------------------------------------------------------------------------
--          Length-Indexed Lists
--------------------------------------------------------------------------------

data Vect : (len : Nat) -> Type -> Type where
  Nil  : Vect 0 a
  (::) : a -> Vect n a -> Vect (S n) a

-- 1
head : Vect (S n) a -> a
head (x :: _) = x
head Nil impossible

-- 2
tail : Vect (S n) a -> Vect n a
tail (_ :: xs) = xs
tail Nil impossible

-- 3
zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d
zipWith3 f []        []        []        = []
zipWith3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: zipWith3 f xs ys zs

-- 4
-- Since we only have a `Semigroup` constraint, we can't conjure
-- a value of type `a` out of nothing in case of an empty list.
-- We therefore have to return a `Nothing` in case of an empty list.
foldSemi : Semigroup a => List a -> Maybe a
foldSemi []        = Nothing
foldSemi (x :: xs) = Just . maybe x (x <+>) $ foldSemi xs

-- 5
-- the `Nil` case is impossible here, so unlike in Exercise 4,
-- we don't need to wrap the result in a `Maybe`.
-- However, we need to pattern match on the tail of the Vect to
-- decide whether to invoke `foldSemiVect` recursively ore not
foldSemiVect : Semigroup a => Vect (S n) a -> a
foldSemiVect (x :: [])         = x
foldSemiVect (x :: t@(_ :: _)) = x <+> foldSemiVect t

-- 6
iterate : (n : Nat) -> (a -> a) -> a -> Vect n a
iterate 0     _ _ = Nil
iterate (S k) f v = v :: iterate k f (f v)

-- 7
generate : (n : Nat) -> (s -> (s,a)) -> s -> Vect n a
generate 0     _ _ = Nil
generate (S k) f v =
  let (v', va) = f v
   in va :: generate k f v'

-- 8
fromList : (as : List a) -> Vect (length as) a
fromList []        = []
fromList (x :: xs) = x :: fromList xs

-- 9
-- Lookup the type and implementation of functions `maybe` `const` and
-- try figuring out, what's going on here. An alternative implementation
-- would of course just pattern match on the argument.
maybeSize : Maybe a -> Nat
maybeSize = maybe 0 (const 1)

fromMaybe : (m : Maybe a) -> Vect (maybeSize m) a
fromMaybe Nothing  = []
fromMaybe (Just x) = [x]

--------------------------------------------------------------------------------
--          Fin: Safe Indexing into Vectors
--------------------------------------------------------------------------------

data Fin : (n : Nat) -> Type where
  FZ : {0 n : Nat} -> Fin (S n)
  FS : (k : Fin n) -> Fin (S n)

(++) : Vect m a -> Vect n a -> Vect (m + n) a
(++) []        ys = ys
(++) (x :: xs) ys = x :: (xs ++ ys)

replicate : (n : Nat) -> a -> Vect n a
replicate 0     _ = []
replicate (S k) x = x :: replicate k x

zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWith _ []        []        = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

-- 1
update : (a -> a) -> Fin n -> Vect n a -> Vect n a
update f FZ     (x :: xs) = f x :: xs
update f (FS k) (x :: xs) = x :: update f k xs

-- 2
insert : a -> Fin (S n) -> Vect n a -> Vect (S n) a
insert v FZ     xs         = v :: xs
insert v (FS k) (x :: xs)  = x :: insert v k xs
insert v (FS k) []  impossible

-- 3
-- The trick here is to pattern match on the tail of the
-- vector in the `FS k` case and realize that an empty
-- tail is impossible. Otherwise we won't be able to
-- convince the type checker, that the vector's tail is
-- non-empty in the recursive case.
delete : Fin (S n) -> Vect (S n) a -> Vect n a
delete FZ     (_ :: xs)          = xs
delete (FS k) (x :: xs@(_ :: _)) = x :: delete k xs
delete (FS k) (x :: []) impossible

-- 4
safeIndexList : (xs : List a) -> Fin (length xs) -> a
safeIndexList (x :: _)  FZ     = x
safeIndexList (x :: xs) (FS k) = safeIndexList xs k
safeIndexList Nil _ impossible

-- 5
finToNat : Fin n -> Nat
finToNat FZ     = Z
finToNat (FS k) = S $ finToNat k

take : (k : Fin (S n)) -> Vect n a -> Vect (finToNat k) a
take FZ     x         = []
take (FS k) (x :: xs) = x :: take k xs

-- 6
minus : (n : Nat) -> Fin (S n) -> Nat
minus n FZ         = n
minus (S j) (FS k) = minus j k
minus 0 (FS k) impossible

-- 7
drop : (k : Fin (S n)) -> Vect n a -> Vect (minus n k) a
drop FZ     xs        = xs
drop (FS k) (_ :: xs) = drop k xs

-- 8
splitAt :  (k : Fin (S n))
        -> Vect n a
        -> (Vect (finToNat k) a, Vect (minus n k) a)
splitAt k xs = (take k xs, drop k xs)

--------------------------------------------------------------------------------
--          Compile-Time Computations
--------------------------------------------------------------------------------

-- 1
flattenList : List (List a) -> List a
flattenList []          = []
flattenList (xs :: xss) = xs ++ flattenList xss

flattenVect : Vect m (Vect n a) -> Vect (m * n) a
flattenVect []          = []
flattenVect (xs :: xss) = xs ++ flattenVect xss

-- 2
take' : (m : Nat) -> Vect (m + n) a -> Vect m a
take' 0     _         = []
take' (S k) (x :: xs) = x :: take' k xs
take' (S k) Nil impossible

drop' : (m : Nat) -> Vect (m + n) a -> Vect n a
drop' 0     xs        = xs
drop' (S k) (x :: xs) = drop' k xs
drop' (S k) Nil impossible

splitAt' : (m : Nat) -> Vect (m + n) a -> (Vect m a, Vect n a)
splitAt' m xs = (take' m xs, drop' m xs)

-- 3
-- Since we must call `replicate` in the `Nil` case, `k`
-- must be a non-erased argument. I used an implicit argument here,
-- since this reflects the type of the mathematical function
-- more closely.
--
-- Empty matrices probably don't make too much sense,
-- so we could also request at the type-level that `k` and `m`
-- are non-zero, in which case both values could be derived
-- by pattern matching on the vectors.
transpose : {k : _} -> Vect m (Vect k a) -> Vect k (Vect m a)
transpose []          = replicate k []
transpose (xs :: xss) = zipWith (::) xs (transpose xss)


module ExVectDecEq

import Decidable.Equality

%default total

data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : a -> Vect k a -> Vect (S k) a

{-
  interface DecEq ty where
    decEq : (val1 : ty) -> (val2 : ty) -> Dec (val1 = val2)

  data Dec : (prop : Type) -> Type where
    Yes : (prf : prop) -> Dec prop
    No : (contra ; prop -> Void) -> Dec prop
-}

headUnequal : DecEq a => { xs: Vect n a } -> { ys : Vect n a } ->
                       (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => { xs : Vect n a } -> { ys : Vect n a } ->
                         (contra : (xs = ys) -> Void) -> ((x :: xs) = (y:: ys)) -> Void
tailUnequal contra Refl = contra Refl

DecEq a => DecEq (Vect n a) where
  decEq [] [] = Yes Refl
  decEq [] _ = No ?nilNotEqualToCons
  decEq _ [] = No ?consNotEqualToNil
  decEq (x :: xs) (y :: ys) = case decEq x y of
                                   No contra => No (headUnequal contra)
                                   Yes Refl => case decEq xs ys of
                                                    No contra => No (tailUnequal contra)
                                                    Yes Refl => Yes Refl


module Basen

import Data.Fin

--Defines a data type Base that behaves like a list
data Base: (n: Nat) -> Type where
  Ones: (n: Nat) -> (Fin n) -> Base n
  Next: (n: Nat) -> (Fin n) -> (Base n) -> (Base n)

--Auxiliary function that reverses a Base (S n) onto anpther given Base (S n)
Revonto: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
Revonto n accum (Ones (S n) x) = Next (S n) x accum
Revonto n accum (Next (S n) x y) = Revonto n (Next (S n) x accum) y

--Reverses a Base (S n)
Rev: (n: Nat) -> (Base (S n)) -> (Base (S n))
Rev n (Ones (S n) x) = Ones (S n) x
Rev n (Next (S n) x y) = Revonto n (Ones (S n) x) y

concat: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
concat n (Ones (S n) x) y = Next (S n) x y
concat n (Next (S n) x z) y = Next (S n) x (concat n z y)

--Fin to Nat
tonatFin: (n: Nat) -> Fin(n) -> Nat
tonatFin (S k) FZ = Z
tonatFin (S k) (FS x) = S (tonatFin k x)

--List Fin to Nat
tonat: (n: Nat) -> Base (S n) -> Nat
tonat n (Ones (S n) FZ) = Z
tonat Z (Ones (S Z) (FS x)) impossible
tonat (S k) (Ones (S (S k)) (FS x)) = S(tonat k (Ones (S k) x))
tonat n (Next (S n) x y) = (tonat n (Ones (S n) x)) + (tonat n y)

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl a Z = (0, a)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)

--Nat to Fin (modular values)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat Z (S j) = FZ
tofinNat (S k) (S j) = case lte (S k) (S j) of
                True => FS (tofinNat k j)
                False =>  (tofinNat (snd(Eucl (S k) (S j))) (S j))

strp: (Base (S n)) -> (Base (S n))
strp (Ones (S n) x) = (Ones (S n) x)
strp (Next (S n) x y) = case x of
                  FZ => strp(y)
                  FS z => Next (S n) x y

-- Nat to List Fin n (base n representation)
tofin: Nat -> (n: Nat) -> Base (S n)
tofin Z n = Ones (S n) FZ
tofin (S k) n = strp(concat n (tofin q n) (Ones (S n) rem)) where
                    rem: Fin (S n)
                    rem = tofinNat (snd(Eucl (S k) (S n))) (S n)
                    q: Nat
                    q = fst(Eucl (S k) (S n))

--embedding Fin n in Fin S n vertically
embn: (n: Nat) -> Fin n -> Fin (S n)
embn (S k) FZ = FZ
embn (S k) (FS x) = FS (embn k x)

--Generates n in (Fin (S n))
Genn: (n: Nat) -> (Fin (S n))
Genn Z = FZ
Genn (S k) = FS (Genn k)

--Checks if a given element of Fin (S n) is in fact n
Isn: (n: Nat) -> (p: Fin (S n)) -> Bool
Isn Z x = True
Isn (S k) FZ = False
Isn (S k) (FS x) = Isn k x

--Proves that the definitional equality for Isn holds
IsnisIsn: (n: Nat) -> (p: Fin (S n)) -> (Isn (S n) (FS p)) = (Isn n p)
IsnisIsn n p = Refl

--Proves that if a given (FS x) is not n in (Fin (S n)), then x is not n-1 in (Fin n)
IsNotnPf:  (n: Nat) -> (p: Fin (S n)) ->  ((Isn (S n) (FS p)) = False) -> ((Isn n p) = False)
IsNotnPf Z _ Refl impossible
IsNotnPf (S k) FZ prf = Refl
IsNotnPf (S k) (FS x) prf = trans (sym (IsnisIsn (S k) (FS x))) prf

--Gives a back embedding whenever the value is not Genn
Predec: (n: Nat) -> (p: Fin (S n)) -> ((Isn n p) = False) -> (Fin n)
Predec Z _ Refl impossible
Predec (S k) FZ Refl = FZ
Predec (S k) (FS x) prf = FS (Predec k x (IsNotnPf (S k) (FS x) prf))

--Decidable type for Isn
DecIsn: (n: Nat) -> (p: (Fin (S n))) -> Either (Isn n p = True) (Isn n p = False)
DecIsn Z p = Left Refl
DecIsn (S k) FZ = Right Refl
DecIsn (S k) (FS x) = case (DecIsn k x) of
                        Left l => Left (trans (IsnisIsn k x) l)
                        Right r => Right (trans (IsnisIsn k x) r)

--adding two Fin n's
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin Z x y = (FZ,  FZ)
addfin (S k) FZ y = (FZ, y)
addfin (S k) (FS x) y = let
                    a = Genn (S k)
                    b = the (Fin (S (S k))) FZ
                    c = the (Fin (S k)) FZ
                    w = fst(addfin (S k) (embn (S k) x) y)
                    z = snd(addfin (S k) (embn (S k) x) y)
                    in
                    case (DecIsn (S k) z) of
                             Left l => (FS c, b)
                             Right r => (w, FS(Predec (S k) z r))

--adding two reversed lists as specified
addfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinl n (Ones (S n) x) (Ones (S n) y) = case (addfin n x y) of
                              (FZ, a) => Ones (S n) a
                              (FS c, a) => Next (S n) a (Ones (S n) (FS c))
addfinl n (Ones (S n) x) (Next (S n) y z) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) z)
addfinl n (Next (S n) x z) (Ones (S n) y) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) z)
addfinl n (Next (S n) x z) (Next (S n) y w) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) (addfinl n z w))

--adding two lists
addfinlist: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinlist n xs ys = (Rev n (addfinl n (Rev n xs) (Rev n ys)))

--multiply two reversed lists in Fin S n
mulfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
mulfinl n (Ones (S n) FZ) y = Ones (S n) FZ
mulfinl n (Ones (S n) (FS x)) y = addfinl n y (mulfinl n (Ones (S n) (embn n x)) y)
mulfinl n (Next (S n) FZ z) y = Next (S n) FZ (mulfinl n z y)
mulfinl n (Next (S n) (FS x) z) y = addfinl n y (mulfinl n (Next (S n) (embn n x) z) y)

--multiply two lists
mulfinList: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
mulfinList n xs ys = Rev n (mulfinl n (Rev n xs) (Rev n ys))

--Custom "functions are functors" function
ap: (x: Type) -> (y: Type) -> (f: x->y) -> (n = m) -> (f n = f m)
ap x y f Refl = Refl


-- ------------------------------------------------------------- [ Metrics.idr ]
-- Module    : Metrics.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Readability Metrics
|||
||| http://www.editcentral.com/gwt1/EditCentral.html
module Readability.Metrics

%access export

public export
data RMetricTy = FLESCH | ARI | KINCAID | COLEMAN | FOG | SMOG

||| Flesch reading ease score
|||
||| ```java
||| 206.835 - (1.015 * wordCount) / sentenceCount - (84.6 * syllableCount) / wordCount;
||| ```
||| @wcount Number of words
||| @scount Number of sentences.
||| @sycount Number of syllables.
flesch : (wcount : Double) -> (scount : Double) -> (sycount : Double) -> Double
flesch ws ss sys = 206.835 - (1.015 * ws) / ss - (84.6 * sys) / ws

||| Automated readability index
|||
||| ```java
||| (4.71 * letterNumberCount) / wordCount + (0.5 * wordCount) / sentenceCount -21.43;
||| ```
||| @ccount Number of Characters
||| @wcount Number of words.
||| @scount Number of sentences.
ari : (ccount : Double) -> (wcount : Double) -> (scount : Double) -> Double
ari as ws ss = (4.71 * as) / ws + (0.5 * ws) / ss - 21.43

||| Flesch-Kincaid grade level
|||
||| ```java
||| (0.39 * wordCount) / sentenceCount + (11.8 * syllableCount) / wordCount - 15.59;
||| ```
||| @wcount The number of words
||| @scount Number of sentences
||| @sycount Number of syllables.
kincaid : (wcount : Double) -> (scount : Double) -> (sycount : Double) -> Double
kincaid ws ss sys = (0.39 * ws) / ss + (11.8 * sys) / ws - 15.59

||| Coleman-Liau index
|||
||| ```java
||| (5.89 * letterNumberCount) / wordCount - (30.0 * sentenceCount) / wordCount - 15.8;
||| ```
||| @ccount Number of letters and digits.
||| @wcount The number of words.
||| @scount The number of sentences.
coleman : (ccount : Double) -> (wcount : Double) -> (scount : Double) -> Double
coleman as ws ss = (5.89 * as) / ws - (30.0 * ss) / ws - 15.8

||| Gunning fog index
|||
||| ```java
|||  0.4 * ( (double)wordCount / sentenceCount + (100.0 * complexCount) / wordCount );
||| ```
||| @wcount Number of Words
||| @scount Number of sentences
||| @bwcount Number of words with three plus syllables.
fog : (wcount : Double) -> (scount : Double) -> (bwcount : Double) -> Double
fog ws ss bs = 0.4 * ( ws / ss + (100.0 * bs) / ws)

||| SMOG index
|||
||| ```java
||| Math.sqrt( complexCount * 30.0 / sentenceCount ) + 3.0;
||| ```
||| @bwcount The number of word with three plus syllables.
||| @scount The number of sentences.
smog : (bwcount : Double) -> (scount : Double) -> Double
smog bs ss = 3.0 + sqrt (bs * (30 / ss))

Show RMetricTy where
  show FLESCH  = "FLESCH"
  show ARI     = "ARI"
  show KINCAID = "KINCAID"
  show COLEMAN = "COLEMAN"
  show FOG     = "FOG"
  show SMOG    = "SMOG"

Eq RMetricTy where
  (==) FLESCH  FLESCH  = True
  (==) ARI     ARI     = True
  (==) KINCAID KINCAID = True
  (==) COLEMAN COLEMAN = True
  (==) FOG     FOG     = True
  (==) SMOG    SMOG    = True
  (==) _        _      = False

readRMetricTy : String -> Maybe RMetricTy
readRMetricTy s =
  case toLower s of
    "flesch"  => Just FLESCH
    "ari"     => Just ARI
    "kincaid" => Just KINCAID
    "coleman" => Just COLEMAN
    "fog"     => Just FOG
    "smog"    => Just SMOG
    otherwise  => Nothing

public export
record ReadResult where
  constructor MkReadResult
  flesch  : Double
  ari     : Double
  kincaid : Double
  coleman : Double
  fog     : Double
  smog    : Double

toList : ReadResult -> List (RMetricTy, Double)
toList (MkReadResult a b c d e f) =
    [ (FLESCH,  a)
    , (ARI,     b)
    , (KINCAID, c)
    , (COLEMAN, d)
    , (FOG,     e)
    , (SMOG,    f)]

Show ReadResult where
  show rslt = show (Metrics.toList rslt)
-- --------------------------------------------------------------------- [ EOF ]


module TakeN

data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

-- Ex. 10.1 # 1
total
takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             (Exact n_xs) => Exact $ x :: n_xs

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

-- Ex. 10.1 # 2
halves : List a -> (List a, List a)
halves xs = splitHalf (div (length xs) 2) xs
  where
  splitHalf : Nat -> List a -> (List a, List a)
  splitHalf n xs with (takeN n xs)
    splitHalf n xs | Fewer = ([], xs)
    splitHalf n (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)


> module So.Properties

> import Data.So

> import Decidable.Predicates
> import Unique.Predicates

> %default total
> %access public export
> %auto_implicits on

* Introduction and elimination rules

> |||
> soIntro : (b : Bool) -> b = True -> So b
> soIntro True  Refl   = Oh
> soIntro False contra = void (trueNotFalse (sym contra))

> |||
> soElim : (b : Bool) -> So b -> b = True
> soElim True  Oh = Refl
> soElim False Oh impossible

** Or

> |||
> soOrIntro1 : (b1 : Bool) -> (b2 : Bool) -> So b1 -> So (b1 || b2)
> soOrIntro1 True _  Oh = Oh

> |||
> soOrIntro2 : (b1 : Bool) -> (b2 : Bool) -> So b2 -> So (b1 || b2)
> soOrIntro2 True  True Oh = Oh
> soOrIntro2 False True Oh = Oh

> |||
> soOrElim : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> Either (So b1) (So b2)
> soOrElim True  True  Oh = Left Oh
> soOrElim True  False Oh = Left Oh
> soOrElim False True  Oh = Right Oh
> soOrElim False False Oh impossible

> |||
> soOrElim1 : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> So (not b1) -> So b2
> soOrElim1 True  True  Oh Oh impossible
> soOrElim1 True  False Oh Oh impossible
> soOrElim1 False True  Oh Oh = Oh
> soOrElim1 False False Oh Oh impossible

> |||
> soOrElim2 : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> So (not b2) -> So b1
> soOrElim2 True  True  Oh Oh impossible
> soOrElim2 True  False Oh Oh = Oh
> soOrElim2 False True  Oh Oh impossible
> soOrElim2 False False Oh Oh impossible

** And

> |||
> soAndElim1 : (b1 : Bool) -> (b2 : Bool) -> So (b1 && b2) -> So b1
> soAndElim1 True  True  Oh = Oh
> soAndElim1 True  False Oh impossible
> soAndElim1 False True  Oh impossible
> soAndElim1 False False Oh impossible

> |||
> soAndElim2 : (b1 : Bool) -> (b2 : Bool) -> So (b1 && b2) -> So b2
> soAndElim2 True  True  Oh = Oh
> soAndElim2 True  False Oh impossible
> soAndElim2 False True  Oh impossible
> soAndElim2 False False Oh impossible

* Counter factuals

> |||
> contra : {b : Bool} -> b = False -> So b -> Void
> contra {b} p q = trueNotFalse (trans (sym (soElim b q)) p)

* Decidability

> ||| Lifted Booleans are decidable
> decSo : (b : Bool) -> Dec (So b)
> decSo True  = Yes Oh
> decSo False = No (\ oh => absurd oh)

> ||| Lifted Boolean functions are decidable
> dec1So : {A : Type} -> (p : A -> Bool) -> Dec1 (\ a => So (p a))
> dec1So p a = decSo (p a)

* Uniqueness

> ||| Lifted Booleans are unique
> uniqueSo : (b : Bool) -> Unique (So b)
> uniqueSo True  Oh Oh = Refl
> uniqueSo False Oh Oh impossible

> ||| Lifted Boolean functions are unique
> unique1So : {A : Type} -> (p : A -> Bool) -> Unique1 (\ a => So (p a))
> unique1So p a = uniqueSo (p a)

> {-

> ---}


module NatTree

import Data.Fin

data NatTree : Type where
  Leaf : Nat -> NatTree
  Node : NatTree -> NatTree -> NatTree

tsum : NatTree -> Nat
tsum (Leaf k) = k
tsum (Node x y) = (tsum x) + (tsum y)

recNT : (x: Type) -> (Nat -> x) -> (NatTree -> x -> NatTree -> x -> x)
  -> (NatTree -> x)
recNT x f g (Leaf k) = f k
recNT x f g (Node y z) = g y yValue z zValue where
  yValue =  recNT x f g y
  zValue = recNT x f g z

tsumTheHardWay : NatTree -> Nat
tsumTheHardWay = recNT Nat leafCase nodeCase where
  leafCase = \k : Nat => k
  nodeCase = \t1 => \n1 => \t2 => \n2 => n1 + n2

flattenTree : NatTree -> List Nat
flattenTree = recNT (List Nat) leafCase nodeCase where
  leafCase = \k => k :: []
  nodeCase = \t1 => \l1 => \t2 => \l2 => (l1 ++ l2)

data FinNatTree : Type where
  FLeaf : Nat -> FinNatTree
  FNode : (n: Nat) -> ((Fin n) -> FinNatTree) -> FinNatTree

data Evil : Type where
  Diag : (Evil -> Bool) -> Evil

evil : Evil -> Bool
evil (Diag f) = not (f (Diag f))

contra : Bool
contra = evil (Diag evil)


import Data.Vect

{-
vApp : Vect n (a -> b) -> Vect n a -> Vect n b
vApp []       []         = []
vApp (f :: fs) (a :: as) = f a :: vApp fs as
-}

total
vApp : {a:Type} -> {b:Type} -> {n:Nat} ->  Vect n (a -> b) -> Vect n a -> Vect n b
vApp  []       []         = []
vApp  (f :: fs) (e :: es) = f e :: vApp fs es

--vApp {a} {b} {n=S m} (f :: fs) (e :: es) = f e :: vApp fs es


module Product_Type_Eq

%access public export
%default total

||| A proof that equality for product types are generate by the equalities of the componenets

Product_Eq_property_1 : (ty1, ty2 : Type) -> (a, b : (ty1, ty2)) ->
                        ( (fst a) = (fst b) ) -> ( (snd a) = (snd b) ) ->
                        ( a = b )

Product_Eq_property_1 ty1 ty2 (x, y) (x, y) Refl Refl = Refl


module Unsigned

%access export
%default total

||| An unsigned binary number represented with `n` bits
data Unsigned : (n : Nat) -> Type where
  ||| Built from an underlying integer
  U : Integer -> Unsigned n

-- We could require a proof for this contructor that our Integer is indeed in
-- the range 0 -> 2*n-1. We don't bother because only (trusted) functions in
-- this module can use the constructor.

||| Cast instance for `Unsigned n` to an integer
Cast (Unsigned n) Integer where
  cast (U x) = x

||| Eq instacne for equality of `Unsigned n`
Eq (Unsigned n) where
  (==) (U x) (U y) = x==y

||| Ord instance for ordering of `Unsigned n`
Ord (Unsigned n) where
  compare (U x) (U y) = compare x y

||| MinBound instance for generating extremes of `Unsigned n`
MinBound (Unsigned n) where
  minBound = U 0

||| MaxBound instance for generating extremes of `Unsigned n`
MaxBound (Unsigned n) where
  maxBound = U $ cast (power 2 n)-1

||| Safely create an `Unsigned n` from an Integer using saturation
saturate : Integer -> Unsigned n
saturate x = let tryU = U {n} x
             in if tryU > maxBound then maxBound else
                if tryU < minBound then minBound else tryU

||| Num instance for saturating arithmetic with `Unsigned n`
Num (Unsigned n) where
  (+) (U x) (U y) = saturate $ (x+y)
  (*) (U x) (U y) = saturate $ (x*y)
  fromInteger x   = saturate $ x

||| Minus operations for two `Unsigned`s. Note that we cannot implement the Neg
||| typeclass because there are no negative representations.
minus : Unsigned n -> Unsigned n -> Unsigned n
minus (U x) (U y) = U (x-y)

||| Helper function to prove that 2^n for all natural n is not 0
private
powerTwoIsNotZ : (n : Nat) -> Not (power 2 n = 0)
powerTwoIsNotZ n = believe_me -- TODO prove properly

||| Add operations for two `Unsigned`s with wrapping overflow.
addWrap : Unsigned n -> Unsigned n -> Unsigned n
addWrap (U x) (U y) = let max = power 2 n
                          res = cast x + cast y
                      in U . cast $ modNatNZ res max (powerTwoIsNotZ n)

||| Minus operations for two `Unsigned`s with wrapping overflow.
minusWrap : Unsigned n -> Unsigned n -> Unsigned n
minusWrap (U x) (U y) = let max = power 2 n
                            res = max + cast x `minus` cast y
                        in U . cast $ modNatNZ res max (powerTwoIsNotZ n)

||| Show instance for printing `Unsigned n`
Show (Unsigned n) where
  show (U x) = "U" ++ show n ++ " " ++ show x

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


module Group_property2

import congruence
import Monoid
import Group
import Group_property

%access public export

||| Property 8 - If f : g -> h is group homomorphism then f(inv(a)) = inv(f(a))
total
Group_property_8 : (dom : Type) -> ((*) : dom -> dom -> dom) -> (pfdom : IsGroup dom (*)) ->
                    (cod : Type) -> ((+) : cod -> cod -> cod) -> (pfcod : IsGroup cod (+)) ->
                    (f : dom -> cod) -> (pfhom : (Hom dom (*) pfdom cod (+) pfcod f)) ->
                    (a : dom) -> ( (f (Inv dom (*) pfdom a)) = (Inv cod (+) pfcod (f a)) )

Group_property_8 dom (*) pfdom cod (+) pfcod f pfhom a = let
                                                         pfid1_dom = (fst (snd pfdom))
                                                         e_dom1 = (fst pfid1_dom) -- identity in the IdentityExists
                                                         e_dom1_pf = (snd pfid1_dom) -- proof that e_dom1 is the identity

                                                         pfid2_dom = (fst (snd (snd pfdom)))
                                                         e_dom2 = (fst pfid2_dom) -- identity in the InverseExists
                                                         e_dom2_pf = (snd pfid2_dom) -- prood that it is the identity

                                                         pf_eq_dom_id12 = (Group_property_1 dom (*) pfdom e_dom1 e_dom2
                                                                            e_dom1_pf e_dom2_pf) -- proof that e_dom1 and e_dom2 are equal

                                                         pfid1_cod = (fst (snd pfcod))
                                                         e_cod1 = (fst pfid1_cod) -- identity in the IdentityExists
                                                         e_cod1_pf = (snd pfid1_cod) -- proof that e_cod1 is the identity

                                                         pfid2_cod = (fst (snd (snd pfcod)))
                                                         e_cod2 = (fst pfid2_cod) -- identity in the InverseExists
                                                         e_cod2_pf = (snd pfid2_cod) -- prood that it is the identity

                                                         pf_eq_cod_id12 = (Group_property_1 cod (+) pfcod e_cod1 e_cod2
                                                                            e_cod1_pf e_cod2_pf) -- proof that e_cod1 and e_cod2 are equal

                                                         a_inv_with_pf = snd (snd (snd pfdom)) a -- (Inv_with_pf dom (*) pfdom a)
                                                         a_inv = fst a_inv_with_pf
                                                         b = (f a_inv)
                                                         c = (Inv cod (+) pfcod (f a))

                                                         pf_id_to_id = (fst pfhom)
                                                         pf_res = (snd pfhom)

                                                         --aux_pf1 : ( ( Group_id dom (*) pfdom ) = (fst (snd pfdom)) )
                                                         --aux_pf1 = Refl -- proof that fst (Group_id dom (*) pfdom) = fst (fst (snd pfdom))

                                                         pf1 = (pf_res a a_inv) -- proof that f(a * a_inv) = f a + f a_inv
                                                         pf2 = (fst (snd a_inv_with_pf)) -- proof that a * a_inv = e_dom2
                                                         pf3 = congruence dom cod (a * a_inv) e_dom2 f pf2 -- proof that a * a_inv = e_dom2
                                                         pf4 = trans (sym pf1) pf3 -- proof that f(a * a_inv) = f e_dom2
                                                         pf5 = (Group_property_1 cod (+) pfcod
                                                               (f e_dom1) e_cod1 pf_id_to_id e_cod1_pf) -- proof that f e_dom1 = e_cod1
                                                         pf6 = congruence dom cod e_dom1 e_dom2 f pf_eq_dom_id12-- proof that f e_dom1 = f e_dom2
                                                         pf7 = trans (trans pf4 (sym pf6)) pf5 -- proof that (f a) + (f a_inv) = e_cod1
                                                         pf8 = Group_property_7 cod (+) pfcod (f a) (f a_inv) pf7 -- proof that inverse of (f a)
                                                                                -- is (f a_inv)
                                                         pf9 = snd (Inv_with_pf cod (+) pfcod (f a)) -- proof that c is a inverse of (f a) with
                                                                                -- e_cod2 as identity
                                                         pf9.1 = fst pf9 -- proof that (f a) + c = e_cod2
                                                         pf9.2 = snd pf9 -- proof that c + (f a) = e_cod2
                                                         pf10.1 = trans pf9.1 (sym pf_eq_cod_id12) -- proof that (f a) + c = e_cod1
                                                         pf10.2 = trans pf9.2 (sym pf_eq_cod_id12) -- -- proof that c + (f a) = e_cod1
                                                         pf10 = (pf10.1, pf10.2)

                                                         in
                                                         (Group_property_2 cod (+) pfcod (f a) b c pf8 pf10)

||| Property 9 - If a*b = c then b = Inv(a) * c
total
Group_property_9 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a, b, c : grp) -> (a*b = c) -> (b = (Inv grp (*) pfgrp a)*c)

Group_property_9 grp (*) pfgrp a b c pfEq = ?rhs


module Cosets

import Group
%access public export

--The type of proofs that a type trav Transverses a given coset only once,
--if at all
CosetInj: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
          (sbgrp: Subgroup h pfh g pfg) ->
          (trav: Type) -> (f: trav -> g) -> Type
CosetInj  h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav f =
  ((x: trav) -> (y: trav) ->
  (p: h ** (f x) = (incl p)*(f y)) -> (x = y)) where
  incl = (fst sbgrp)

--The type of proofs that a type trav Transverses every coset of a given
-- group g wrt a subgroup h
CosetAll: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
          (sbgrp: Subgroup h pfh g pfg) ->
          (trav: Type) -> (f: trav -> g) -> Type
CosetAll h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav f =
  ((a: g) ->
  (p: h ** (t: trav ** ((incl p)*(f t) = a)))) where
  incl = (fst sbgrp)

-- Transversal type - the type of proofs that a given type is a Transversal
-- of a group g wrt a subgroup h
IsTransversal: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
               (sbgrp: Subgroup h pfh g pfg) -> (trav: Type) -> Type
IsTransversal h pfh g pfg sbgrp trav = DPair (trav -> g) (\f =>
  (CosetInj h pfh g pfg sbgrp trav f,
  CosetAll  h pfh g pfg sbgrp trav f)
  )

--The transversal data type
data Transversal: (trav: Type) -> Type where
  MkTransversal: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
                 (sbgrp: Subgroup h pfh g pfg) -> (trav: Type) ->
                 (IsTransversal h pfh g pfg sbgrp trav) -> Transversal trav

--Defining the multiplication operation between elements of a traversal
MulTrans: (trav: Type) -> (Transversal trav) -> trav -> trav -> trav
MulTrans trav (MkTransversal h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav pftrav) y z = (fst (snd ((snd (snd pftrav)) ((f y)*(f z))))) where
  f: trav -> g
  f = (fst pftrav)


> module BoundedNat.Operations

> import Data.Fin
> import Data.Vect

> import BoundedNat.BoundedNat
> import Fin.Properties
> import Nat.LTProperties
> import Sigma.Sigma
> import Pairs.Operations

> %default total
> %access public export

> ||| Mapping bounded |Nat|s to |Fin|s
> toFin : {b : Nat} -> LTB b -> Fin b
> toFin {b = Z}   (MkSigma  _     nLT0        ) = void (succNotLTEzero nLT0)
> toFin {b = S m} (MkSigma  Z     _           ) = FZ
> toFin {b = S m} (MkSigma (S n) (LTESucc prf)) = FS (toFin (MkSigma n prf))

> ||| Mapping |Fin|s to bounded |Nat|s
> fromFin : {b : Nat} -> Fin b -> LTB b
> fromFin k = MkSigma (finToNat k) (finToNatLemma k)

> |||
> toVect : {b : Nat} -> {A : Type} -> (LTB b -> A) -> Vect b A
> toVect {b = Z}        _ = Nil
> toVect {b = S b'} {A} f = (f (MkSigma Z (ltZS b'))) :: toVect f' where
>   f' : LTB b' -> A
>   f' (MkSigma k q) = f (MkSigma (S k) (LTESucc q))


import Data.Vect

import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views

{- 1 -}

total
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] input2 | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec)
         = if x == y
              then equalSuffix xs ys | xsrec | ysrec ++ [y]
              else []

{- 2 -}

total
mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (ys ++ zs) | (SplitRecPair lrec rrec)
      = merge (mergeSort ys | lrec) (mergeSort zs | rrec)

{- 3 -}

total
toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1"

{- 4 -}

palindrome : Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (xs ++ [y])) | (VCons rec)
      = x == y && palindrome xs


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor
   Ctrl-Alt-W: Add With View -}
module Main

data TakeN : List a -> Type where
  Fewer : TakeN xs
  Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
  Fewer => Fewer
  Exact ys => Exact (x :: ys)

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = (xs, [])
  halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)

main : IO ()
main = do
  printLn $ groupByN 3 [1,2,3,4,5,6,7,8,9,10,11]
  printLn $ halves [1..10]
  printLn $ halves [1]


import Data.Fin
import Data.List
import Data.Nat
import Data.SortedSet as S
import Data.String.Parser
import Data.Vect

import System.File

Node : Type
Node = (Nat, Nat)

-- A Non empty grid
Grid : Nat -> Type
Grid n = Vect (S n) (Vect (S n) Node)

gupdateAt : (Fin (S n), Fin (S n)) -> (Node -> Node) -> Grid n -> Grid n
gupdateAt (x, y) f = updateAt y (updateAt x f)

gindex : (Fin (S n), Fin (S n)) -> Grid n -> Node
gindex (x, y) = index x . index y

inf : Nat
inf = 1000000

parser : Parser (n ** Grid n)
parser = do row <- some digit <* char '\n'
            let n = length row
            Just v <- pure $ toVect n $ (,inf) . finToNat <$> row
              | Nothing => fail "not length"
            Yes ItIsSucc <- pure $ isItSucc n
              | No _ => fail "Row is zero"
            vs <- ntimes (pred n) (((map ((,inf) . finToNat)) <$> ntimes n digit) <* char '\n')
            pure $ MkDPair (pred n) (v :: vs)

decFin : Fin n -> Maybe (Fin n)
decFin FZ = Nothing
decFin (FS x) = Just $ weaken $ x
incFin : {n : Nat} -> Fin n -> Maybe (Fin n)
incFin f = strengthen $ shift 1 f

neighbours : {n : Nat} -> (Fin n, Fin n) -> List (Fin n, Fin n)
neighbours (x, y) = ((, y) <$> catMaybes [decFin x, incFin x]) ++
                    ((x, ) <$> catMaybes [decFin y, incFin y])

lowestRisk' : {n : Nat} -> List (Fin (S n), Fin (S n)) -> Grid n -> Grid n
lowestRisk' [] g = g
lowestRisk' ((x, y) :: queue) g = let (_, d) = gindex (x, y) g
                                      n = filter (\p => let (v, t) = gindex p g in v + d < t) $ neighbours (x, y)
                                      ng = foldl (\g' => \p => gupdateAt p (\(v, _) => (v, v + d)) g') g $ n
                                      nq = queue ++ n in
                                      lowestRisk' nq ng

lowestRisk : {n : Nat} -> Grid n -> Grid n
lowestRisk g = lowestRisk' ((0, 0) :: []) (gupdateAt (0, 0) (mapSnd (const 0)) g)

wrapAdd : Nat -> Nat -> Nat
wrapAdd 0 n = n
wrapAdd (S k) n = if n == 9
                     then wrapAdd k 1
                     else wrapAdd k (S n)

largerRow : Vect (S n) (Nat, Nat) -> Vect (5 * (S n)) (Nat, Nat)
largerRow v = v ++ (concat $ ((\a => mapFst (wrapAdd a) <$> v) <$> [1,2,3,4]))

largerColumn : Vect (S n) (Vect (5 * (S n)) (Nat, Nat)) -> Vect (5 * (S n)) (Vect (5 * (S n)) (Nat, Nat))
largerColumn v = v ++ (concat $ ((\a => (mapFst (wrapAdd a) <$>) <$> v) <$> [1,2,3,4]))

largerGrid : Grid n -> Grid (pred (5 * (S n)))
largerGrid g = let rowextended = largerRow <$> g in
                   largerColumn rowextended

run : String -> IO ()
run s = do Right (MkDPair n g, _) <- pure $ parse parser s
             | Left err => putStrLn $ show err
           let g = lowestRisk $ largerGrid g
           putStrLn $ show $ snd $ gindex (last, last) g

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


module With

import Data.Vect

filter' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter' f [] = (_ ** [])
filter' f (x :: xs) =
  let (_ ** xs') = filter' f xs
  in if f x
    then (_ ** x :: xs')
    else (_ ** xs')

filter'' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter'' f [] = (_ ** [])
filter'' f (x :: xs) with (filter'' f xs)
  | (_ ** xs') = if f x then (_ ** x :: xs') else (_ ** xs')

-- similar to view pattern in haskell?
-- https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns#Basicviewpatterns

data Parity : Nat -> Type where
  Even : Parity (n + n)
  Odd  : Parity (S (n + n))

parity : (n : Nat) -> Parity n
parity Z = Even {n = Z}
parity (S Z) = Odd {n = Z}
parity (S (S k)) = ?incomplete
-- parity (S (S k)) with (parity k)
--   parity (S (S (j + j)))     | Even = Even { n = S j }
--   parity (S (S (S (j + j)))) | Odd  = Odd  { n = S j }
  -- don't know how to go futher, the error message shows it cannot prove:
  --  (S j) + (S j) ~ S (S (j + j))

-- `with' syntax can be used to further decompose (pattern matchin) on the
-- parameter with respect to the result of an expression

natToBin : Nat -> List Bool
natToBin Z = Nil
natToBin k with (parity k)
  natToBin (j + j)    | Even = False :: natToBin j
  natToBin (S (j + j))| Odd  = True  :: natToBin j


module Math.Algebra.Quantum.Qubit

import public Data.Fin
import public Data.Vect
import public Data.Matrix
import public Data.Matrix.Algebraic
--import public Data.Matrix.Numeric
import public Data.Complex

import public Control.Algebra
import public Control.Algebra.VectorSpace

%access public export
%default total

C : Type
C = Complex Double

-- Euler
e : Double
e = exp 1

-- Imaginary unit
i : C
i = 0:+1

-- Complex Pi
pii : C
pii = pi:+0

-- Complex exponentiation
expi : C -> C
expi z =
  let es = exp $ realPart z in
    es * (cos $ imagPart z) :+ es * (sin $ imagPart z)

-- WIP
-- really to enforce conjugate transpose we need to have a 1-col matrix
-- and a 1-row matrix as a Bra i.e.
-- Ket = Matrix 2 1 C
-- Bra = Matrix 1 2 C
-- them implement all the Semigroup/Monoid/Group/InnerProductSpace etc. instances for these
-- along with interfaces for (ant general matrix classes, definite, normal, semi-definite etc.?)
-- Operator = Matrix 2 2 C
-- Unitary : Operator where ...
-- Hermitian : Unitary where ...

-- in some sense a vector is a linear transformation anyway especially when
-- you consider dot product as linear transformation to 1-d field
-- hermitian = dagger = adjoint

mmap : (a -> a) -> Matrix n m a -> Matrix n m a
mmap = map . map

-- TODO instead of aliases we should define new types and classes

Ket : Type
Ket = Matrix 2 1 C

Bra: Type
Bra = Matrix 1 2 C

ket : C -> C -> Ket
ket a b = [[a], [b]]

bra : C -> C -> Bra
bra a b = [[a, b]]

qubit : C -> C -> Ket
qubit = ket

one : Ket
one = qubit (0:+0) (1:+0)

zero : Ket
zero = qubit (1:+0) (0:+0)

bra2ket : Bra -> Ket
bra2ket b = Data.Vect.transpose $ mmap conjugate b

ket2bra : Ket -> Bra
ket2bra k = Data.Vect.transpose $ mmap conjugate k

--

Operator : Type
Operator = Matrix 2 2 C

Id : Operator
Id = [[1:+0, 0:+0], [0:+0, 1:+0]]

{-
Data.Matrix.Agebraic now takes care of these implementations

[AddComplexSemigroup] Semigroup C where
  (<+>) z w = z + w

[MulComplexSemigroup] Semigroup C where
  (<+>) z w = z * w

[AddComplexMonoid] Monoid C using AddComplexSemigroup where
  neutral = 0:+0

[MulComplexMonoid] Monoid C using MulComplexSemigroup where
  neutral = 1:+0

Group C using MulComplexMonoid where
  inverse z = 1 / z

AbelianGroup C where { }

Ring C where
  (<.>) z w = z * w

RingWithUnity C where
  unity = 1:+0

-- Kets upto InnerProductSpace

Semigroup Ket where
  (<+>) u v = zipWith (+) u v

Monoid Ket where
  neutral = [0:+0, 0:+0]

Group Ket where
  inverse u = map (1 /) u

AbelianGroup Ket where { }

Module C Ket where
  (<#>) c v = map (* c) v

-}

{-
InnerProductSpace C Ket where
  (<||>) u v = sum $ zipWith (*) u v

test : C
test = one <||> one
-}

-- Local Variables:
-- idris-load-packages: ("base" "contrib")
-- End:


-- module Main

data N = Zero | Suc N

addOne : N -> N
addOne Zero = Suc Zero
addOne (Suc n) = Suc (Suc n)

One : N
One = Suc Zero
Two : N
Two = (Suc (Suc Zero))
Three : N
Three = addOne Two
Four : N
Four = addOne Three
Five : N
Five = addOne Four

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

data Vec : (a : Type) -> N -> Type where
  Nil : Vec a Zero
  Cons : {n : N} -> a -> Vec a n -> Vec a (Suc n)

empt : Vec N Zero
empt = Nil

test : Vec N Two
test = Cons One (Cons Two Nil)

test2 : Vec N Three
test2 = Cons Three (Cons Four (Cons Five Nil))

concat : {g : Type} -> {a : N} -> {b : N} -> Vec g a -> Vec g b -> Vec g (add a b)
concat Nil rest = rest
concat (Cons a rest) b = concat rest (Cons a b)

t3 : Vec N (addOne (addOne (addOne (addOne One))))
t3 = concat test test2


module FinCmp

-- Decidable comparison of finite numbers less
-- than a given bound (i.e. "ordinals").

import public Data.Fin

%default total
%access public export

-------------------------------------------
-- Begin: DECIDABLE COMPARISONS OF ORDINALS

-- Data type for evidence that "i < j".
data FinLT : Fin n -> Fin n -> Type where
  LtZ : FinLT FZ (FS i)
  LtS : FinLT i j -> FinLT (FS i) (FS j)

-- Simplified symtax:
infixl 6 :<:
(:<:) : Fin n -> Fin n -> Type
(:<:) = FinLT

-- Data type for evidence of which of the
-- following holds between ordinals 'i' and 'j':
--
--    (a) i < j
--    (b) i = j
--    (c) i < j
--
data FinCMP : Fin n -> Fin n -> Type where
  CmpEq : (i = j) -> FinCMP i j
  CmpLt : i :<: j -> FinCMP i j
  CmpGt : j :<: i -> FinCMP i j

-- Function 'finNotLtZ' yields a proof of the following:
--
--    "There is no ordinal less than zero."
--     (In other words, given a proof that 'i' is
--     less than zero, the function 'finNotLtZ' yields
--     a member of the uninhabited type 'Void'.)
--
finNotLtZ : i :<: FZ -> Void
finNotLtZ _ impossible

-- Function 'finCmpDec' decides whether
--
--    (a) i < j, or
--    (b) i = j, or
--    (c) i > j  holds,
--
-- and yields evidence in the form of a value
-- of type 'FinCMP i j'.
finCmpDec : (i : Fin n) -> (j : Fin n) -> (FinCMP i j)
finCmpDec i j = case i of
  FZ => case j of
             FZ    => CmpEq Refl
             FS j' => CmpLt LtZ
  FS i' => case j of
                FZ    => CmpGt LtZ
                FS j' => case finCmpDec i' j' of
                              CmpEq eq => CmpEq (rewrite eq in Refl)
                              CmpLt lt => CmpLt (LtS lt)
                              CmpGt lt => CmpGt (LtS lt)

-- Function 'finLtPred' yields a proof of the following:
--
--    "Given (FS i) < (FS j)m then i < j".
--
finLtPred : (FS i) :<: (FS j) -> i :<: j
finLtPred lt = case lt of LtS lt' => lt'

-- End: DECIDABLE COMPARISONS OF ORDINALS
-----------------------------------------


import Decidable.Equality

data DivisiblebyX : Nat -> Nat -> Type where
  Base: DivisiblebyX x x
  Multiple: DivisiblebyX x y -> DivisiblebyX x (x+y)

data FizzBuzzProof: Nat -> Type where
  Fizz: DivisiblebyX 3 x -> (DivisiblebyX 5 x -> Void) -> FizzBuzzProof x
  Buzz: DivisiblebyX 5 x -> (DivisiblebyX 3 x -> Void) -> FizzBuzzProof x
  FizzBuzz: DivisiblebyX 3 x -> DivisiblebyX 5 x -> FizzBuzzProof x
  Normal: (x: Nat) -> (DivisiblebyX 3 x -> Void) ->(DivisiblebyX 5 x -> Void) -> FizzBuzzProof x

Show (FizzBuzzProof x) where
  show (Fizz _ _) = "fizz"
  show (Buzz _ _) = "buzz"
  show (FizzBuzz _ _) = "fizzbuzz"
  show (Normal x _ _) = show x

threeLessNotDivisible3 : (notdiv : DivisiblebyX 3 (S y) -> Void) -> DivisiblebyX 3 (3 + (S y)) -> Void
threeLessNotDivisible3 notdiv (Multiple x) = notdiv x

zeroNotDivisible3 : DivisiblebyX 3 0 -> Void
zeroNotDivisible3 Base impossible
zeroNotDivisible3 (Multiple _) impossible

oneNotDivisible3 : DivisiblebyX 3 1 -> Void
oneNotDivisible3 Base impossible
oneNotDivisible3 (Multiple _) impossible

twoNotDivisible3 : DivisiblebyX 3 2 -> Void
twoNotDivisible3 Base impossible
twoNotDivisible3 (Multiple _) impossible

divisibleby3: (y: Nat) -> Dec (DivisiblebyX 3 y)
divisibleby3 Z = No zeroNotDivisible3
divisibleby3 (S Z) = No oneNotDivisible3
divisibleby3 (S (S Z)) = No twoNotDivisible3
divisibleby3 (S (S (S Z))) = Yes Base
divisibleby3 (S (S (S (S y)))) = case divisibleby3 (S y) of
  Yes prf => Yes (Multiple prf)
  No notdiv => No (threeLessNotDivisible3 notdiv)

zeroNotDivisible5 : DivisiblebyX 5 0 -> Void
zeroNotDivisible5 Base impossible
zeroNotDivisible5 (Multiple _) impossible

oneNotDivisible5 : DivisiblebyX 5 1 -> Void
oneNotDivisible5 Base impossible
oneNotDivisible5 (Multiple _) impossible

twoNotDivisible5 : DivisiblebyX 5 2 -> Void
twoNotDivisible5 Base impossible
twoNotDivisible5 (Multiple _) impossible

threeNotDivisible5 : DivisiblebyX 5 3 -> Void
threeNotDivisible5 Base impossible
threeNotDivisible5 (Multiple _) impossible

fourNotDivisible5 : DivisiblebyX 5 4 -> Void
fourNotDivisible5 Base impossible
fourNotDivisible5 (Multiple _) impossible

fiveLessNotDivisible5 : (notdiv : DivisiblebyX (fromInteger 5) (S y) -> Void) -> DivisiblebyX 5 (S (S (S (S (S (S y)))))) -> Void
fiveLessNotDivisible5 notdiv (Multiple x) = notdiv x

divisibleby5: (y: Nat) -> Dec (DivisiblebyX 5 y)
divisibleby5 Z = No zeroNotDivisible5
divisibleby5 (S Z) = No oneNotDivisible5
divisibleby5 (S (S Z)) = No twoNotDivisible5
divisibleby5 (S (S (S Z))) = No threeNotDivisible5
divisibleby5 (S (S (S (S Z)))) = No fourNotDivisible5
divisibleby5 (S (S (S (S (S Z))))) = Yes Base
divisibleby5 (S (S (S (S (S (S y)))))) = case divisibleby5 (S y) of
  Yes prf => Yes (Multiple prf)
  No notdiv => No (fiveLessNotDivisible5 notdiv)

fizzbuzz: (x: Nat) -> FizzBuzzProof x
fizzbuzz x = case (divisibleby3 x, divisibleby5 x) of
  (No not_fizz, No not_buzz) => Normal x not_fizz not_buzz
  (Yes fizz_prf, Yes buzz_prf) => FizzBuzz fizz_prf buzz_prf
  (No not_fizz, Yes buzz_prf) => Buzz buzz_prf not_fizz
  (Yes fizz_prf, No not_buzz) => Fizz fizz_prf not_buzz

fizzbuzz_string: (x: Nat) -> String
fizzbuzz_string x = show $ fizzbuzz x

fizzbuzz_loop: (n: Nat) -> (end: Nat) -> IO ()
fizzbuzz_loop n end with (decEq n end)
  fizzbuzz_loop n end | Yes prf = pure ()
  fizzbuzz_loop n end | No contra =  do
    putStrLn $ show $ fizzbuzz n
    fizzbuzz_loop (S n) end

main: IO ()
main = fizzbuzz_loop 1 101


import Data.Fin

data Graph : Nat -> Type where
  Empty : Graph Z
  Node : Bool -> Graph (S Z)
  Combine : (Fin (S n) -> Fin (S m) -> Bool) -> Graph (S n) -> Graph (S m) -> Graph (S n + S m)

combine : {n:Nat} -> {m:Nat} -> (Fin n -> Fin m -> Bool) -> Graph n -> Graph m -> Graph (n+m)
combine {n=n} _ a Empty = rewrite plusZeroRightNeutral n in a
combine {m=m} _ Empty b = b
combine {n=S n} {m=S m} f a b = Combine f a b

f : Bool -> Fin n -> Fin m -> Bool
f a _ _ = a

overlay : Graph n -> Graph m -> Graph (n+m)
overlay a b = combine (f False) a b

connect : Graph n -> Graph m -> Graph (n+m)
connect a b = combine (f True) a b

unconnected : (n : Nat) -> Graph n
unconnected Z = Empty
unconnected (S n) = overlay (Node False) (unconnected n)

clique : (n : Nat) -> Graph n
clique Z = Empty
clique (S n) = connect (Node True) (clique n)


import Data.Vect

inputs : Vect 4 Double
inputs = [1.0, 2.0, 3.0, 2.5]

weights : Vect 3 (Vect 4 Double)
weights = [[0.2, 0.8, -0.5, 1.0], [0.5, -0.91, 0.26, -0.5], [-0.26, -0.27, 0.17, 0.87]]

biases : Vect 3 Double
biases = [2.0, 3.0, 0.5]

-- NOTE: match numpy interface in the spirit of the Python lesson
dotProduct : Vect n (Vect m Double) ->
             Vect m Double ->
             Vect n Double
dotProduct xss ys = map (\xs => sum $ zipWith (*) xs ys) xss

-- add the biases to the results of the dot product
output : Vect 3 Double
output = zipWith (+) (dotProduct weights inputs) biases

main : IO ()
main = printLn output


module EqNat

%default total

data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
  Same : (num : Nat) -> EqNat num num

sameS : (eq : EqNat k j) -> EqNat (S k) (S j)
sameS (Same k) = Same (S k)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z _  = Nothing
checkEqNat _ Z = Nothing
checkEqNat (S k) (S l) = case checkEqNat k l of
                              Nothing => Nothing
                              Just eq => Just (sameS eq)


data Vect : Nat -> Type -> Type where
    Nil : Vect Z a
    (::) : a-> Vect k a-> Vect (S k) a

(++) : Vect n a -> Vect m a -> Vect (n+m) a
(++) Nil ys =ys
(++) (x::xs) ys = x :: xs ++ ys

data Fin : Nat -> Type where
    FZ : Fin (S k)
    FS : Fin k  -> Fin (S k)

index : Fin n -> Vect n a -> a
index FZ (x::xs) = x
index (FS k) (x::xs) = index k xs

isEmpty : Vect n a -> Bool
isEmpty {n=Z} _ = True
isEmpty {n=S k} _ = False

1::(2::(3::Nil)) : Vect 3 Integer


We start with a trivial language comtaining numbers and booleans.

> import Math
> import Data.List

> data UntypedTerm : Type where
>   CTrue : UntypedTerm
>   CFalse : UntypedTerm
>   IfThenElse : UntypedTerm -> UntypedTerm -> UntypedTerm -> UntypedTerm
>   CZero : UntypedTerm
>   Succ : UntypedTerm -> UntypedTerm
>   Pred : UntypedTerm -> UntypedTerm
>   IsZero : UntypedTerm -> UntypedTerm

We can create a generator for such terms:

> data UntypedTermGenerator : Nat -> List UntypedTerm -> Type where
>   GenEmpty : UntypedTermGenerator Z []
>   GenSucc : UntypedTermGenerator k xs -> UntypedTermGenerator (S k) ([CTrue,CFalse,CZero]) -- ++ (map ))

This generator in fact covers the UntypedTerms. First, we need a notion of the
size of a term

> size : UntypedTerm -> Nat
> size CTrue = 1
> size CFalse = 1
> size CZero = 1
> size (Succ t) = S (size t)
> size (Pred t) = S (size t)
> size (IsZero t) = S (size t)
> size (IfThenElse i t e) = S (plus (plus (size i) (size t)) (size e))

Since the terms form a tree there is a notion of depth:

> depth : UntypedTerm -> Nat
> depth CTrue = 1
> depth CFalse = 1
> depth CZero = 1
> depth (Succ t) = S (depth t)
> depth (Pred t) = S (depth t)
> depth (IsZero t) = S (depth t)
> depth (IfThenElse i t e) = S (maximum (maximum (depth i) (depth t)) (depth e))--S (maximum (maximum( (depth i) (depth t))) (depth e))

Now we can prove covering. We prove the equivalent result that for any Nat n and any UntypedTerm t with depth LTE n, then there exists an UntypedTermGenerator n xs such that Elem t xs.

> generatorCovers : (t:UntypedTerm) -> (xs : List UntypedTerm ** ((UntypedTermGenerator (depth t) xs), (Elem t xs)))--((n:Nat ** (UntypedTermGenerator n xs)) ** (Elem t xs))
> generatorCovers CTrue = ([CTrue,CFalse,CZero] ** (GenSucc GenEmpty,Here))
> generatorCovers CFalse = ([CTrue,CFalse,CZero] ** (GenSucc GenEmpty,There (the (Elem CFalse [CFalse,CZero]) Here)))
> generatorCovers (IfThenElse x y z) = ?generatorCovers_rhs_1
> generatorCovers CZero = ([CTrue,CFalse,CZero] ** (GenSucc GenEmpty,There (There (the (Elem CZero [CZero]) Here))))
> generatorCovers (Succ x) = ?generatorCovers_rhs_5
> generatorCovers (Pred x) = ?generatorCovers_rhs_6
> generatorCovers (IsZero x) = ?generatorCovers_rhs_7


data Bool = False | True
data Nat = Z | S Nat

not : Bool -> Bool
not False = True
not True = False

isZero : Nat -> Bool
isZero Z = True
isZero (S k) = False

isOdd : Nat -> Bool
isOdd Z = False
isOdd (S k) = not (isOdd k)

testZ : Nat -> String
testZ x = if isZero x then "Zero" else
             if isOdd x then "Odd" else "Even"


module Minus

import Data.Nat

plus_mult : (n, m, k : Nat) -> {auto km : k `LTE` m} -> n + (m `minus` k) = (m + n) `minus` k
plus_mult n m Z = rewrite minusZeroRight m in
                  rewrite minusZeroRight $ m + n in
                  rewrite plusCommutative m n in
                  Refl
plus_mult n (S m) (S k) {km=LTESucc _} = plus_mult n m k

%hint
power2_ge_1 : (n : Nat) -> 1 `LTE` (2 `power` n)
power2_ge_1 Z     = LTESucc LTEZero
power2_ge_1 (S n) = lteTransitive (power2_ge_1 n) $ lteAddRight (2 `power` n)


module IntegerProofs

%access public export
%default total

||| A decision procedure for `DecEq Integer`
||| @ m the first number
||| @ n the second number
isEq : (m : Integer) -> (n : Integer) -> Dec (m = n)
isEq m n = decEq m n

||| Proofs that `m` is not equal to `n`
||| @ m the first number
||| @ n the second number
NotEq : (m, n : Integer) -> Type
NotEq m n = Not (m=n)

||| Not (m = n) implies m /= n
notEqImpliesNotEq : (contra : (m = n) -> Void) -> ((m = n) -> Void)
notEqImpliesNotEq contra Refl = contra Refl

||| (m = n) implies Not (m /= n)
eqImpliesNotNotEq : (prf : m = n) -> (((m = n) -> Void) -> Void)
eqImpliesNotNotEq Refl f = f Refl

||| A decision procedure for `NotEq`
isNotEq : (m : Integer) -> (n : Integer) -> Dec (NotEq m n)
isNotEq m n = case (isEq m n) of
                   (Yes prf) => No (eqImpliesNotNotEq prf)
                   (No contra) => Yes (notEqImpliesNotEq contra)

smaller : (m : Integer) -> (n : Integer) -> Integer
smaller m n = case m <= n of
                   False => n
                   True => m

sameIntegerCheckPrf : (prf : m = n) -> (n : Integer) -> Integer
sameIntegerCheckPrf Refl n = n

sameInteger : (m : Integer) -> (n : Integer) -> (m=n) -> Integer
sameInteger m n prf = sameIntegerCheckPrf prf n

isTrue : (b : Bool) -> Dec (b = True)
isTrue b = decEq b True

isFalse : (b : Bool) -> Dec (b = False)
isFalse b = decEq b False


||| Implementing `Decidable.Order.Strict` for `Data.Nat.LT`
module Data.Nat.Order.Strict

import Data.Nat
import Decidable.Order.Strict
import Decidable.Equality
import Data.Nat.Order

%default total

public export
Irreflexive Nat LT where
  irreflexive {x = 0} _ impossible
  irreflexive {x = S _} (LTESucc prf) =
    irreflexive {rel = Nat.LT} prf

public export
Transitive Nat LT where
  transitive {x} {y} xy yz =
    transitive {rel = LTE} (lteSuccRight xy) yz

public export
StrictPreorder Nat LT where

public export
decLT : (a, b : Nat) -> DecOrdering {lt = LT} a b
decLT 0       0   = DecEQ Refl
decLT 0     (S b) = DecLT (LTESucc LTEZero)
decLT (S a)  0    = DecGT (LTESucc LTEZero)
decLT (S a) (S b) = case decLT a b of
  DecLT a_lt_b => DecLT (LTESucc a_lt_b)
  DecEQ Refl   => DecEQ Refl
  DecGT b_lt_a => DecGT (LTESucc b_lt_a)

public export
StrictOrdered Nat LT where
  order = decLT


data MyNat = Zero | Succ MyNat

total mynat_plus : MyNat -> MyNat -> MyNat
mynat_plus Zero m = m
mynat_plus (Succ k) m = Succ (mynat_plus k m)

-- proving that 0 + a = a
total first_proof : (a: MyNat) -> mynat_plus Zero a = a
first_proof a = Refl

-- proving that there exists an x such that Succ x exists
-- we are basically constructing a dependent pair of (x, Succ x)
-- that is accomplished with the DPair type
total second_proof : MyNat -> DPair MyNat (\_ => MyNat)
second_proof x = MkDPair x (Succ x)

data MyLTE : MyNat -> MyNat -> Type where
  MyLTEZero : MyLTE Zero right
  MyLTESucc : MyLTE left right -> MyLTE (Succ left) (Succ right)

-- proving that a + 0 = a
-- using induction here
-- what we do it rewrite the induction hypothesis
total third_proof : (a: MyNat) -> mynat_plus a Zero = a
third_proof Zero = Refl
third_proof (Succ x) = rewrite (third_proof x) in Refl


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
    negate x = 0 - x
    (-) = Sub
    abs = Abs

-- Exercise 1

showOp : Show a => String -> a -> a -> String
showOp op x y = "(" ++ show x ++ op ++ show y ++ ")"

Show ty => Show (Expr ty) where
    show (Val x) = show x
    show (Add x y) = showOp " + " x y
    show (Sub x y) = showOp " - " x y
    show (Mul x y) = showOp " * " x y
    show (Div x y) = showOp " / " x y
    show (Abs x) = "abs " ++ show x

-- Exercise 2

(Neg a, Integral a, Eq a) => Eq (Expr a) where
    (==) x y = eval x == eval y

-- Exercise 3

(Neg num, Integral num) => Cast (Expr num) num where
    cast orig = eval orig


module Order

data InclusiveEither : (typeLeft : Type) -> (typRight : Type) -> Type where
	OnlyLeft : typLeft -> Not typRight -> InclusiveEither typLeft typRight
	OnlyRight : Not typLeft -> typRight -> InclusiveEither typLeft typRight
	Both : typLeft -> typRight -> InclusiveEither typLeft typRight

|||Type of proof that a relation is reflexive
isReflexive : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isReflexive {typ} r = (a : typ) -> (r a a)

|||Type of proof that a relation is symmetric
isSymmetric : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isSymmetric {typ} r = (a : typ) -> (b : typ) -> (r a b) -> (r b a)

|||Type of proof that a relation is anti-symmetric
isAntiSymmetric : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isAntiSymmetric {typ} r = (a : typ) -> (b : typ) -> (r a b) -> (r b a) -> (a = b)

|||Type of proof that a relation is transitive
isTransitive : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isTransitive {typ} r = (a : typ) -> (b : typ) -> (c : typ) -> (r a b) -> (r b c) -> (r a c)

|||Type of proof that a relation is an equivalence
isEquivalence : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isEquivalence {typ} r = (isReflexive r, isSymmetric r, isTransitive r)

|||Type of proof that a relation is a partial order
isPartialOrder : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isPartialOrder {typ} r = (isReflexive r, isAntiSymmetric r, isTransitive r)

|||Type of proof that a relation is a total order
isTotalOrder : {typ : Type} -> (r : (typ -> typ -> Type)) -> Type
isTotalOrder {typ} r = (isPartialOrder r, (a : typ) -> (b : typ) -> (InclusiveEither (r a b) (r b a)))


module equality

import Data.Vect

-- 8.1.7 Exercises
same_cons : {xs : List a}
            -> {ys : List a}
            -> xs = ys
            -> x :: xs = x :: ys
same_cons Refl = Refl

same_lists : {xs : List a}
             -> {ys : List a}
             -> x = y
             -> xs = ys
             -> x :: xs = y :: ys
same_lists Refl Refl = Refl

data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
     Same : (num : Nat) -> EqNat num num

-- Functions as Proofs: Manipulating Equalities
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS j j (Same j) = Same (S j)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Just eq => Just $ sameS _ _ eq
                              Nothing => Nothing

checkEqNat' : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat' Z Z = Just Refl
checkEqNat' Z (S k) = Nothing
checkEqNat' (S k) Z = Nothing
checkEqNat' (S k) (S j) = case checkEqNat' k j of
                               Just eq => Just $ cong eq
                               Nothing => Nothing

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case checkEqNat m len of
                                 Just (Same len) => Just input
                                 Nothing => Nothing

reverseProof : Vect (k + 1) elem -> Vect (S k) elem
reverseProof {k} ys = rewrite plusCommutative 1 k in ys

my_reverse : Vect n elem -> Vect n elem
my_reverse [] = []
my_reverse (x :: xs) = reverseProof (my_reverse xs ++ [x])


module TypeDrivenDevelopment

||| Map a list of strings to their length
allLengths : List String -> List Nat
allLengths xs = map length xs

||| Negate a boolean
invert : (t : Bool) -> Bool
invert True = False
invert False = True

||| Describe whether a list is empty or not
describeList : List Int -> String
describeList [] = "Empty"
describeList (x :: xs) = "Non-empty"

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k


module Data.Group

import Data.Stream

||| This extends 'Monoid' by defining an inverse for every element.
public export
interface (Monoid t) => Group t where
  inverse : t -> t

||| Stream of elements starting at some given element.
public export
generate : (Monoid g) => g -> Stream g
generate g1 = neutral :: map (<+> g1) (generate g1)

||| (Positive) integer exponentiation.
public export
exp : (Monoid g) => (n : Nat) -> g -> g
exp n g = Prelude.head (drop n (generate g))

||| Whether a group element is idempotent
public export
total
idempotent : (Eq g, Semigroup g) => g -> Bool
idempotent x = x == (x <+> x)

||| Commutator of two elements.
public export
total
commutator : (Group g) => g -> g -> g
commutator a b = inverse a <+> inverse b <+> a <+> b