module Chapter2

import TypesAndFunctions
import Category

%default total

Exercise_2_1_1 : {cat : Category} -> {a, b, c, d : Object cat} ->
  (g : Morphism cat c d) -> (f : Morphism cat b c) ->
  postCompose {cat} {a} {b} {c=d} ((.*) {cat} {a=b} {b=c} {c=d} g f) =
    (postCompose {cat} {a} {b=c} {c=d} g) . (postCompose {cat} {a} {b} {c} f)
Exercise_2_1_1 {cat} _ _ = functionalExtensionality (Associativity cat _ _)

Exercise_2_1_2 : {cat : Category} -> {a, b, c, d : Object cat} ->
  (h : Morphism cat c d) -> (g : Morphism cat b c) -> (f : Morphism cat a b) ->
  postCompose {cat} {a} {b} {c=d} (postCompose {cat} {a=b} {b=c} {c=d} h g) f =
    postCompose h {cat} {a} {b=c} {c=d} (postCompose {cat} {a} {b} {c} g f)
Exercise_2_1_2 {cat} = Associativity cat

Exercise_2_1_3 : {cat : Category} -> {a, b, c, d : Object cat} ->
  (g : Morphism cat b c) -> (f : Morphism cat a b) ->
  preCompose {cat} {a} {b=c} {c=d} ((.*) {cat} {a} {b} {c} g f) =
    (preCompose {cat} {a} {b} {c=d} f) .
      (preCompose {cat} {a=b} {b=c} {c=d} g)
Exercise_2_1_3 {a} {b} {c} {d} {cat} _ _ =
  functionalExtensionality (\_ => sym (Associativity cat _ _ _))

{- Post-composition with the identity leaves arrows unchanged.
 - (So post-composition with the identity is itself the identity on
 - the type of arrows terminating in a.) -}
Exercise_2_3_1_post : {cat : Category} -> {a, b : Object cat} ->
  (f : Morphism cat b a) ->
  postCompose {cat} {a=b} {b=a} {c=a} (catId {cat} a) f = f
Exercise_2_3_1_post f = LeftIdentity cat f

{- Pre-composition with the identity leaves arrows unchanged.
 - (So pre-composition with the identity is itself the identity on
 - the type of arrows originating in a.) -}
Exercise_2_3_1_pre : {cat : Category} -> {a, b : Object cat} ->
  (f : Morphism cat a b) ->
  preCompose {cat} {a} {b=a} {c=b} (catId {cat} a) f = f
Exercise_2_3_1_pre f = RightIdentity cat f


module ProofSorted

checkSorted: Ord ty => List ty -> Bool
checkSorted []  = True
checkSorted [x] = True
checkSorted (x :: xs) =
    case xs of
        []       => True
        (y :: _) => if x <= y
            then checkSorted xs
            else False

data IsLte : (smaller: ty) -> (bigger: ty) -> Type where
    Lte: IsLte smaller bigger

proveLessThen: Ord ty => (smaller: ty) -> (bigger: ty) -> Dec (IsLte smaller bigger)
proveLessThen smaller bigger =
    case smaller <= bigger of
        False => No  fails
        True  => Yes holds
    where
        fails: IsLte smaller bigger -> Void
        fails prf = believe_me {b = Void} ()
        holds: IsLte smaller bigger
        holds = really_believe_me (Lte {smaller = smaller} {bigger = bigger})

data Sorted : List ty -> Type where
    SortedNil: Sorted []
    SortedOne: (head: ty) -> Sorted [head]
    SortedMany: {tl: List ty} -> (elem: ty) -> Sorted (hd :: tl) -> (prf: IsLte elem hd) -> Sorted (elem :: hd :: tl)

keepsUnsorted : (tailUnsorted : Sorted (second :: tail) -> Void) -> Sorted (first :: (second :: tail)) -> Void
keepsUnsorted tailUnsorted (SortedMany _ tailSort _) = tailUnsorted tailSort

prependUnsorted : (unsorted : IsLte first second -> Void) -> Sorted (first :: (second :: tail)) -> Void
prependUnsorted unsorted (SortedMany _ _ fsSorted) = unsorted fsSorted

proveSorted: Ord ty => (input: List ty) -> Dec(Sorted input)
proveSorted []    = Yes SortedNil
proveSorted [one] = Yes (SortedOne one)
proveSorted (first :: second :: tail) = case proveLessThen first second of
    (Yes fsSorted)  => case proveSorted (second :: tail) of
        (Yes tailSorted)   => Yes (SortedMany first tailSorted fsSorted)
        (No  tailUnsorted) => No  (keepsUnsorted tailUnsorted)
    (No fsUnsorted) => No (prependUnsorted fsUnsorted)


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

%name Vect xs, ys, zs

data Elem : a -> Vect k a -> Type where
  Here : Elem x (x :: xs)
  There : (later : Elem x xs) -> Elem x (y :: xs)

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

notInTail : (notHere : (value = x) -> Void) -> (notThere : Elem value xs -> Void) -> Elem value (x :: xs) -> Void
notInTail notHere notThere Here = notHere Refl
notInTail notHere notThere (There later) = notThere later

isElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
isElem value [] = No notInNil
isElem value (x :: xs) = case decEq value x of
                              (Yes Refl) => Yes Here
                              (No notHere) => (case isElem value xs of
                                                    (Yes prf) => Yes (There prf)
                                                    (No notThere) => No (notInTail notHere notThere))

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


import Prelude.Nat

-- Not in axiom list, but covered in class
-- (ab)^k = a^k * b^k
postulate powerDistributesRightMult : (a : Nat) -> (b : Nat) -> (k : Nat) -> power (a * b) k = (power a k) * (power b k)

-- a | b
Divides : (a : Nat) -> (b : Nat) -> Type
Divides a b = DPair Nat (\n => b = n * a)

-- a = b & x = y -> a + x = b + y
additionEquality : {a : Nat} -> {b : Nat} -> a = n -> b = m -> a + b = n + m
additionEquality pa pb =
  rewrite pa in
  rewrite pb in
  Refl

-- a | b & a | c -> a | (b + c)
theorem1_1 : {a : Nat} -> {b : Nat} -> {c : Nat} -> Divides a b -> Divides a c -> Divides a (b + c)
theorem1_1 {a} {b} {c} (bFactor ** bProof) (cFactor ** cProof) =
  let result = additionEquality bProof cProof in
  let proofOfDist = multDistributesOverPlusLeft bFactor cFactor a in
  ((bFactor + cFactor) ** (rewrite proofOfDist in result))

-- a | b & b | c -> a | c
theorem1_2 : {a : Nat} -> {b : Nat} -> {c : Nat} -> Divides a b -> Divides b c -> Divides a c
theorem1_2 {a} {b} {c} (bFactor ** bProof) (cFactor ** cProof) =
  rewrite cProof in
  rewrite bProof in
  ((cFactor * bFactor) ** multAssociative cFactor bFactor a)

-- a | b -> a^k | b^k
theorem1_4 : {a : Nat} -> {b : Nat} -> {k : Nat} -> Divides a b -> Divides (power a k) (power b k)
theorem1_4 {a} {k} (bFactor ** bProof) =
  rewrite bProof in
  ((power bFactor k) ** powerDistributesRightMult bFactor a k)


module AssRecRule

import Data.Fin
import Data.Vect

{-
 The recursion function for lists of type `a`. Define this by pattern matching
-}
recList : (a: Type) ->  (x: Type) -> x -> (a -> List a -> x -> x) -> (List a -> x)
recList a x emp fn [] = emp
recList a x emp fn (head :: ls) = fn head ls (recList a x emp fn ls)

{-
Given a list of type `a` and a function `f: a -> b` get a list of type `b`
by applying `f` to each element.
Note: Define using `recList` and without pattern matching on lists.
-}
mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f ls = recList a (List b) [] map ls where
  map head la lb = (f head) :: lb

{-
Given a list of type `a`, an initial value `init: a` and an operation `op: a -> a -> a`,
get an element of `a` by starting with init and repeatedly applying the elements of the
list,
e.g. fold Nat 1 (*) ([22] :: [3] :: [])  = 1 * 22 * 3
Note: Define using `recList` and without pattern matching on lists.
-}
foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op ls = recList a a init map ls where
  map head la val = op head val

{-
The induction function on the `Fin` indexed type family. Define this by pattern matching.
-}
inducFin : (xs : (n: Nat) -> Fin n -> Type) ->
  (base : (m: Nat) -> xs (S m) FZ) ->
  (step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))) ->
  (q: Nat) -> (j: Fin q) -> xs q j
inducFin _ _ _ Z FZ impossible
inducFin _ _ _ Z (FS _) impossible
inducFin xs base step (S k) FZ = base k
inducFin xs base step (S k) (FS x) = step k x (inducFin xs base step k x)

{-
Given a type `a`, a natural number `q`, an element `j : Fin q` and a vector `v` of length q with entries of type `a`,
get the element in position `j` of `v`. Note that this is always well defined.

Note: Define using `inducList` and without pattern matching on the `Fin` family. You may pattern match on Vectors.
The definition should have only one case, and there should be no case splitting on `Fin`.
-}
fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a q j ys = inducFin xs base step q j ys where
  xs: (n: Nat) -> Fin n -> Type
  xs n j = Vect n a -> a
  base m = retHead where
    retHead: Vect (S m) a -> a --retrieve Head
    retHead (x :: ls) = x
  step p k prev = retStep where --reduce list to smaller one
    retStep : Vect (S p) a -> a
    retStep (x :: ls) = prev ls


module Intro
import Data.Vect

-- a term (object) with its type
three : Nat
three = 3

next: Nat -> Nat -- the type is a function type
next n = n + 1

-- a recursive definition
fct: Nat -> Nat
fct Z = 1
fct (S k) = (S k) * (fct k) -- this is primitive recursion

loop: Nat -> Nat
loop Z = Z
loop (S k) = loop k + (loop (k + 2)) -- this is horrible

fibPair: Nat -> (Nat, Nat)
fibPair Z = (1, 1)
fibPair (S k) = case fibPair k of
                     (a, b) => (b, a + b)

fibo: Nat -> Nat
fibo n = fst (fibPair n)

-- types are terms, i.e., first class, so have types
Naturals : Type
Naturals = Nat

natToNat : Type
natToNat = Nat -> Nat

anotherThree : Naturals
anotherThree = 3

add : Nat -> Nat -> Nat -- Curryed type
add m n = m + n

data BinTree : Type where
  Leaf : BinTree
  Node : (left: BinTree) -> (right: BinTree) -> BinTree

egTree: BinTree
egTree = Node (Node Leaf (Node Leaf Leaf)) Leaf

numberVertices : BinTree -> Nat
numberVertices Leaf = 1
numberVertices (Node left right) =
  (numberVertices left) + (numberVertices right) + 1

-- a parametrized type (generic)
data LTree : Type -> Type where
  LLeaf : (a: Type) -> (label: a) -> LTree a
  LNode : (a : Type) -> (left : LTree a) -> (right : LTree a) -> LTree a

egLTree : LTree Nat
egLTree =
  LNode Nat (
  LNode Nat (LLeaf Nat 1) (LNode Nat (LLeaf Nat 3) (LLeaf Nat 4))
  ) (LLeaf Nat 7)

labels : (a: Type) -> LTree a -> List a
labels a (LLeaf a label) = [label]
labels a (LNode a left right) =
  (labels a left) ++ (labels a right)

Tuple: Nat -> Type -- tuples of Natural numbers
Tuple Z = Unit
Tuple (S k) = (Nat, Tuple k)

egTuple : Tuple 2
egTuple = (3, (4, ()))

countdown : (n: Nat) -> Tuple n -- this is a dependent function
countdown Z = ()
countdown (S k) = (S k, countdown k)

cntd : (n: Nat) -> Vect (S n) Nat
cntd Z = [0]
cntd (S k) = (S k) :: (cntd k)

zipNat : (n: Nat) -> Vect n Nat -> Vect n Nat -> Vect n (Nat, Nat)
zipNat Z [] [] = []
zipNat (S len) (x :: xs) (y :: ys) = (x , y) :: (zipNat len xs ys)

zip : (n: Nat) -> (a: Type) -> (b: Type) -> Vect n a -> Vect n b -> Vect n (a, b)
zip Z a b [] [] = []
zip (S len) a b (x :: xs) (y :: ys) =
  (x, y) :: (zip len a b xs ys)

append: (n: Nat) -> (a: Type) -> (x: a) -> Vect n a -> Vect (S n) a
append Z a x [] = [x]
append (S len) a x (y :: xs) =
  y :: (append len a x xs)

filter: (n: Nat) -> (a: Type) -> (p: a -> Bool) -> Vect n a -> (m: Nat ** Vect m a)
filter Z a p [] = (Z ** [])
filter (S len) a p (x :: xs) =
  (case p x of
        False => filter len a p xs
        True => (case filter len a p xs of
                      (m ** pf) =>
                        (S m ** x :: pf) ))

data Nothing : Type where

vacuous : (a: Type) -> Nothing -> a

-- some space


data Shape = ||| A triangle with a base and a height
             Triangle Double Double
           | ||| A square with base and a height
             Rectangle Double Double
           | ||| A circle with it's radius
             Circle Double
%name Shape shape, shape1, shape2

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle base height) = base * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture
%name Picture pic, pic1, pic2

testPicture : Picture
testPicture = Combine (Translate 5  5  (Primitive (Rectangle 20 10)))
            $ Combine (Translate 35 5  (Primitive (Circle    5    )))
                      (Translate 15 25 (Primitive (Triangle  10 10)))

pictureArea: Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + (pictureArea pic1)
pictureArea (Rotate _ pic) = pictureArea pic
pictureArea (Translate _ _ pic) = pictureArea pic

data Tree a = Empty
            | Node (Tree a) a (Tree a)

insert : Ord a => a -> Tree a -> Tree a
insert a Empty = Node Empty a Empty
insert a node@(Node left val right) =
  case compare a val of
      LT => Node (insert a left) val right
      EQ => node
      GT => Node left val (insert a right)

listToTree : Ord a => List a -> Tree a
listToTree = foldr insert Empty

treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left val right) = treeToList left ++ [val] ++ (treeToList right)

data Expr = Val Int
          | Sum Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr

eval : Expr -> Int
eval (Val x) = x
eval (Sum x y) = eval x + (eval y)
eval (Sub x y) = eval x - (eval y)
eval (Mul x y) = eval x * (eval y)

liftA2' : Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2' f x y = map f x <*> y

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just x) = Just x
maxMaybe (Just x) Nothing = Just x
maxMaybe (Just x) (Just y) = Just $ max x y

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
                   (Primitive (Circle 4))

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive triangle@(Triangle x y)) = Just $ area triangle
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic pic1) = maxMaybe (biggestTriangle pic) (biggestTriangle pic1)
biggestTriangle (Rotate _ pic) = biggestTriangle pic
biggestTriangle (Translate _ _ pic) = biggestTriangle pic


module Chapter2

||| Calculate the average length of words in a string
||| @str a string containing words separated by whitespace
export
average : (str : String) -> Double
average str = let num_words = word_count str
                  total_length = sum (word_lengths (words str)) in
                  cast total_length / cast num_words
where
  word_count : String -> Nat
  word_count str = length (words str)

  word_lengths : List String -> List Nat
  word_lengths strs = map length strs

showAverage : String -> String
showAverage str = "The average word length is: " ++
                   show (average str) ++ "\n"

palindrome : Nat -> String -> Bool
palindrome nat str = if ((length str) > nat) then (toLower str) == (reverse (toLower str)) else False

counts : String -> (Nat, Nat)
counts str = (length (words str), length str)

top_ten : Ord a => List a -> List a
top_ten lst = take 10 $ reverse $ sort lst

over_length : Nat -> List String -> Nat
over_length nat lst = length $ filter (\s => (length s) > nat) lst

main : IO ()
main = repl "Enter a string: " showAverage


module Data.Nat.Exponentiation

import Data.Nat as Nat
import Data.Nat.Properties
import Data.Monoid.Exponentiation as Mon
import Data.Num.Implementations as Num
import Data.Nat.Views
import Data.Nat.Order
import Syntax.PreorderReasoning
import Syntax.PreorderReasoning.Generic

%default total

public export
pow : Nat -> Nat -> Nat
pow = Mon.(^)

public export
lpow : Nat -> Nat -> Nat
lpow = linear @{Monoid.Multiplicative}

public export
pow2 : Nat -> Nat
pow2 = (2 ^)

public export
lpow2 : Nat -> Nat
lpow2 = lpow 2

export
modularCorrect : (v : Nat) -> {n : Nat} ->
                 pow v n === lpow v n
modularCorrect
   = Mon.modularCorrect
     @{Monoid.Multiplicative}
     (sym (multAssociative _ _ _))
     (irrelevantEq $ multOneLeftNeutral _)

export
pow2Correct : {n : Nat} -> pow2 n === lpow2 n
pow2Correct = modularCorrect 2

export
unfoldLpow2 : lpow2 (S n) === (lpow2 n + lpow2 n)
unfoldLpow2 = unfoldDouble

export
unfoldPow2 : pow2 (S n) === (pow2 n + pow2 n)
unfoldPow2 = irrelevantEq $ Calc $
  let mon : Monoid Nat; mon = Monoid.Multiplicative
      lpow2 : Nat -> Nat; lpow2 = linear @{mon} 2 in
  |~ pow2 (S n)
  ~~ lpow2 (S n)       ...( pow2Correct )
  ~~ lpow2 n + lpow2 n ...( unfoldLpow2 )
  ~~ (pow2 n + pow2 n) ...( cong2 (+) (sym pow2Correct) (sym pow2Correct) )

export
lteLpow2 : {m : Nat} -> 1 `LTE` lpow2 m
lteLpow2 {m = Z} = reflexive {rel = LTE}
lteLpow2 {m = S m} = CalcWith $
  let ih = lteLpow2 {m} in
  |~ 1
  <~ 2                 ...( ltZero )
  <~ lpow2 m + lpow2 m ...( plusLteMonotone ih ih )
  ~~ lpow2 (S m)       ...( sym (unfoldLpow2) )

export
ltePow2 : {m : Nat} -> 1 `LTE` pow2 m
ltePow2 = CalcWith $
  |~ 1
  <~ lpow2 m ...( lteLpow2 )
  ~~ pow2 m  ...( sym pow2Correct )

export
pow2Increasing : {m : Nat} -> pow2 m `LT` pow2 (S m)
pow2Increasing = CalcWith $
  |~ S (pow2 m)
  <~ pow2 m + pow2 m ...( plusLteMonotoneRight (pow2 m) 1 (pow2 m) ltePow2 )
  ~~ pow2 (S m)      ...( sym unfoldPow2 )


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

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 taken => Exact (x :: taken)

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 (div (length xs) 2) xs)
  halves xs | Fewer = ([], xs)
  halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)


||| Binary representation of natural numbers.
module BiNat

%access public export
%default total

data Bit = O | I

infixl 7 -:

data BiNat : Type where
  ||| Leading one bit
  J : BiNat

  ||| Append a bit to a BiNat.
  ||| `J -: O -: I -: I` corresponds to `1011`.
  (-:) : BiNat -> Bit -> BiNat

Uninhabited (J = n -: b) where
  uninhabited Refl impossible
Uninhabited (n -: b = J) where
  uninhabited Refl impossible
Uninhabited (m -: O = n -: I) where
  uninhabited Refl impossible
Uninhabited (m -: I = n -: O) where
  uninhabited Refl impossible

succ' : BiNat -> List Bit -> BiNat
succ' J        acc = foldl (-:) (J -: O) acc
succ' (n -: O) acc = foldl (-:) (n -: I) acc
succ' (n -: I) acc = succ' n (O :: acc)

||| The successor of a natural number.
succ : BiNat -> BiNat
succ n = succ' n []

pred' : BiNat -> List Bit -> BiNat
pred' J              acc = foldl (-:) J acc
pred' (n -: I)       acc = foldl (-:) (n -: O) acc
pred' (J -: O)       acc = foldl (-:) J acc
pred' (ns -: n -: O) acc = pred' (ns -: n) (I :: acc)

||| The predecessor of a natural number, but `pred J` is `J`.
pred : BiNat -> BiNat
pred n = pred' n []

nextCarry : Bit -> Bit -> Bit -> Bit
nextCarry I I I = I
nextCarry I I O = I
nextCarry I O I = I
nextCarry O I I = I
nextCarry _ _ _ = O

nextAcc : Bit -> Bit -> Bit -> Bit
nextAcc O O O = O
nextAcc O I I = O
nextAcc I O I = O
nextAcc I I O = O
nextAcc _ _ _ = I

plus' : BiNat -> BiNat -> Bit -> List Bit -> BiNat
plus' J         J         c acc = foldl (-:) (J -: c) acc
plus' J         ns        O acc = succ' ns acc
plus' J         (ns -: n) I acc = succ' ns (n :: acc)
plus' ms        J         O acc = succ' ms acc
plus' (ms -: m) J         I acc = succ' ms (m :: acc)
plus' (ms -: m) (ns -: n) c acc = plus' ms ns (nextCarry m n c) (nextAcc m n c :: acc)

||| Add two natural numbers.
plus : BiNat -> BiNat -> BiNat
plus m n = plus' m n O []

mult' : BiNat -> BiNat -> BiNat -> BiNat
mult' J         added acc = pred (plus added acc)
mult' (ms -: O) added acc = mult' ms (added -: O) acc
mult' (ms -: I) added acc = mult' ms (added -: O) (plus added acc)

||| Multiply natural numbers.
mult : BiNat -> BiNat -> BiNat
mult m n = mult' m n J

||| Convert an Integer to a BiNat, mapping non-positive numbers to J.
fromInteger : Integer -> BiNat
fromInteger i = if i <= 1 then J else fromInteger' i [] where
  fromInteger' : Integer -> List Bit -> BiNat
  fromInteger' 1 acc = foldl (-:) J acc
  fromInteger' i acc =
    fromInteger'
      (assert_smaller i (assert_total (div i 2)))
      ((if assert_total (mod i 2) == 0 then O else I) :: acc)

||| Convert a BiNat to an Integer.
toInteger : BiNat -> Integer
toInteger n = toInteger' n 1 0 where
  toInteger' : BiNat -> Integer -> Integer -> Integer
  toInteger' J         added acc = added + acc
  toInteger' (ns -: O) added acc = toInteger' ns (added * 2) acc
  toInteger' (ns -: I) added acc = toInteger' ns (added * 2) (acc + added)

tailToBiNat : List Bit -> BiNat
tailToBiNat []          = J
tailToBiNat (O :: tail) = tailToBiNat tail
tailToBiNat (I :: tail) = foldl (-:) J tail

minus' : BiNat -> BiNat -> List Bit -> BiNat
minus' J          J         tail = tailToBiNat tail
minus' J          ns        tail = J
minus' (J -: O)   J         tail = foldl (-:) J tail
minus' (ms -: O)  J         tail = foldl (-:) (pred ms -: I) tail
minus' (ms -: I)  J         tail = foldl (-:) (ms -: O) tail
minus' (ms -: O)  (ns -: O) tail = minus' ms ns (O :: tail)
minus' (J -: O)   (ns -: I) tail = J
minus' (ms -: O)  (ns -: I) tail = minus' (pred ms) ns (I :: tail)
minus' (ms -: I)  (ns -: O) tail = minus' ms ns (I :: tail)
minus' (ms -: I)  (ns -: I) tail = minus' ms ns (O :: tail)

||| Subtract natural numbers. If the second number is larger than or equal to the first, return J.
minus : BiNat -> BiNat -> BiNat
minus m n = minus' m n []

Eq BiNat where
  J         == J         = True
  (ns -: O) == (ms -: O) = ns == ms
  (ns -: I) == (ms -: I) = ns == ms
  _         == _         = False

||| Proofs that a BiNat is strictly less than another BiNat.
data LT : BiNat -> BiNat -> Type where
  JLT : (ns : BiNat) -> (n : Bit) -> LT J (ns -: n)
  LTLeading : (ms, ns : BiNat) -> ms = ns -> LT (ms -: O) (ns -: I)
  LTAppend : (ms, ns : BiNat) -> LT ms ns -> (m, n : Bit) -> LT (ms -: m) (ns -: n)

||| Strict greater than
GT : BiNat -> BiNat -> Type
GT m n = LT n m

Uninhabited (LT n J) where
  uninhabited JLT       impossible
  uninhabited LTLeading impossible
  uninhabited LTAppend  impossible

||| Less than or equal to
data LTE : BiNat -> BiNat -> Type where
  LTEEqual : (m, n : BiNat) -> m = n -> LTE m n
  LTELessThan : (m, n : BiNat) -> LT m n -> LTE m n

||| Greater than or equal to
GTE : BiNat -> BiNat -> Type
GTE m n = LTE n m

compare' : BiNat -> BiNat -> Ordering -> Ordering
compare' J         J         last = last
compare' J         (ns -: n) last = LT
compare' (ms -: m) J         last = GT
compare' (ms -: O) (ns -: O) last = compare' ms ns last
compare' (ms -: O) (ns -: I) last = compare' ms ns LT
compare' (ms -: I) (ns -: O) last = compare' ms ns GT
compare' (ms -: I) (ns -: I) last = compare' ms ns last

Ord BiNat where
  compare m n = compare' m n EQ

Num BiNat where
  (+) = plus
  (*) = mult
  fromInteger = BiNat.fromInteger


data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its length and height
              Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

testPic1 : Picture
testPic1 = Combine (Primitive (Triangle 2 3))
                   (Primitive (Triangle 2 4))

testPic2 : Picture
testPic2 = Combine (Primitive (Rectangle 1 3))
                   (Primitive (Circle 4))

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
    = case compare x val of
           LT => Node (insert x left) val right
           EQ => orig
           GT => Node left val (insert x right)

-- Exercise 1
listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

-- Exercise 2
-- The function `treeToList` does an in-order traversal of a tree.
treeToList : Ord a => Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = (treeToList left) ++ x :: treeToList right

-- Exercise 3
data Expr = Val Integer
          | Add Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr
-- Exercise 4
evaluate : Expr -> Integer
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mul x y) = evaluate x * evaluate y

-- Exercise 5
maybeMax : Ord a => Maybe a -> Maybe a -> Maybe a
maybeMax Nothing Nothing = Nothing
maybeMax Nothing (Just x) = Just x
maybeMax (Just x) Nothing = Just x
maybeMax (Just x) (Just y) = Just $ max x y

-- Exercise 6
biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just $ area tri
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic1 pic2) = maybeMax (biggestTriangle pic1) (biggestTriangle pic2)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic


||| Algebra.Magma: A representation of magmas.
|||
||| A magma is more-or-less the simplest non-trivial example of a algebraic
||| structure. It is simply a set together with a lawless binary operation over
||| it. More formally, it is *any* pair
||| \\(\mathscr{M} = (M:\mathscr{V}, \* : M^2 \to M)\\). It doesn't matter what
||| the function \\(\*\\) is. It can have any properties whatsoever; the only
||| reuirement is that it be a function of the specified type. That is, it must
||| be a total co-injective relation with domain \\(M^2\\) and codomain \\(M\\),
||| where by \"co-injective\" I mean that for every input, there is no more than
||| one output. Together with totality, which states that every input has at
||| least one output, this means that a function is a relation where every input
||| has exactly one output.
|||
||| Magmas aren't especially interesting in and of themselves. Because there are
||| no magma axioms, just a type, there isn't much that can be said about magmas
||| in general. However, they give a useful way to talk about other algebraic
||| structures. A group, for example, is a magma satisfying certain laws. In
||| other words, talking in terms of magmas and related lawless algebraic
||| structures just gives us a more convenient way to talk about the signature
||| of the more interesting ones. (Of course, all of this leads naturally to
||| groups, semigroups, monoids, etc. being extensions of the `Magma`
||| record.)
|||
||| That's not to say there's nothing interesting about magmas. There are
||| interesting combinatorial questions arising from freely generated magmas.
||| That is, consider a magma generated by three elements, \\(a, b, c\\). By
||| \"freely generated\", we mean that there are no equalities except those
||| directly entailed by the axioms; since there aren't any axioms, there aren't
||| any (non-reflexive) equalities! E.g., in a freely generated magma, we know
||| that \\((x\*y)\*z \neq x\*(y\*z)\\) for every \\(x, y, z\\). If they were
||| equal, it would still be a magma, but not a freely generated one. Now, for
||| the free magma with 3 generating elements, how many elements are there with
||| exactly \\(k\\) applications of the operation \\(\*\\)? Or more generally,
||| what if there are \\(n\\) generating elements? If you like combinatorics,
||| you might enjoy working these and related questions out\-\-\-and, as usual,
||| there's a connection to the Catalan numbers.
module Algebra.Magma

%default total

infix 7 |*|

||| The record representing magmas. Note that there are no proofs to be
||| automatically filled in; magmas don't have any extra properties beyond their
||| signature.
public export
record Magma where
  constructor MkMagma
  Set' : Type
  op'  : Set' -> Set' -> Set'

public export
Set : {magma : Magma} -> Type
Set {magma} = Set' magma

public export
(|*|) : {magma : Magma} -> Set {magma} -> Set {magma} -> Set {magma}
(|*|) {magma} = op' magma

{-
public export
AddMagma : (Num ty) => Magma
AddMagma {ty} = MkMagma ty (+)

public export
MultMagma : (Num ty) => Magma
MultMagma {ty} = MkMagma ty (*)

-- -}

-- data Magma : (Set : Type) -> (Set -> Set -> Set) -> Type where
--   Magmoid :
-- {-


-- Exercise 1
data Elem : a -> List a -> Type where
     Here : Elem x (x :: xs)
     There : Elem x xs -> Elem x (y :: xs)

-- Exercise 2
data Last : List a -> a -> Type where
     LastOne : Last [value] value
     LastCons : (prf : Last xs value) -> Last (x :: xs) value

lastNotNil : (value : a) -> Last [] x -> Void
lastNotNil _ LastOne impossible
lastNotNil _ (LastCons _) impossible

lastNotCons : (contra : Last (x :: xs) value -> Void) ->
              Last (y :: (x :: xs)) value -> Void
lastNotCons contra (LastCons prf) = contra prf

lastNotSingleton : (contra : (y = value) -> Void) -> Last [y] value -> Void
lastNotSingleton contra LastOne = contra Refl
lastNotSingleton _ (LastCons LastOne) impossible
lastNotSingleton _ (LastCons (LastCons _)) impossible

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No (lastNotNil value)
isLast (y :: []) value = case decEq y value of
                              (Yes Refl) => Yes LastOne
                              (No contra) => No (lastNotSingleton contra)
isLast (y :: (x :: xs)) value = case isLast (x :: xs) value of
                                     (Yes prf) => Yes (LastCons prf)
                                     (No contra) => No (lastNotCons contra)


{- 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 -}
module Main

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 : (Abs num, 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)

data Expr' : Type -> Type where
  Val' : num -> Expr' num
  Add' : Num num => Expr' num -> Expr' num -> Expr' num
  Mul' : Num num => Expr' num -> Expr' num -> Expr' num
  Sub' : Neg neg => Expr' neg -> Expr' neg -> Expr' neg
  Div' : Integral int => Expr' int -> Expr' int -> Expr' int
  Abs' : Abs abs => Expr' abs -> Expr' abs

eval' : Expr' num -> num
eval' (Val' x) = x
eval' (Add' x y) = eval' x + eval' y
eval' (Mul' x y) = eval' x * eval' y
eval' (Sub' 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 ty => Abs (Expr ty) where
  abs = Abs

Show ty => Show (Expr ty) where
  show e = case e of
    (Val x) => show x
    (Add x y) => "(" ++ show x ++ " + " ++ show y ++ ")"
    (Sub x y) => "(" ++ show x ++ " - " ++ show y ++ ")"
    (Mul x y) => "(" ++ show x ++ " * " ++ show y ++ ")"
    (Div x y) => "(" ++ show x ++ " / " ++ show y ++ ")"
    (Abs x) => "|" ++ show x ++ "|"

(Eq ty, Integral ty, Neg ty, Abs ty) => Eq (Expr ty) where
  e1 == e2 = eval e1 == eval e2

(Integral ty, Neg ty, Abs ty) => Cast (Expr ty) ty where
  cast e = eval e

totalLen : List String -> Nat
totalLen xs = foldr (\str, len => length str + len) 0 xs

main : IO ()
main = do
  putStrLn "Expr"
  printLn $ eval $ the (Expr Integer) (Add (Val 6) (Mul (Val 3) (Val 12)))
  printLn $ eval $ the (Expr Integer) (6 + 3 * 12)
  printLn $ the (Expr Integer) (6 + 3 * 12)
  printLn $ eval' $ the (Expr' Integer) (Add' (Val' 6) (Mul' (Val' 3) (Val' 12)))
  printLn $ map (*2) [1,2,3,4]
  printLn $ foldr (+) 0 [1,2,3,4]
  printLn $ foldr (*) 1 [1,2,3,4]
  printLn $ totalLen ["One", "Two", "Three"]


data MyVect : (len: Nat) -> (elem: Type) -> Type where
  Nil  : MyVect 0 elem
  (::) : (e: elem) -> (tail: MyVect len elem) -> MyVect (S len) elem

Eq elem => Eq (MyVect n elem) where
  (==) Nil Nil = True
  (==) (head :: tail) (head' :: tail') = head == head' && tail == tail'

Foldable (MyVect n) where
  foldr func acc Nil = acc
  foldr func acc (e :: tail) =
    let
      foldedTail = foldr func acc tail
    in
      func e foldedTail

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

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 (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
--     Nothing => Nothing
--     Just prf => Just (cong prf)

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

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

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

checkEqNat: (num1: Nat) -> (num2: Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zeroNotSuc
checkEqNat (S k) Z = No sucNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
  Yes prf => Yes (cong prf)
  No contra => No (noRec contra)

exactLength: (len: Nat) -> (input: MyVect m a) -> Maybe (MyVect len a)
exactLength {m} len input =
  case decEq m len of
    Yes Refl  => Just input
    No contra => Nothing

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

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

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

example1: MyVect 4 Integer
example1 = 1 :: 2 :: 3 :: 4 :: Nil

example1': MyVect 4 Integer
example1' = 1 :: 2 :: 3 :: 4 :: Nil

example2: MyVect 3 Integer
example2 = 1 :: 2 :: 3 :: Nil

example3: MyVect 4 Integer
example3 = 4 :: 3 :: 2 :: 1 :: Nil

natEqual: (x: Nat) -> (y: Nat) -> Maybe(x = y)
natEqual Z Z = Just Refl
natEqual Z (S k) = Nothing
natEqual (S k) Z = Nothing
natEqual (S k) (S j) = case natEqual k j of
  Nothing => Nothing
  (Just prf) => Just (cong prf)


module BoehmBerarducci

%default total

NatQ : Type
NatQ = (A : Type) -> (A -> A) -> A -> A

unNatQ : {A : Type} -> (A -> A) -> A -> NatQ -> A
unNatQ f a q = q _ f a

succQ : NatQ -> NatQ
succQ q = \_, f, a => f (q _ f a)

zeroQ : NatQ
zeroQ = \_, f, a => a

fromNatQ : NatQ -> Nat
fromNatQ q = unNatQ S Z q

toNatQ : Nat -> NatQ
toNatQ (S n) = succQ (toNatQ n)
toNatQ Z     = zeroQ

iterated : Nat -> (a -> a) -> a -> a
iterated (S n) f a = f (iterated n f a)
iterated Z f a     = a

test_iterated : (n : Nat) -> iterated n S Z = n
test_iterated (S n) = rewrite test_iterated n in Refl
test_iterated Z     = Refl

test_fromNatQ : (n : Nat) -> fromNatQ (iterated n succQ zeroQ) = n
test_fromNatQ (S n) = rewrite test_fromNatQ n in Refl
test_fromNatQ Z     = Refl

test_toNatQ : (n : Nat) -> toNatQ n = iterated n succQ zeroQ
test_toNatQ (S n) = rewrite test_toNatQ n in Refl
test_toNatQ Z = Refl

ListQ : Type -> Type
ListQ A = (B : Type) -> (A -> B -> B) -> B -> B

unListQ : {A, B : Type} -> (A -> B -> B) -> B -> ListQ A -> B
unListQ f b q = q _ f b

consQ : {A : Type} -> A -> ListQ A -> ListQ A
consQ a q = \_, f, b => f a (q _ f b)

nilQ : {A : Type} -> ListQ A
nilQ = \_, f, b => b

fromListQ : {A : Type} -> ListQ A -> List A
fromListQ q = unListQ (::) [] q

toListQ : {A : Type} -> List A -> ListQ A
toListQ (a :: aa) = consQ a (toListQ aa)
toListQ []        = nilQ


> module Fraction.BasicOperations

> import Fraction.Fraction
> import PNat.PNat
> import PNat.Operations
> import Nat.Positive

> %default total
> %access public export

> ||| The numerator of a fraction
> num : Fraction -> Nat
> num = fst

> ||| The denominator of a fraction
> den : Fraction -> Nat
> den = toNat . snd

> ||| Every natural number is a fraction
> fromNat : Nat -> Fraction
> fromNat n = (n, Element (S Z) MkPositive)

> ||| Fraction addition
> plus : Fraction -> Fraction -> Fraction
> plus (n1, d1) (n2, d2) = (n1 * (toNat d2) + n2 * (toNat d1), d1 * d2)

> ||| Fraction multiplication
> mult : Fraction -> Fraction -> Fraction
> mult (n1, d1) (n2, d2) = (n1 * n2, d1 * d2)

> ||| Fraction upscaling
> upscale : Fraction -> PNat -> Fraction
> upscale (m, d) e = (m * (toNat e), d * e)


module Graphs1
import Data.Vect

%access public export

{-This program works only for simple undirected graphs. and whenever I use "am" it means adjacency matrix.
Please give a symmetric matrix for am. The important functions in this program are
EdgeisPath
ConnectedComponents
PathWithProof
AdjacentsAreConnected
-}
|||Checks whether 2 numbers are equal and returns nothing or a proof of equality
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
                              Nothing => Nothing
                              (Just x) => Just (cong x)
|||Returns the i j element of an m by n matrix and nothing if ij is out of bounds.
Access : Vect m (Vect n Nat)->(i:Nat)->(j:Nat)->Maybe Nat
Access {n}{m} xs i j = case ((integerToFin  ((cast j)-1) n),(integerToFin  ((cast i)-1) m)) of
                         (Nothing, _) => Nothing
                         (_ ,Nothing) => Nothing
                         (Just x, Just y) => Just ((Vect.index x (Vect.index y xs)))

|||Returns the i j element of an n by n matrix with 0 if it is out of bounds
Accessnum:Vect n (Vect n Nat)->(i:Nat)->(j:Nat)-> Nat
Accessnum xs i j = case Access xs i j of
                    Nothing => 0
                    (Just x) => x
|||A type inhabited if only if vertices i and j are connected by an edge
data Edge :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Type where
    Thereisanedge :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->(Accessnum am i j) =1 ->Edge am i j
|||A type inhabited iff vertices i and j are connected by a path
data Path : (am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Type where
  Self : (i:Nat)->Path am i i
  Adjacent : (Edge am i j) ->Path am i j
  Thereispath: (am:(Vect n (Vect n Nat)))-> (i:Nat)->(k:Nat) ->Path am i k->(Edge am j i)->Path am j k
|||Returns Nothing if there is no edge or a proof that Accessnum am i j =1
Isthereanedge: (am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Maybe ( (Accessnum am i j ) = 1)
Isthereanedge am i j = case Access am i j of
                            Nothing => Nothing
                            (Just x) => (case checkEqNat (Accessnum am i j ) 1 of
                                              Nothing => Nothing
                                              (Just y) => (Just y))
|||Returns a proof that 2 adjacent vertices are connected or nothing if they are not connected.
AdjacentsAreConnected:(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)->Maybe (Path am i j)
AdjacentsAreConnected am i j = case Isthereanedge am i j of
                                    Nothing => Nothing
                                    (Just x) => Just (Adjacent (Thereisanedge am i j x))
|||Proves that adjacent vertices (ie vertices that have an edge between them are connected)
EdgeisPath :(am:(Vect n (Vect n Nat)))-> (Edge am i j)->Path am i j
EdgeisPath am (Thereisanedge am i j prf) = Adjacent (Thereisanedge am i j prf)

|||Checks whether a Natural number is in the list or not
isInList  : (i:Nat)->List Nat ->Bool
isInList i [] = False
isInList i (x :: xs) = case (x==i) of
                            False => isInList i xs
                            True => True
|||Updates an adjacency list if there is an edge between i and (S j) and calls the same function with j
adja :(am:(Vect n (Vect n Nat)))-> (i:Nat)->(j:Nat)  ->List (s:Nat**Path am i s)->List (s:Nat**Path am i s)
adja am i Z xs = xs
adja am i (S k) xs = case AdjacentsAreConnected am i (S k) of
                      Nothing => adja am i k xs
                      (Just x) => adja am i k (((S k )**x)::xs)
|||Returns a list of adjacent vectors to i with a proof that they are connected
Adjacents :(am:(Vect n (Vect n Nat)))-> (i:Nat)->List (s:Nat**Path am i s)
Adjacents {n} am i = adja am i n []
Adjacentlist:(am:(Vect n (Vect n Nat)))-> (i:Nat)->List Nat
Adjacentlist am i = map fst (Adjacents am i)
|||Returns the list of elements in the first list, but not in the second
Complement: List Nat ->List Nat ->List Nat
Complement [] ys = []
Complement (x :: xs) ys = case isInList x ys of
                               False => x::(Complement xs ys)
                               True => Complement xs ys

|||Does Depth first search of i and returns the list of elements connected to i
Dfs :(am:(Vect n (Vect n Nat)))-> (i:Nat) ->List Nat->List Nat
Dfs am i xs = case Complement (Adjacentlist am i) xs of
                     []=>xs
                     (j::ys)=>Dfs am i (Dfs am j (j::xs))

|||A helper function for ConnectedComponents
Connectedcompos: (am:(Vect n (Vect n Nat)))->List Nat ->List (List Nat)->(List (List Nat))
Connectedcompos{n} am xs ys = case Complement [1..n] xs of
                                [] => ys
                                (x :: zs) => Connectedcompos am (xs++(Dfs am x [x])) ((Dfs am x [x])::ys)

|||Gives the connected components of a graph as a list of lists
ConnectedComponents :  (am:(Vect n (Vect n Nat)))->(List (List Nat))
ConnectedComponents am = Connectedcompos am [] []

|||Modified depth first search which searches for a path between i and k. When there is no path, it behaves just like a depth first search from i
Dfss :(am:(Vect n (Vect n Nat)))-> (i:Nat) ->(k:Nat)->(Found:Bool)->List Nat->List Nat->((List Nat,List Nat),Bool)
Dfss am i k True path visit = ((path,visit),True)
Dfss am i k False path visit = case Complement (Adjacentlist am i) visit of
                     []=>(([],visit),False)
                     (j::ys)=>(case (k==j) of
                       True =>(((k::path),(j::visit)),True)
                       False =>  let dps =(Dfss am j k False (j::path) (j::visit)) in (let pathn = (case (snd(dps)) of
                                                                                False => path
                                                                                True => (fst (fst (dps)))) in (Dfss am i k  (snd(dps)) pathn (snd (fst (dps))))))

||| Ruturns a path between 2 vertices and returns Nothing if there is no path.
FindPath :(am:(Vect n (Vect n Nat)))->(k:Nat)->(i:Nat)->Maybe (List Nat)
FindPath am k i = case (k==i) of
                  True => Just [i]
                  False =>   (case isInList k (Dfs am  i [i])  of
                     False => Nothing
                     True => Just (fst (fst (Dfss am i k False [i] [i]))))
|||Gives the proof that there is a path between i and k when the path is not just one vertex long
Proofcon2 :(am:(Vect n (Vect n Nat)))-> List Nat -> (i:Nat)->(k:Nat)-> Path am i k
Proofcon2 am [j,p] i k = case checkEqNat p k of
                           (Just Refl) => (case AdjacentsAreConnected am i k of
                                                (Just x) => x)
Proofcon2 am (x::y::z::xs) i k =case AdjacentsAreConnected am i y of
                                                           (Just (Adjacent x)) => (let loop = Proofcon2 am (y::z::xs) y k in
                                                                 Thereispath am y k loop x )

|||Gives proof for 1 vertex long paths and calls proofcon2 when there are at least 2 vertices in the path
Proofcon :(am:(Vect n (Vect n Nat)))-> List Nat -> (i:Nat)->(k:Nat)-> Path am i k
Proofcon am xs i k = case checkEqNat i k of
                          (Just Refl) => Self i
                          Nothing => Proofcon2 am xs i k
|||Gives a path with proof when there is a path between k and i and Nothing when there is no path.
PathWithProof :(am:(Vect n (Vect n Nat)))->(k:Nat)->(i:Nat)->Maybe((List Nat),Path am k i )
PathWithProof am k i = case FindPath am k i of
                        Nothing => Nothing
                        Just x => Just (x,Proofcon am x k i)


module Evens

% access public export

public export
data IsEven : Nat -> Type where
  ZEven : IsEven 0
  SSEven : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = SSEven 0 ZEven

fourEven : IsEven 4
fourEven = SSEven 2 twoEven

half : (n: Nat) -> IsEven n -> Nat
half Z ZEven = 0
half (S (S k)) (SSEven k x) = S (half k x)

double: Nat -> Nat
double Z = Z
double (S k) = S (S (double k))

doubleEven : (n: Nat) -> IsEven (double n)
doubleEven Z = ZEven
doubleEven (S k) = SSEven (double k) (doubleEven k)

halfDouble: Nat -> Nat
halfDouble n = half (double n) (doubleEven n)

oneOdd: IsEven 1 -> Void
oneOdd ZEven impossible
oneOdd (SSEven _ _) impossible

threeOdd : IsEven 3 -> Void
threeOdd (SSEven (S Z) ZEven) impossible
threeOdd (SSEven (S Z) (SSEven _ _)) impossible

nOrSnEven: (n: Nat) -> Either (IsEven n) (IsEven (S n))
nOrSnEven Z = Left ZEven
nOrSnEven (S k) = case (nOrSnEven k) of
                       (Left l) => Right (SSEven k l)
                       (Right r) => Left r

halfRoof: Nat -> Nat
halfRoof n = case (nOrSnEven n) of
                  (Left nEven) => half n nEven
                  (Right snEven) => half (S n) snEven

nSnNotBothEven: (n: Nat) -> (IsEven n) -> IsEven (S n) -> Void
nSnNotBothEven Z ZEven ZEven impossible
nSnNotBothEven Z ZEven (SSEven _ _) impossible
nSnNotBothEven (S (S k)) (SSEven k x) (SSEven (S k) y) = nSnNotBothEven k x y

notNandSnEven : (n: Nat) -> (IsEven n , IsEven (S n)) -> Void
notNandSnEven n (a, b) = nSnNotBothEven n a b

apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

byTwo : (n: Nat) -> IsEven n -> (k: Nat ** double k = n)
byTwo Z ZEven = (0 ** Refl)
byTwo (S (S k)) (SSEven k x) = step where
  step = case (byTwo k x) of
            (m ** pf) => ((S m) ** apNat (\l => S (S l)) (double m) k pf)

oneOddFamily : Nat -> Type
oneOddFamily Z = ()
oneOddFamily (S Z) = Void
oneOddFamily (S (S k)) = ()

oneOddProof : (n : Nat) -> IsEven n -> oneOddFamily n
oneOddProof Z ZEven = ()
oneOddProof (S (S k)) (SSEven k x) = ()

-- Examples

halfRoof3 : Nat
halfRoof3 = halfRoof 3 -- 2 : Nat

-- Equality added

thmAdd : (a: Nat) -> (b: Nat) -> (a = 0) -> (b = 0) -> (a + b = 0)
thmAdd Z Z Refl Refl = Refl

symmEq : (x : Type) -> (a: x) -> (b: x) -> (a = b) -> (b = a)
symmEq x b b Refl = Refl


import Data.Vect

word_lengths : Vect len String -> Vect len Nat
word_lengths [] = []
word_lengths (x :: xs) = length x :: word_lengths xs

-- insertion sort
insert : Ord elem =>
         (x : elem) -> (xs_sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

ins_sort : Ord elem => Vect n elem -> Vect n elem
ins_sort [] = []
ins_sort (x :: xs) = let xs_sorted = ins_sort xs in
                         insert x xs_sorted

-- 3.2.4 excercises

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

||| length using type var
my_length_vect : Vect n a -> Nat
my_length_vect {n} xs = n

my_reverse : List a -> List a
my_reverse = foldl (flip (::)) []

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

-- this one generated itself!!
mymapv : (a -> b) -> Vect n a -> Vect n b
mymapv f [] = []
mymapv f (x :: xs) = f x :: mymapv f xs

-- 3.3

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

transpose_helper : (x : Vect n elem) -> (xs_trans : Vect n (Vect k elem)) ->
                    Vect n (Vect (S k) elem)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys
-- usage replaced by zipWith

transpose_mat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose_mat [] = create_empties
transpose_mat (x :: xs) = let xs_trans = transpose_mat xs in
                              zipWith (::) x xs_trans

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 :: addMatrix xs ys


> module Nat.LTProperties

> import Nat.BasicProperties
> import Nat.LTEProperties

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

|LT| is unique:

> ||| LT is unique
> uniqueLT : (p1 : LT m n) -> (p2 : LT m n) -> p1 = p2
> uniqueLT {m} {n} = uniqueLTE {m = S m} {n = n}
> %freeze uniqueLT

> |||
> uniqueLT' : m1 = m2 -> n1 = n2 -> (p1 : LT m1 n1) -> (p2 : LT m2 n2) -> p1 = p2
> uniqueLT' Refl Refl p1 p2 = uniqueLT p1 p2
> %freeze uniqueLT'

|LT| is decidable:

> ||| LT is decidable
> decLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)
> decLT m n = decLTE (S m) n
> %freeze decLT

Properties of |LT| and successor:

> |||
> ltLemma1 : (m : Nat) -> (n : Nat) -> LT (S m) n -> LT m n
> ltLemma1 m n prf = lteLemma1 (S m) n prf
> %freeze ltLemma1

> ||| LT is contained in LTE
> ltInLTE : (m : Nat) -> (n : Nat) -> LT m n -> LTE m n
> ltInLTE = lteLemma1
> %freeze ltInLTE

> ||| Zero is smaller than any successor
> ltZS : (m : Nat) -> LT Z (S m)
> ltZS  Z    = LTESucc LTEZero
> ltZS (S m) = idSuccPreservesLTE (S Z) (S m) (ltZS m)
> %freeze ltZS

> ||| Zero is smaller than any successor
> ltZS' : {n : Nat} -> LT Z (S n)
> ltZS' {n = Z}   = LTESucc LTEZero
> ltZS' {n = S m} = idSuccPreservesLTE (S Z) (S m) ltZS'
> %freeze ltZS'

> ||| Any number is smaller than its successor
> ltIdS : (m : Nat) -> LT m (S m)
> ltIdS  Z    = LTESucc LTEZero
> ltIdS (S m) = LTESucc (ltIdS m)
> %freeze ltIdS

> ||| Any number which is not zero is greater than zero
> notZisgtZ : {n : Nat} -> Not (n = Z) -> LT Z n
> notZisgtZ {n = Z}   contra = void (contra Refl)
> notZisgtZ {n = S m} _      = ltZS m
> %freeze notZisgtZ

> ||| Any number which is greater than zero is not zero
> gtZisnotZ : {n : Nat} -> LT Z n -> Not (n = Z)
> gtZisnotZ {n = Z}   p = absurd p
> gtZisnotZ {n = S m} p = SIsNotZ
> %freeze gtZisnotZ

> ||| No number is less than zero
> notLTzero : {n : Nat} -> Not (LT n Z)
> notLTzero = succNotLTEzero
> %freeze notLTzero

> |||
> strengthenLT : (m : Nat) -> (n : Nat) -> LT m (S n) -> Not (m = n) -> LT m n
> strengthenLT  Z       n  _       zNEQn   = notZisgtZ (zNEQn . sym)
> strengthenLT (S m)  Z    smLTsz  _       = void (notLTzero (fromLteSucc smLTsz))
> strengthenLT (S m) (S n) smLTssn smNEQsn = LTESucc mLTn where
>   mLTsn : LT m (S n)
>   mLTsn = fromLteSucc smLTssn
>   mNEQn : Not (m = n)
>   mNEQn = predInjective m n smNEQsn
>   mLTn : LT m n
>   mLTn = strengthenLT m n mLTsn mNEQn
> %freeze strengthenLT

> {-

> ---}


||| Implementation of ordering relations for `Nat`ural numbers
module Data.Nat.Order

import Data.Nat
import Data.Fun
import Data.Rel
import Decidable.Decidable

%default total

public export
zeroNeverGreater : Not (LTE (S n) Z)
zeroNeverGreater LTEZero     impossible
zeroNeverGreater (LTESucc _) impossible

public export
zeroAlwaysSmaller : {n : Nat} -> LTE Z n
zeroAlwaysSmaller = LTEZero

public export
ltesuccinjective : {0 n, m : Nat} -> Not (LTE n m) -> Not (LTE (S n) (S m))
ltesuccinjective disprf (LTESucc nLTEm) = void (disprf nLTEm)
ltesuccinjective disprf LTEZero         impossible

-- Remove any time after release of 0.6.0
||| Deprecated. Use `Nat.isLTE`.
public export
decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)
decideLTE = isLTE

public export
Decidable 2 [Nat,Nat] LTE where
  decide = decideLTE

public export
Decidable 2 [Nat,Nat] LT where
  decide m = decideLTE (S m)

public export
lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)
lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n

public export
shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)
shift m n mLTEn = LTESucc mLTEn


module Toolkit.Data.List.Size

public export
data Size : List a -> Nat -> Type where
  Zero    : Size Nil Z
  PlusOne : Size       rest     k
         -> Size (e :: rest) (S k)

export
size' : (xs : List a) -> DPair Nat (Size xs)
size' [] = MkDPair Z Zero
size' (x :: xs) with (size' xs)
  size' (x :: xs) | (MkDPair k rest) = MkDPair (S k) (PlusOne rest)

export
size : (xs : List a) -> Size xs (length xs)
size [] = Zero
size (x :: xs) = PlusOne (size xs)

Uninhabited (Size Nil (S x)) where
  uninhabited Zero impossible
  uninhabited (PlusOne x) impossible

Uninhabited (Size (x::xs) Z) where
  uninhabited Zero impossible
  uninhabited (PlusOne x) impossible

export
hasSize : (xs : List a) -> (d : Nat) -> Dec (Size xs d)
hasSize xs d with (xs)
  hasSize xs 0 | [] = Yes Zero
  hasSize xs (S k) | [] = No absurd

  hasSize xs 0 | (x :: ys) = No absurd
  hasSize xs (S k) | (x :: ys) with (hasSize ys k)
    hasSize xs (S k) | (x :: ys) | (Yes prf) = Yes (PlusOne prf)
    hasSize xs (S k) | (x :: ys) | (No contra) = No (\(PlusOne y) => contra y)

-- [ EOF ]


module Part2.Sec6_2_1_adder

{-
Think of this type as type level function
second case maps AdderType to a function type
-}
AdderType : (numargs : Nat) -> Type
AdderType Z = Int
AdderType (S k) = (nextArg : Int) -> AdderType k

||| adder numargs acc nums...
||| adder 0 : Int -> Int
||| adder 1 : Int -> Int -> Int
||| adder 2 : Int -> Int -> Int -> Int
||| adder 2 : Int -> Int -> Int -> Int
adder : (numargs : Nat) -> (acc : Int) -> AdderType numargs
adder Z acc = acc
adder (S k) acc = \nextArg => adder k (nextArg + acc)


module MergeSort

data SplitList : List a -> Type where
     SplitNil : SplitList []
     SplitOne : SplitList [x]
     SplitPair : (lefts : List a) -> (rights : List a) -> SplitList (lefts ++ rights)

total
splitList : (l : List a) -> SplitList l
splitList inp = splitListHelp inp inp
  where
    splitListHelp : List a -> (l : List a) -> SplitList l
    splitListHelp _ [] = SplitNil
    splitListHelp _ [x] = SplitOne
    splitListHelp (_ :: _ :: counter) (i :: items) = case splitListHelp counter items of
                                                          SplitNil => SplitOne
                                                          SplitOne {x} => SplitPair [i] [x]
                                                          (SplitPair lefts rights) => SplitPair (i :: lefts) rights
    splitListHelp _ items = SplitPair [] items

mergeSort : Ord a => List a -> List a
mergeSort xs with (splitList xs)
  mergeSort [] | SplitNil = []
  mergeSort [x] | SplitOne = [x]
  mergeSort (lefts ++ rights) | (SplitPair lefts rights) = merge (mergeSort lefts) (mergeSort rights)


> module Nat.GCDProperties

> import Nat.GCD
> import Nat.GCDOperations
> import Nat.Divisor
> import Nat.DivisorOperations
> import Nat.DivisorProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import Basic.Operations
> import Sigma.Sigma
> import Pairs.Operations

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

> |||
> gcdUnique : (d1 : Nat) -> (d2 : Nat) -> GCD d1 m n -> GCD d2 m n -> d1 = d2
> gcdUnique d1 d2 (MkGCD d1Dm d1Dn d1G) (MkGCD d2Dm d2Dn d2G) = s3 where
>   s1 : d1 `Divisor` d2
>   s1 = d2G d1 d1Dm d1Dn
>   s2 : d2 `Divisor` d1
>   s2 = d1G d2 d2Dm d2Dn
>   s3 : d1 = d2
>   s3 = divisorAntisymmetric d1 d2 s1 s2
> %freeze gcdUnique

> |||
> gcdCommutative : GCD d m n -> GCD d n m
> gcdCommutative (MkGCD dDm dDn dG) = (MkGCD dDn dDm (\ d' => \ n => \ m => dG d' m n))
> %freeze gcdCommutative

> ||| If |m| is positive, the greatest common divisor of |m| and |n| is positive
> gcdPreservesPositivity1 : Z `LT` m -> (dv : Sigma Nat (\ d => GCD d m n)) -> Z `LT` (getWitness dv)
> gcdPreservesPositivity1 {m} zLTm (MkSigma d prf) = multLTZeroLeftLTZero d q zLTdq where
>   dDm : d `Divisor` m
>   dDm = gcdDivisorFst prf
>   q : Nat
>   q = quotient m d dDm
>   zLTdq : Z `LT` (d * q)
>   zLTdq = replace {x = m}
>                   {y = d * q}
>                   {P = \ ZUZU => Z `LT` ZUZU}
>                   (sym (quotientLemma m d dDm)) zLTm
> %freeze gcdPreservesPositivity1

> ||| If |n| is positive, the greatest common divisor of |m| and |n| is positive
> gcdPreservesPositivity2 : Z `LT` n -> (dv : Sigma Nat (\ d => GCD d m n)) -> Z `LT` (getWitness dv)
> gcdPreservesPositivity2 {n} zLTn (MkSigma d prf) = multLTZeroLeftLTZero d q zLTdq where
>   dDn : d `Divisor` n
>   dDn = gcdDivisorSnd prf
>   q : Nat
>   q = quotient n d dDn
>   zLTdq : Z `LT` (d * q)
>   zLTdq = replace {x = n}
>                   {y = d * q}
>                   {P = \ ZUZU => Z `LT` ZUZU}
>                   (sym (quotientLemma n d dDn)) zLTn
> %freeze gcdPreservesPositivity2

> |||
> gcdLemma : (v : GCD (S d) m n) ->
>            d' `Divisor` (quotient m (S d) (gcdDivisorFst v)) ->
>            d' `Divisor` (quotient n (S d) (gcdDivisorSnd v)) ->
>            d' `Divisor` S Z
> gcdLemma {d} {d'} {m} {n} v d'DmoSd d'DnoSd = divisorOneLemma d d' Sdd'DSd where
>   SdDm    : (S d) `Divisor` m
>   SdDm    = gcdDivisorFst v
>   SdDn    : (S d) `Divisor` n
>   SdDn    = gcdDivisorSnd v
>   SdG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` (S d)
>   SdG     = gcdDivisorGreatest v
>   Sdd'Dm  : (S d) * d' `Divisor` m
>   Sdd'Dm  = divisorTowerLemma (S d) d' m SdDm d'DmoSd
>   Sdd'Dn  : (S d) * d' `Divisor` n
>   Sdd'Dn  = divisorTowerLemma (S d) d' n SdDn d'DnoSd
>   Sdd'DSd : (S d) * d' `Divisor` (S d)
>   Sdd'DSd = SdG ((S d) * d') Sdd'Dm Sdd'Dn
> %freeze gcdLemma

> |||
> gcdLemma' : (v : GCD d m n) -> Not (d = Z) ->
>             d' `Divisor` (quotient m d (gcdDivisorFst v)) ->
>             d' `Divisor` (quotient n d (gcdDivisorSnd v)) ->
>             d' `Divisor` S Z
> gcdLemma' {d} {d'} {m} {n} v dNotZ d'DmoSd d'DnoSd = divisorOneLemma' d d' dNotZ Sdd'DSd where
>   SdDm    : d `Divisor` m
>   SdDm    = gcdDivisorFst v
>   SdDn    : d `Divisor` n
>   SdDn    = gcdDivisorSnd v
>   SdG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   SdG     = gcdDivisorGreatest v
>   Sdd'Dm  : d * d' `Divisor` m
>   Sdd'Dm  = divisorTowerLemma d d' m SdDm d'DmoSd
>   Sdd'Dn  : d * d' `Divisor` n
>   Sdd'Dn  = divisorTowerLemma d d' n SdDn d'DnoSd
>   Sdd'DSd : d * d' `Divisor` d
>   Sdd'DSd = SdG (d * d') Sdd'Dm Sdd'Dn
> %freeze gcdLemma'

> |||
> gcdLemma'' : (d : Nat) -> (m : Nat) -> (n : Nat) ->
>              (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>              (v : GCD d m n) -> Z `LT` d ->
>              (d' : Nat) ->
>              d' `Divisor` (quotient m d dDm) ->
>              d' `Divisor` (quotient n d dDn) ->
>              d' `Divisor` S Z
> gcdLemma'' d m n dDm dDn v zLTd d' d'Dqmd d'Dqnd = divisorOneLemma'' d d' zLTd dd'Dd where
>   dG     : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   dG     = gcdDivisorGreatest v
>   dd'Dm  : d * d' `Divisor` m
>   dd'Dm  = divisorTowerLemma d d' m dDm d'Dqmd
>   dd'Dn  : d * d' `Divisor` n
>   dd'Dn  = divisorTowerLemma d d' n dDn d'Dqnd
>   dd'Dd  : d * d' `Divisor` d
>   dd'Dd  = dG (d * d') dd'Dm dd'Dn
> %freeze gcdLemma''

> ||| d GCD ((S a) * m) ((S a) * n) => d/(S a) GCD m n
> |||
> ||| The implementation is based on a proof by Tim Richter. We have to show
> |||
> |||   1) d/(S a) is a divisor of m
> |||   2) d/(S a) is a divisor of n
> |||   3) if d' is a divisor of m and n, then d' is a divisor of d/(S a)
> |||
> ||| We know from |quotientDivisorLemma| that
> |||
> |||   a|b, b|c, a|c => (b/a)|(c/a)
> |||
> ||| Thus, we can prove 1) and 2) by applying the lemma to
> |||
> |||   (S a)|d, d|((S a) * m), (S a)|((S a) * m)
> |||
> |||   and
> |||
> |||   (S a)|d, d|((S a) * n), (S a)|((S a) * n)
> |||
> ||| and using |quotientCancellationLemma| to reduce ((S a) * m)/(S a) and
> ||| ((S a) * n)/(S a) to m and n, respectively. Since d is the GCD of
> ||| (S a) * m and (S a) * n and (S a) is trivially a divisor of both, we
> ||| readily have (S a)|d. d|((S a) * m) and d|((S a) * m) also diretly follow
> ||| from d being the GCD of (S a) * m and (S a) * n.
> |||
> ||| In order to prove 3), we again apply |quotientDivisorLemma|, this time to
> |||
> |||   (S a)|((S a) * d'), ((S a) * d')|d, (S a)|d
> |||
> ||| We derive ((S a) * d')|d from the hypothesis d'|m, d'|n by pre-multiplying
> ||| by (S a) (and using |divisorMultLemma1|). This yields
> |||
> |||   ((S a) * d')|((S a) * m), ((S a) * d')|((S a) * n)
> |||
> ||| The result directly follows from d being the GCD of (S a) * m and (S a) * n.
> |||
> gcdDivisorLemma : (d : Nat) -> (m : Nat) -> (n : Nat) -> (a : Nat) ->
>                   GCD d ((S a) * m) ((S a) * n) ->
>                   Sigma ((S a) `Divisor` d) (\ saDd => GCD (quotient d (S a) saDd) m n)

> gcdDivisorLemma d m n a v = MkSigma saDd (MkGCD qDm qDn qG) where
>   dDsam   :  d `Divisor` ((S a) * m)
>   dDsam   =  gcdDivisorFst v
>   saDsam  :  S a `Divisor` ((S a) * m)
>   saDsam  =  Element m Refl
>   dDsan   :  d `Divisor` ((S a) * n)
>   dDsan   =  gcdDivisorSnd v
>   saDsan  :  S a `Divisor` ((S a) * n)
>   saDsan  =  Element n Refl
>   saDd    :  (S a) `Divisor` d
>   saDd    =  gcdDivisorGreatest {d = d} v (S a) saDsam saDsan

>   q       :  Nat
>   q       =  quotient d (S a) saDd
>   preqDm  :  q `Divisor` (quotient ((S a) * m) (S a) saDsam)
>   preqDm  =  quotientDivisorLemma a d ((S a) * m) saDd dDsam saDsam
>   qDm     :  q `Divisor` m
>   qDm     =  replace {x = quotient ((S a) * m) (S a) saDsam}
>                      {y = m}
>                      {P = \ ZUZU => q `Divisor` ZUZU}
>                      (quotientCancellationLemma m a saDsam) preqDm

>   preqDn  :  q `Divisor` (quotient ((S a) * n) (S a) saDsan)
>   preqDn  =  quotientDivisorLemma a d ((S a) * n) saDd dDsan saDsan
>   qDn     :  q `Divisor` n
>   qDn     =  replace {x = quotient ((S a) * n) (S a) saDsan}
>                      {y = n}
>                      {P = \ ZUZU => q `Divisor` ZUZU}
>                      (quotientCancellationLemma n a saDsan) preqDn

>   preqG   :  (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n ->
>              (quotient ((S a) * d') (S a) (Element d' Refl)) `Divisor` q
>   preqG d' d'Dm d'Dn  =  quotientDivisorLemma a ((S a) * d') d (Element d' Refl) sad'Dd saDd
>     where sad'Dsam  :  ((S a) * d') `Divisor` ((S a) * m)
>           sad'Dsam  =  divisorMultLemma1 (S a) (S a) (anyDivisorAny (S a)) m d' d'Dm
>           sad'Dsan  :  ((S a) * d') `Divisor` ((S a) * n)
>           sad'Dsan  =  divisorMultLemma1 (S a) (S a) (anyDivisorAny (S a)) n d' d'Dn
>           sad'Dd    :  ((S a) * d') `Divisor` d
>           sad'Dd    =  gcdDivisorGreatest {d = d} v ((S a) * d') sad'Dsam sad'Dsan
>
>   qG      :  (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` q
>   qG    d' d'Dm d'Dn     =  replace {x = quotient ((S a) * d') (S a) (Element d' Refl)}
>                                     {y = d'}
>                                     {P = \ ZUZU => ZUZU `Divisor` q}
>                                     (quotientCancellationLemma d' a (Element d' Refl)) (preqG d' d'Dm d'Dn)
> %freeze gcdDivisorLemma

> |||
> gcdScaleInvariant : (d : Nat) -> (m : Nat) -> (n : Nat) -> (d' : Nat) -> (a : Nat) ->
>                     GCD d m n -> GCD d' (a * m) (a * n) -> d' = a * d
> gcdScaleInvariant d m n d'  Z    v  v' = s6 where
>   s0   :  Z `Divisor` (Z * m)
>   s0   =  Element m Refl
>   s1   :  Z `Divisor` (Z * n)
>   s1   =  Element n Refl
>   s2   :  Z `Divisor` d'
>   s2   =  gcdDivisorGreatest {d = d'} v' Z s0 s1
>   s3   :  Nat
>   s3   =  getWitness s2
>   s4   :  Z * s3 = d'
>   s4   =  getProof s2
>   s5   :  d' = Z
>   s5   =  replace {x = Z * s3} {y = Z} {P = \ ZUZU => d' = ZUZU} (multZeroLeftZero s3) (sym s4)
>   s6   :  d' = Z * d
>   s6   =  replace {x = Z} {y = Z * d} {P = \ ZUZU => d' = ZUZU} (sym (multZeroLeftZero d)) s5
> gcdScaleInvariant d m n d' (S a) v  v' = s4 where
>   s0   :  (S a) `Divisor` d'
>   s0   =  getWitness (gcdDivisorLemma d' m n a v')
>   s1   :  GCD (quotient d' (S a) s0) m n
>   s1   =  getProof (gcdDivisorLemma d' m n a v')
>   s2   :  quotient d' (S a) s0 = d
>   s2   =  gcdUnique (quotient d' (S a) s0) d s1 v
>   s3   :  (S a) * (quotient d' (S a) s0) = (S a) * d
>   s3   =  multPreservesEq (S a) (S a) (quotient d' (S a) s0) d Refl s2
>   s4   :  d' = (S a) * d
>   s4   =  replace {x = (S a) * (quotient d' (S a) s0)}
>                   {y = d'}
>                   {P = \ ZUZU => ZUZU = (S a) * d}
>                   (quotientLemma d' (S a) s0) s3
> %freeze gcdScaleInvariant

> |||
> gcdScaleInvariantCoro1 : (m : Nat) -> (n : Nat) -> (d : Nat) -> (d1 : Nat) -> (d2 : Nat) ->
>                          (dDm : d `Divisor` m) -> (dDn : d `Divisor` n) ->
>                          GCD d1 (quotient m d dDm) (quotient n d dDn) -> GCD d2 m n -> d2 = d * d1
> gcdScaleInvariantCoro1 m n d d1 d2 dDm dDn v1 v2 =
>   gcdScaleInvariant d1 (quotient m d dDm) (quotient n d dDn) d2 d v1 v2' where
>     v2'  :  GCD d2 (d * (quotient m d dDm)) (d * (quotient n d dDn))
>     v2'  =  replace2 {a = Nat} {a1 = m} {a2 = d * (quotient m d dDm)}
>                      {b = Nat} {b1 = n} {b2 = d * (quotient n d dDn)}
>                      {P = \ ZAZA => \ ZUZU => GCD d2 ZAZA ZUZU}
>                      (sym (quotientLemma m d dDm)) (sym (quotientLemma n d dDn)) v2
> %freeze gcdScaleInvariantCoro1


module Ch04.SubTerm

import Ch03.Arith

||| Propositional type describing that one term is an direct subterm of another one.
data DirectSubTerm : Term -> Term -> Type where
  IsIfTerm : (x : Term) -> DirectSubTerm x (IfThenElse x y z)
  IsThenTerm : (y : Term) -> DirectSubTerm y (IfThenElse x y z)
  IsElseTerm : (z : Term) -> DirectSubTerm z (IfThenElse x y z)
  IsSuccSubTerm : (x : Term) -> DirectSubTerm x (Succ x)
  IsPredSubTerm : (x : Term) -> DirectSubTerm x (Pred x)

||| Propositional type describing that one term is a subterm of another one.
data SubTerm : Term -> Term -> Type where
  IsSubTermOfDirectSubTerm : SubTerm x y -> DirectSubTerm y z -> SubTerm x z
  IsEqual : SubTerm x x


-- My answer to the question in Slack https://functionalprogramming.slack.com/archives/C043A0KTY/p1613365432408100

import Syntax.PreorderReasoning

import Data.Nat

mult_plus_distr : (n, m, p : Nat) -> (n + m) * p = (n * p) + (m * p)
mult_plus_distr 0 m p = Refl
mult_plus_distr (S k) m p =
  let ih = mult_plus_distr k m p
  in rewrite ih in plusAssociative p (mult k p) (mult m p)

mult_assoc : (n, m, p : Nat) -> n * (m * p) = (n * m) * p
mult_assoc Z m p = Refl
mult_assoc (S k) m p = Calc $
  |~ (S k) * (m * p)
  ~~ (m * p) + k * (m * p) ... ( Refl )
  ~~ (m * p) + (k * m) * p ... ( cong ((m * p) +) $ mult_assoc k m p )
  ~~ (m + k * m) * p       ... ( sym $ mult_plus_distr m (k * m) p )


module Lib
import Types
import Data.List

public export
calculateDeltas : (Double,Double) -> (Double, Double) -> Double
calculateDeltas (t0, t1) (x, y) = t0 + t1 * x-y

avg : List Double -> Double
avg [] = 0.0
avg xs = (sum xs) / (cast (length xs))

getmult: List Double -> List Double -> List Double
getmult = zipWith (*)

public export
adjustDeltas : List Double -> List (Double,Double) -> List Double
adjustDeltas deltas examples =
  let xs = map fst examples in getmult deltas  xs

public export
newthetas : (Double, Double) -> Double -> List (Double, Double) ->  (Double, Double)
newthetas thetas alpha examples =
  let deltas = (map (calculateDeltas thetas) examples)
      adjusted = adjustDeltas deltas examples
      t0 = fst thetas
      t1 = snd thetas
      newt0 = t0 - alpha * avg deltas
      newt1 = t1 - alpha * avg adjusted
  in (newt0, newt1)

public export
linearRegression : (Double, Double) -> Double ->List (Double, Double) -> Int -> (Double, Double)
linearRegression coefficients alpha dataset iterations =
 case iterations == 0 of
      True => coefficients
      False => let thetas = newthetas coefficients alpha dataset in linearRegression thetas alpha dataset (iterations -1)


module Proofs.DiscreteOrderTheory

import Common.Util
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory
import Proofs.GroupCancelMisc
import Proofs.OrderTheory
import Proofs.TranslationInvarianceTheory

%default total
%access export

infixl 8 #

lemmaOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) e inv leq -> (a,b,c : s) ->
    a # (b # inv c) `leq` e -> a # b `leq` c
lemmaOrder spec a b c given = rewriteRelation leq o2 o3 o1 where
  o1 : a # (b # inv c) # c `leq` e # c
  o1 = translationInvariantR (invariantOrder spec) (a # (b # inv c)) e c given
  o2 : a # (b # inv c) # c = a # b
  o2 = groupCancelMisc1 (group spec) _ b c
  o3 : e # c = c
  o3 = neutralL (monoid (group spec)) c

strictOrderSeparates : {(+) : Binop s} -> {(<=) : Binrel s} ->
  DiscreteOrderedGroupSpec (+) zero neg (<=) unit -> (a,b : s) ->
    Not (a = b) -> a <= b -> unit + a <= b
strictOrderSeparates spec a b diff given = o4 where
  o1 : a + neg b <= zero
  o1 = groupInverseAndOrder (partiallyOrderedGroup spec) a b given
  o2 : a + neg b = zero -> a = b
  o2 = groupInverseAndEquality (group spec) a b
  o3 : unit + (a + neg b) <= zero
  o3 = discreteOrder spec (a + neg b) (contraposition o2 diff) o1
  o4 : unit + a <= b
  o4 = lemmaOrder (partiallyOrderedGroup spec) unit a b o3

public export
separate : Decidable [s,s] leq => {(+) : Binop s} ->
  DiscreteOrderedGroupSpec (+) zero neg leq unit ->
    (a,b : s) ->
    EitherErased (a `leq` b) (unit + b `leq` a)
separate spec a b =
  case decision {rel = leq} a b of
    Yes prf => Left prf
    No contra =>
      let (baLeq, diff) = orderContra (totalOrder spec) a b contra
          prf = strictOrderSeparates spec b a (diff . sym) baLeq
      in Right prf

public export
separateBis : Decidable [s,s] leq => {(+) : Binop s} ->
  DiscreteOrderedGroupSpec (+) zero neg leq unit ->
    (a,b : s) ->
    EitherErased (a `leq` neg unit + b) (b `leq` a)
separateBis spec a b =
  case separate spec b a of
    Left ba => Right ba
    Right ab => Left (orderInverseL (partiallyOrderedGroup spec) unit b a ab)


module Adithyau.Odds

import Evens

import Intro

data IsOdd : Nat -> Type where
	OneOdd : IsOdd (S Z)
	SSOdd : (k : Nat) -> IsOdd k -> IsOdd (S (S k))

threeOdd : IsOdd 3				{- 3 is odd -}
threeOdd = SSOdd (S Z) OneOdd

twoNotOdd : IsOdd 2 -> Void		{- 2 is not odd -}
twoNotOdd OneOdd impossible
twoNotOdd (SSOdd _ _) impossible

ifOddSEven : (n : Nat) -> (IsOdd n) -> (IsEven (S n))				{- if n is odd, S n is even -}
ifOddSEven (S Z) OneOdd = SSEven 0 ZEven
ifOddSEven (S (S k)) (SSOdd k x) = SSEven (S k) (ifOddSEven k x)

ifEvenSOdd : (n : Nat) -> (IsEven n) -> (IsOdd (S n))				{- if n is even, S n is odd -}
ifEvenSOdd Z ZEven = OneOdd
ifEvenSOdd (S (S k)) (SSEven k x) = SSOdd (S k) (ifEvenSOdd k x)

nOddorEven : (n : Nat) -> Either (IsEven n) (IsOdd n)				{- n is odd or even -}
nOddorEven Z = Left ZEven
nOddorEven (S k) = case (nOddorEven k) of
						(Left l) => Right (ifEvenSOdd k l)
						(Right r) => Left (ifOddSEven k r)

nNotOddandEven : (n : Nat) -> (IsEven n) -> (IsOdd n) -> Void		{- n is not both odd and even -}
nNotOddandEven Z ZEven _ impossible
nNotOddandEven Z (SSEven _ _) _ impossible
nNotOddandEven (S Z) _ OneOdd  impossible
nNotOddandEven (S Z) _ (SSOdd _ _) impossible
nNotOddandEven (S (S k)) ZEven _ impossible
nNotOddandEven (S (S k)) (SSEven k x) OneOdd impossible
nNotOddandEven (S (S k)) (SSEven k x) (SSOdd k y) = nNotOddandEven k x y

isEvenAdd : (n : Nat) -> (m : Nat) -> (IsOdd n) -> (IsOdd m) -> (IsEven (add n m))				{- if n and m are odd, add n m is even -}
isEvenAdd (S Z) k OneOdd x = ifOddSEven k x
isEvenAdd (S (S k)) l (SSOdd k proofk) proofl = SSEven (add k l) (isEvenAdd k l proofk proofl)

isDoubleS : (n : Nat) -> (IsOdd n) -> (m : Nat ** n = S (double m))					{- if n is odd, there exists an m such that n = S (double m) -}
isDoubleS (S Z) OneOdd = (Z ** Refl)
isDoubleS (S (S k)) (SSOdd k x) = step where
	step = case (isDoubleS k x) of
				(m ** pf) => ((S m) ** apNat (\l => S (S l)) k (S (double m)) pf)


module Evens

public export
data IsEven : Nat -> Type where
  ZEven : IsEven 0
  SSEven : (n: Nat) -> IsEven n -> IsEven (S (S n))

twoEven : IsEven 2
twoEven = SSEven 0 ZEven

fourEven : IsEven 4
fourEven = SSEven 2 twoEven

half : (n: Nat) -> IsEven n -> Nat
half Z ZEven = 0
half (S (S k)) (SSEven k x) = S (half k x)

public export
double: Nat -> Nat
double Z = Z
double (S k) = S (S (double k))

doubleEven : (n: Nat) -> IsEven (double n)
doubleEven Z = ZEven
doubleEven (S k) = SSEven (double k) (doubleEven k)

halfDouble: Nat -> Nat
halfDouble n = half (double n) (doubleEven n)

oneOdd: IsEven 1 -> Void
oneOdd ZEven impossible
oneOdd (SSEven _ _) impossible

threeOdd : IsEven 3 -> Void
threeOdd (SSEven (S Z) ZEven) impossible
threeOdd (SSEven (S Z) (SSEven _ _)) impossible

nOrSnEven: (n: Nat) -> Either (IsEven n) (IsEven (S n))
nOrSnEven Z = Left ZEven
nOrSnEven (S k) = case (nOrSnEven k) of
                       (Left l) => Right (SSEven k l)
                       (Right r) => Left r

halfRoof: Nat -> Nat
halfRoof n = case (nOrSnEven n) of
                  (Left nEven) => half n nEven
                  (Right snEven) => half (S n) snEven

nSnNotBothEven: (n: Nat) -> (IsEven n) -> IsEven (S n) -> Void
nSnNotBothEven Z ZEven ZEven impossible
nSnNotBothEven Z ZEven (SSEven _ _) impossible
nSnNotBothEven (S (S k)) (SSEven k x) (SSEven (S k) y) = nSnNotBothEven k x y

notNandSnEven : (n: Nat) -> (IsEven n , IsEven (S n)) -> Void
notNandSnEven n (a, b) = nSnNotBothEven n a b

apNat : (f: Nat -> Nat) -> (n: Nat) -> (m: Nat) -> n = m -> f n = f m
apNat f m m Refl = Refl

byTwo : (n: Nat) -> IsEven n -> (k: Nat ** double k = n)
byTwo Z ZEven = (0 ** Refl)
byTwo (S (S k)) (SSEven k x) = step where
  step = case (byTwo k x) of
            (m ** pf) => ((S m) ** apNat (\l => S (S l)) (double m) k pf)

oneOddFamily : Nat -> Type
oneOddFamily Z = ()
oneOddFamily (S Z) = Void
oneOddFamily (S (S k)) = ()

oneOddProof : (n : Nat) -> IsEven n -> oneOddFamily n
oneOddProof Z ZEven = ()
oneOddProof (S (S k)) (SSEven k x) = ()


-- 自己写的一个一个链表翻转程序和验证程序

{- 翻转函数 -}
myreverse : List a-> List a
myreverse [] = []
myreverse (x::xs) = myreverse xs ++ [x]

{- 引理1 -}
app_nil_r : (l:List a)->(l++[]=l)
app_nil_r [] = Refl
app_nil_r (x::xs) =
    let ind_xs = app_nil_r xs in
        rewrite ind_xs in Refl

{- 引理2：结合性 -}
app_assoc : (l1: List a) -> (l2 : List a) -> (l3:List a) -> ((l1++l2)++l3=l1++(l2++l3))
app_assoc [] l2 l3 = Refl
app_assoc (x::xs) l2 l3 =
    let ind_xs = app_assoc xs l2 l3 in
        rewrite ind_xs in Refl

{- 引理3：分配律 -}
app_distr : (l1:List a)->(l2:List a)->(myreverse (l1++l2)=myreverse l2++myreverse l1)
app_distr [] l2 =
    rewrite app_nil_r (myreverse l2) in Refl
app_distr (x::xs) l2 =
    rewrite app_distr xs l2 in
        rewrite app_assoc (myreverse l2) (myreverse xs) [x] in Refl

{- 定理：链表翻转的函数的逆元是其自身 -}
myreverseSym : (l:List a)->(l=myreverse (myreverse l))
myreverseSym [] = Refl
myreverseSym (x::xs) =
    let ind_xs = myreverseSym xs in
        rewrite app_distr (myreverse xs) [x] in
            rewrite ind_xs in Refl


module Main

import Data.Vect

allLengths : List String -> List Nat
allLengths [] = []
allLengths (w :: ws) = length w :: allLengths ws

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

isEven0 : Nat -> Bool
isEven0 Z = True
isEven0 (S k) = not (isEven0 k)

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

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

fourInts : Vect 4 Int
fourInts = [0,1,2,3]

sixInts : Vect 6 Int
sixInts = [4,5,6,7,8,9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

--total
allLengths1 : Vect l String -> Vect l Nat
allLengths1 [] = []
allLengths1 (w :: ws) = length w :: allLengths1 ws -- length w :: allLengths1 ws

insert  : Ord elem
       => (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
  False => y :: insert x xs
  True => x :: y :: xs

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) =
  let xsSorted = insSort xs
  in (insert x xsSorted)

addVector : Num num => Vect n num -> Vect n num -> Vect n num
addVector [] [] = []
addVector (x :: xs) (y :: ys) = x + y :: addVector xs ys

addMatrix
  : Num n
  => Vect rows (Vect cols n)
  -> Vect rows (Vect cols n)
  -> Vect rows (Vect cols n)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = addVector x y :: addMatrix xs ys

createEmpties : Num num => Vect m (Vect 0 num)
createEmpties {m} = replicate m []

transposeHelper
  : Num num
  => (x : Vect n num)
  -> (xsTrans : Vect n (Vect len num))
  -> Vect n (Vect (S len) num)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat
  : Num num
  => Vect m (Vect n num)
  -> Vect n (Vect m num)
transposeMat [] = createEmpties
transposeMat (x :: xs) =
  let xsTrans = transposeMat xs
  in (transposeHelper x xsTrans)

{-
mulMatrix
  : Num num
  => Vect n (Vect m num)
  -> Vect m (Vect p num)
  -> Vect n (Vect p num)
-}

main : IO ()
main = do
  putStrLn $ show $ allLengths $ words "Hello World! This is nice. I am being an Idris dev."
  putStrLn $ show $ isEven0 100000
  putStrLn $ show $ isEven 100000
  putStrLn $ show $ tenInts
  putStrLn $ show $ insSort [1,8,9,7,5,6,3,2]
  putStrLn $ show $ addMatrix [[1,1], [2,2]] [[2,2], [1,1]]
  putStrLn $ show $ transposeMat [[1,2,3], [4,5,6]]


module Main
import Data.SnocList

|||Abstract Syntax Tree for Integer with addition, subtraction and multiplication
data ASTExpr
    = EIntLit Int
    | EAddition ASTExpr ASTExpr
    | ESubtraction ASTExpr ASTExpr
    | EMultiplication ASTExpr ASTExpr

|||Usng the Num interface to define basic numerical arithmetic
Num (ASTExpr) where
    (+) = EAddition
    (*) = EMultiplication
    fromInteger = EIntLit . fromInteger

|||Using the Neg interface to define operations on numbers which can be negative.
Neg (ASTExpr) where
    negate x = 0 - x
    (-) = ESubtraction

|||Instruction syntax
data Instruction = Push Int | Add | Sub | Mult

|||Compile expression to a list of instruction
total
compile : ASTExpr -> List Instruction
compile (EIntLit a) =  [Push a]
compile (EAddition a b) = compile a ++ compile b ++ [Add]
compile (ESubtraction a b) = compile a ++ compile b ++ [Sub]
compile (EMultiplication a b) = compile a ++ compile b ++ [Mult]

|||Writing the instructions to a file for the stack machine to execute
total
print : Instruction -> String
print (Push a) = "Push " ++ show a
print Add = "Add"
print Sub = "Sub"
print Mult = "Mult"

|||Helper function for printList (tail recursive and linear time by using stringMap)
total
stringMap : (a -> String) -> List a -> String
stringMap f = go Lin
  where go : SnocList String -> List a -> String
        go sx []         = concat (sx <>> Nil)
        go sx (x :: Nil) = go (sx :< f x) Nil
        go sx (x :: xs)  = go (sx :< f x :< "\n") xs

|||Writing the List instructions to a file for the stack machine to execute
total
printList : List Instruction -> String
printList = stringMap print

--Taking a machine configuration to the next one by executing a single step of computations
total
runInstruction : List Int -> Instruction -> Maybe (List Int)
runInstruction xs (Push a) = Just (a :: xs)
runInstruction (x :: y :: xs) Add = Just ((x + y) :: xs)
runInstruction (x :: y :: xs) Sub = Just ((y - x) :: xs)
runInstruction (x :: y :: xs) Mult = Just ((x * y) :: xs)
runInstruction _ _ = Nothing

|||Taking a machine configuration to the next one by executing multiple step of computations
total
runInstructions: List Instruction -> List Int -> Maybe (List Int)
runInstructions xs ys = foldlM runInstruction ys xs

|||Evaluate Abstract Syntax Tree and return value
total
evaluate : ASTExpr -> Int
evaluate (EIntLit a) = a
evaluate (EAddition a b) = evaluate a + evaluate b
evaluate (ESubtraction a b) = evaluate a - evaluate b
evaluate (EMultiplication a b) = evaluate a * evaluate b

|||Universal statement linking the evaluation path via compile followed by RunInstructions
total
runAll: (e : ASTExpr) -> Maybe (List Int)
runAll e = runInstructions(compile(e)) []

|||Universal statement linking the evaluation path via evaluate
total
runAll2: (e : ASTExpr) -> Maybe (List Int)
runAll2 e = Just([evaluate(e)])

-- Testing all functions invidually and against each other

--runInstruction
test_runInstruction_add : runInstruction [1, 2] Add = Just [3]
test_runInstruction_add = Refl

test_runInstruction_sub : runInstruction [2, 1] Sub = Just [-1]
test_runInstruction_sub = Refl

test_runInstruction_mult : runInstruction [10, 2] Mult = Just [20]
test_runInstruction_mult = Refl

--runInstructions
test_runInstructions_add : runInstructions [Push 1, Push 2, Add] [] = Just [3]
test_runInstructions_add = Refl

test_runInstructions_sub : runInstructions [Push 1, Push 2, Sub] [] = Just [-1]
test_runInstructions_sub = Refl

test_runInstructions_mult : runInstructions [Push 10, Push 2, Mult] [] = Just [20]
test_runInstructions_mult = Refl

--runAll
test_runAll_add : runAll (EAddition (EIntLit 2) (EIntLit 3))  = Just [5]
test_runAll_add = Refl

test_runAll_sub : runAll (ESubtraction (EIntLit 2) (EIntLit 3))  = Just [-1]
test_runAll_sub = Refl

test_runAll_mul : runAll (EMultiplication (EIntLit 10) (EIntLit 2))  = Just [20]
test_runAll_mul = Refl

--runAll2
test_runAll2_add : runAll2 (EAddition (EIntLit 2) (EIntLit 3))  = Just [5]
test_runAll2_add = Refl

test_runAll2_sub : runAll2 (ESubtraction (EIntLit 2) (EIntLit 3))  = Just [-1]
test_runAll2_sub = Refl

test_runAll2_mul : runAll2 (EMultiplication (EIntLit 10) (EIntLit 2))  = Just [20]
test_runAll2_mul = Refl

--equality between runAll and runAll2
test_both_RunAlls_add : runAll (EAddition (EIntLit 2) (EIntLit 3)) = runAll2 (EAddition (EIntLit 2) (EIntLit 3))
test_both_RunAlls_add = Refl

test_both_RunAlls_sub : runAll (ESubtraction (EIntLit 2) (EIntLit 3)) = runAll2 (ESubtraction (EIntLit 2) (EIntLit 3))
test_both_RunAlls_sub = Refl

test_both_RunAlls_mul : runAll (EMultiplication (EIntLit 10) (EIntLit 2)) = runAll2 (EMultiplication (EIntLit 10) (EIntLit 2))
test_both_RunAlls_mul = Refl

-- Testing the two evaluation paths
test3_allFunc_add : runInstructions (compile (EAddition (EIntLit 2) (EIntLit 3))) [] === Just [evaluate (EAddition (EIntLit 2) (EIntLit 3))]
test3_allFunc_add = Refl

test3_allFunc_sub : runInstructions (compile (ESubtraction (EIntLit 2) (EIntLit 3))) [] === Just [evaluate (ESubtraction (EIntLit 2) (EIntLit 3))]
test3_allFunc_sub = Refl

test3_allFunc_mul : runInstructions (compile (EMultiplication (EIntLit 10) (EIntLit 2))) [] === Just [evaluate (EMultiplication (EIntLit 10) (EIntLit 2))]
test3_allFunc_mul = Refl

main : IO ()
main = ?hole


module sorting_with_proof

import Data.Vect
import Data.Fin
import permutation
import perm_cons

data Finite : Nat -> Type where
    FinZ : (k : Nat) -> (Finite (S k))
    FinS : (k : Nat) -> (Finite k) -> (Finite (S k))

total
Finite_to_Fin : (k : Nat) -> (Finite k) -> (Fin k)
Finite_to_Fin Z a impossible
Finite_to_Fin (S k) (FinZ k) = FZ
Finite_to_Fin (S k) (FinS k nm) = FS (Finite_to_Fin k nm)

total
Fin_to_Finite : (k : Nat) -> (Fin k) -> (Finite k)
Fin_to_Finite Z a impossible
Fin_to_Finite (S k) FZ = FinZ k
Fin_to_Finite (S k) (FS l) = FinS k (Fin_to_Finite k l)

||| Predecessor function for finite
total
predFinite : (k : Nat) -> (Finite k) -> (Finite k)
predFinite Z a impossible
predFinite (S k) (FinZ k) = FinZ k
predFinite (S (S k)) (FinS (S k) (FinZ k)) = FinZ (S k)
predFinite (S (S k)) (FinS (S k) l) = FinS (S k) (predFinite (S k) l)

||| Predecessor function for fin
total
predFin : (n : Nat) -> (Fin n) -> (Fin n)
predFin n a = Finite_to_Fin n ( predFinite n (Fin_to_Finite n a))

||| Type of proofs that a vector is sorted in increasing order.
||| Note that the predecessor function takes care of the first index
total
SortProof : (n : Nat) -> (NatVect n) -> (Fin n) -> Type
SortProof Z v a impossible
SortProof (S k) v l = LTE (Vect.index (pred l) v) (Vect.index l v)

||| Type of the sorted vectors.
SortedVect : Type
SortedVect = (n : Nat ** (v : (NatVect n)  ** ((k : Fin n) -> (SortProof n v k))))


-- This code is a copy of gist:
-- https://gist.github.com/david-christiansen/3660d5d45e9287c25a5e

module FizzBuzzC

%default total

-- Dependently typed FizzBuzz, constructively

-- A number is fizzy if it is evenly divisible by 3
data Fizzy : Nat -> Type where
  ZeroFizzy : Fizzy 0
  Fizz : Fizzy n -> Fizzy (3 + n)

-- Fizzy is a correct specification of divisibility by 3 - that is, if n is
-- fizzy then there exists some k such that n = 3*k.
fizzyCorrect : (n : Nat) -> Fizzy n -> (k : Nat ** n = 3 * k)
fizzyCorrect Z ZeroFizzy = (Z ** Refl)
fizzyCorrect (S (S (S k))) (Fizz x) =
  let (k' ** ih) = fizzyCorrect k x
  in (S k' ** ?fizzyIsAOK)

-- Basic fizziness lemmas
oneNotFizzy : Not (Fizzy 1)
oneNotFizzy (Fizz f) impossible

twoNotFizzy : Not (Fizzy 2)
twoNotFizzy (Fizz f) impossible

fizzyUp : Not (Fizzy n) -> Not (Fizzy (3 + n))
fizzyUp nope ZeroFizzy impossible
fizzyUp nope (Fizz f) = nope f

-- Fizziness is decidable
decFizzy : (n : Nat) -> Dec (Fizzy n)
decFizzy Z = Yes ZeroFizzy
decFizzy (S Z) = No oneNotFizzy
decFizzy (S (S Z)) = No twoNotFizzy
decFizzy (S (S (S k))) with (decFizzy k)
  decFizzy (S (S (S k))) | (Yes prf) = Yes (Fizz prf)
  decFizzy (S (S (S k))) | (No contra) = No $ fizzyUp contra

-- A number is buzzy if it is evenly divisible by 5
data Buzzy : Nat -> Type where
  ZeroBuzzy : Buzzy 0
  Buzz : Buzzy n -> Buzzy (5 + n)

-- Correctness of buzziness spec elided due to verbosity

oneNotBuzzy : Not (Buzzy 1)
oneNotBuzzy (Buzz b) impossible

twoNotBuzzy : Not (Buzzy 2)
twoNotBuzzy (Buzz b) impossible

threeNotBuzzy : Not (Buzzy 3)
threeNotBuzzy (Buzz b) impossible

fourNotBuzzy : Not (Buzzy 4)
fourNotBuzzy (Buzz b) impossible

buzzOff : Not (Buzzy n) -> Not (Buzzy (5 + n))
buzzOff nope ZeroBuzzy impossible
buzzOff nope (Buzz b) = nope b

decBuzzy : (n : Nat) -> Dec (Buzzy n)
decBuzzy Z = Yes ZeroBuzzy
decBuzzy (S Z) = No oneNotBuzzy
decBuzzy (S (S Z)) = No twoNotBuzzy
decBuzzy (S (S (S Z))) = No threeNotBuzzy
decBuzzy (S (S (S (S Z)))) = No fourNotBuzzy
decBuzzy (S (S (S (S (S k))))) with (decBuzzy k)
  decBuzzy (S (S (S (S (S k))))) | (Yes prf) = Yes (Buzz prf)
  decBuzzy (S (S (S (S (S k))))) | (No way) = No (buzzOff way)

-- A version of Dec that tracks two properties - DoubleDec A B is isomorphic
-- to (Dec A, Dec B). This is just for readability.
data DoubleDec : Type -> Type -> Type where
  Neither : Not a -> Not b -> DoubleDec a b
  First : a -> Not b -> DoubleDec a b
  Second : Not a -> b -> DoubleDec a b
  Both : a -> b -> DoubleDec a b

decFizzBuzz : (n : Nat) -> DoubleDec (Fizzy n) (Buzzy n)
decFizzBuzz n with (decFizzy n, decBuzzy n)
  decFizzBuzz n | (Yes f, Yes b) = Both f b
  decFizzBuzz n | (No nf, Yes b) = Second nf b
  decFizzBuzz n | (Yes f, No nb) = First f nb
  decFizzBuzz n | (No nf, No nb) = Neither nf nb

-- Let's show some fizzing and buzzing. Start with all the nats:
nats : Stream Nat
nats = iterate S Z

-- and the fizzed and buzzed nats
fizzBuzz : Stream (n : Nat ** DoubleDec (Fizzy n) (Buzzy n))
fizzBuzz = map (\n => (n ** (decFizzBuzz n))) (tail nats)

instance Show (n : Nat ** DoubleDec (Fizzy n) (Buzzy n)) where
  show (x ** Neither _ _) = show x
  show (x ** First _ _)   = "Fizz"
  show (x ** Second _ _)  = "Buzz"
  show (x ** Both _ _)    = "FizzBuzz"

-- Take the first 100 numbers' FizzBuzzes, then print them to the screen.
namespace Main
  main : IO ()
  main = sequence_ . map (putStrLn . show) . take 100 $ fizzBuzz

---------- Proofs ----------

FizzBuzzC.fizzyIsAOK = proof
  compute
  intros
  rewrite plusSuccRightSucc k' (plus k' 0)
  rewrite plusSuccRightSucc k' (S (plus k' (plus k' 0)))
  rewrite plusSuccRightSucc k' (plus k' (plus k' 0))
  rewrite ih
  trivial


 module Lecture.GCD

switchLTE : (n: Nat) -> (m: Nat) -> (contra : (LTE n m) -> Void) -> LTE m n
switchLTE Z m contra = void (contra (LTEZero))
switchLTE (S k) Z contra = LTEZero
switchLTE (S k) (S j) contra =
  LTESucc (switchLTE k j previousContra) where
    previousContra = \evidence : (LTE k j) => contra (LTESucc evidence)

EuclidIndAux_rhs_2 : (x : LTE left right) -> Nat
EuclidIndAux_rhs_2 x = ?EuclidIndAux_rhs_2_rhs

gcdAux: (n: Nat) -> (m: Nat) -> (LTE m n) -> Nat
gcdAux n Z LTEZero = n
gcdAux (S right) (S left) (LTESucc x) = EuclidIndAux_rhs_2 x

gcd : Nat -> Nat -> Nat
gcd k j = case isLTE j k of
               (Yes prf) => gcdAux k j prf
               (No contra) => gcdAux j k (switchLTE j k contra)


module UninhabitedRec

import Data.Nat
import Data.List.Elem

ff : Uninhabited (a, b) => Int
ff = 4

callFGood : Int
callFGood = ff {b = (Left 4 = Right 4)} {a = 5 = 5}

------------------

data Lookup : a -> List (a, b) -> Type where
  Here : (y : b) -> Lookup x $ (x, y)::xys
  There : (0 _ : Uninhabited $ x === z) => Lookup z xys -> Lookup z $ (x, y)::xys

fff : (xs : List (Nat, String)) -> (n : Nat) -> (0 _ : Lookup n xs) => String

xxs : List (Nat, String)
xxs = [(1, "one"), (2, "two"), (4, "four")]

lkup1Good : String
lkup1Good = fff xxs 1

lkup2Good : String
lkup2Good = fff xxs 2

lkup3Bad : String
lkup3Bad = fff xxs 3

------------------

data Uniq : Type -> Type

toList : Uniq a -> List a

data Uniq : Type -> Type where
  Nil  : Uniq a
  (::) : (x : a) -> (xs : Uniq a) -> Uninhabited (Elem x $ toList xs) => Uniq a

toList [] = []
toList (x::xs) = x :: toList xs

uniqGood : Uniq Nat
uniqGood = [1, 2, 3]

uniqBad : Uniq Nat
uniqBad = [1, 2, 1]


||| Implementation  of ordering relations for `Fin`ite numbers
module Data.Fin.Order

import Data.Fin
import Data.Fun
import Data.Rel
import Data.Nat
import Data.Nat.Order
import Decidable.Decidable
import Decidable.Order

using (k : Nat)
  data FinLTE : Fin k -> Fin k -> Type where
    FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n

  implementation Preorder (Fin k) FinLTE where
    transitive m n o (FromNatPrf p1) (FromNatPrf p2) =
      FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)
    reflexive n = FromNatPrf (LTEIsReflexive (finToNat n))

  implementation Poset (Fin k) FinLTE where
    antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =
      finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)

  implementation Decidable [Fin k, Fin k] FinLTE where
    decide m n with (decideLTE (finToNat m) (finToNat n))
      decide m n | Yes prf    = Yes (FromNatPrf prf)
      decide m n | No  disprf = No (\ (FromNatPrf prf) => disprf prf)

  implementation Ordered (Fin k) FinLTE where
    order m n =
      either (Left . FromNatPrf)
             (Right . FromNatPrf)
             (order (finToNat m) (finToNat n))


module Edsl
import Data.Vect
import Data.Fin

data Ty = TyInt | TyBool | TyFun Ty Ty
interpTy : Ty -> Type
interpTy TyInt       = Int
interpTy TyBool      = Bool
interpTy (TyFun a t) = interpTy a -> interpTy t

using (G:Vect n Ty)
  data HasType : Fin n -> Vect n Ty -> Ty -> Type where
    Stop : HasType FZ (t :: G) t
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Int) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)     =  ?sdf2
  interp env (Val x)     = x
  interp env (Lam body)  = \x => interp (x :: env) body
  interp env (App f s)   = (interp env f) (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)
  interp env (If x t e)  = if interp env x then interp env t else interp env e


import Data.Vect

total add_vec : Num t =>
          (x : Vect cols t) ->
          (y : Vect cols t) ->
          Vect cols t
add_vec [] [] = []
add_vec (x :: xs) (y :: ys) = (x + y) :: add_vec xs ys

total add : Num t =>
      Vect rows ( Vect cols t ) ->
      Vect rows ( Vect cols t ) ->
      Vect rows ( Vect cols t )
add [] [] = []
add (x :: xs) (y :: ys) = add_vec x y :: add xs ys

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

total transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect k elem)) -> Vect n (Vect (S k) elem)
transposeHelper [] [] = []
transposeHelper (x :: ys) (y :: xs) = (x :: y) :: transposeHelper ys xs

total transpose' : Vect m (Vect n elem) -> Vect n (Vect m elem)
transpose' [] = createEmpties
transpose' (x :: xs) = let xsTrans = transpose' xs in
                          transposeHelper x xsTrans


> module Unique.Predicates -- from an idea by Tim Richter

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

> Unique : Type -> Type
> Unique t = (p : t) -> (q : t) -> p = q

> Unique0 : Type -> Type
> Unique0 = Unique

> Unique1 : {A : Type} -> (A -> Type) -> Type
> Unique1 {A} P = (a : A) -> Unique0 (P a)

> UniqueEq0 : Type -> Type
> UniqueEq0 A = (a1 : A) -> (a2 : A) -> Unique (a1 = a2)

> UniqueEq1 : {A : Type} -> (P : A -> Type) -> Type
> UniqueEq1 {A} P = (a : A) -> UniqueEq0 (P a)

> {- Maybe implement via a type class ?

> class Unique t where
>   unique : (p : t) -> (q : t) -> p = q

> -}