module Lists

%default total

data NatProd : Type where
    Pair : Nat -> Nat -> NatProd

syntax "(" [x] "," [y] ")" = Pair x y

fst : (p : NatProd) -> Nat
fst (Pair x y) = x

snd : (p : NatProd) -> Nat
snd (Pair x y) = y

swap : (p : NatProd) -> NatProd
swap (x, y) = (y, x)

surjective_pairing : (n, m : Nat) -> (n, m) = (fst (n, m), snd(n, m))
surjective_pairing n m = Refl

surjective_pairing_stuck : (p : NatProd) -> p = (fst p, snd p)
surjective_pairing_stuck (Pair k j) = Refl

snd_fst_is_swap : (p : NatProd) -> (snd p, fst p) = swap p
snd_fst_is_swap (Pair k j) = Refl

fst_swap_is_snd : (p : NatProd) -> fst (swap p) = snd p
fst_swap_is_snd (Pair k j) = Refl

data NatList : Type where
    Nil : NatList
    Cons : Nat -> NatList -> NatList

(::) : Nat -> NatList -> NatList
(::) n l = Cons n l

mylist : NatList
mylist = [1, 2, 3]

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

length : (l : NatList) -> Nat
length [] = Z
length (Cons k x) = S (length x)

append : (l1, l2 : NatList) -> NatList
append Nil l2 = l2
append (Cons h t) l2 = h :: append t l2

(++) : NatList -> NatList -> NatList
(++) = append

test_append1 : ([1, 2, 3] ++ [4, 5]) = [1, 2, 3, 4, 5]
test_append1 = Refl

test_append2 : (Nil ++ [4, 5]) = [4, 5]
test_append2 = Refl

test_append3 : [1, 2, 3] ++ [] = [1, 2, 3]
test_append3 = Refl

hd : (default : Nat) -> (l : NatList) -> Nat
hd default Nil = default
hd default (Cons h t) = h

tl : (l : NatList) -> NatList
tl Nil = Nil
tl (Cons h t) = t

test_hd1 : hd 0 [1, 2, 3] = 1
test_hd1 = Refl

test_hd2 : hd 0 [] = 0
test_hd2 = Refl

test_tl : tl [1, 2, 3] = [2, 3]
test_tl = Refl

non_zeros : (l : NatList) -> NatList
non_zeros [] = Nil
non_zeros (Cons Z x) = non_zeros x
non_zeros (Cons k x) = k :: non_zeros x

test_nonzeros : non_zeros [0, 1, 0, 2, 3, 0, 0] = [1, 2, 3]
test_nonzeros = Refl

oddmembers : (l : NatList) -> NatList
oddmembers [] = Nil
oddmembers (Cons k x) =
    if modNatNZ k 2 SIsNotZ == 0
        then oddmembers x
        else k :: oddmembers x

test_oddmembers : oddmembers [0, 1, 0, 2, 3, 0, 0] = [1, 3]
test_oddmembers = Refl

count_oddmembers : (l : NatList) -> Nat
count_oddmembers = length . oddmembers

test_count_oddmembers : count_oddmembers [1, 0, 3, 1, 4, 5] = 4
test_count_oddmembers = Refl

alternate : (l1, l2 : NatList) -> NatList
alternate [] l2 = l2
alternate l1 [] = l1
alternate (Cons k x) (Cons j y) = k :: j :: alternate x y

test_alternate1 : alternate [1, 2, 3] [4, 5, 6] = [1, 4, 2, 5, 3, 6]
test_alternate1 = Refl
test_alternate2 : alternate [1] [4, 5, 6] = [1, 4, 5, 6]
test_alternate2 = Refl
test_alternate3 : alternate [1, 2, 3] [4] = [1, 4, 2, 3]
test_alternate3 = Refl
test_alternate4 : alternate [] [20, 30] = [20, 30]
test_alternate4 = Refl

Bag : Type
Bag = NatList

count : (v : Nat) -> (s : Bag) -> Nat
count v [] = Z
count Z (Cons Z x) = S (count Z x)
count v@(S k) (Cons (S j) x) = count k [j] + count v x
count v (Cons k x) = count v x

test_count : count 1 [1, 2, 3, 1, 4, 1] = 3
test_count = Refl
test_count2 : count 6 [1, 2, 3, 1, 4, 1] = 0
test_count2 = Refl

sum : Bag -> Bag -> Bag
sum = append

test_sum1 : count 1 (sum [1, 2, 3] [1, 4, 1]) = 3
test_sum1 = Refl

add : (v : Nat) -> (s : Bag) -> Bag
add = (::)

test_add1 : count 1 (add 1 [1, 4, 1]) = 3
test_add1 = Refl
test_add2 : count 5 (add 1 [1, 4, 1]) = 0
test_add2 = Refl

member : (v : Nat) -> (s : Bag) -> Bool
member v [] = False
member v (Cons k x) =
    if k == v
        then True
        else member v x

test_member1 : member 1 [1, 4, 1] = True
test_member1 = Refl
test_member2 : member 2 [1, 4, 1] = False
test_member2 = Refl

remove_one : (v : Nat) -> (s : Bag) -> Bag
remove_one v [] = []
remove_one v (Cons k x) =
    if k == v
        then x
        else k :: remove_one v x

test_remove_one1 : count 5 (remove_one 5 [2, 1, 5, 4, 1]) = 0
test_remove_one1 = Refl
test_remove_one2 : count 5 (remove_one 5 [2, 1, 4, 1]) = 0
test_remove_one2 = Refl
test_remove_one3 : count 4 (remove_one 5 [2, 1, 5, 4, 1, 4]) = 2
test_remove_one3 = Refl
test_remove_one4 : count 5 (remove_one 5 [2, 1, 5, 4, 5, 1, 4]) = 1
test_remove_one4 = Refl

remove_all : (v : Nat) -> (s : Bag) -> Bag
remove_all v [] = []
remove_all v (Cons k x) =
    if k == v
        then remove_all v x
        else k :: remove_all v x

test_remove_all1 : count 5 (remove_all 5 [2, 1, 5, 4, 1]) = 0
test_remove_all1 = Refl
test_remove_all2 : count 5 (remove_all 5 [2, 1, 4, 1]) = 0
test_remove_all2 = Refl
test_remove_all3 : count 4 (remove_all 5 [2, 1, 5, 4, 1, 4]) = 2
test_remove_all3 = Refl
test_remove_all4 : count 5 (remove_all 5 [2, 1, 5, 4, 5, 1, 4, 5, 1, 4]) = 0
test_remove_all4 = Refl

subset : (s1 : Bag) -> (s2 : Bag) -> Bool
subset [] s2 = True
subset (Cons k x) s2 =
    let
        contains_elem_of_s1 = member k s2
        s2' = remove_one k s2
    in
        contains_elem_of_s1 && subset x s2'

test_subset1 : subset [1, 2] [2, 1, 4, 1] = True
test_subset1 = Refl

test_subset2 : subset [1, 2, 2] [2, 1, 4, 1] = False
test_subset2 = Refl

add_succ_count : (v : Nat) -> (s : Bag) -> count v (add v s) = S (count v s)
add_succ_count Z s = Refl
add_succ_count (S k) [] = rewrite add_succ_count k [] in Refl
add_succ_count (S k) (Cons j x) = rewrite add_succ_count k [] in Refl

ble_n_Sn : (n : Nat) -> n `lte` (S n) = True
ble_n_Sn Z = Refl
ble_n_Sn (S k) = rewrite ble_n_Sn k in Refl

count_member_nonzero : (s : Bag) -> 1 `lte` count 1 (1 :: s) = True
count_member_nonzero s = Refl

remove_decreases_count : (s : Bag) -> lte (count 0 (remove_one 0 s)) (count 0 s) = True
remove_decreases_count [] = Refl
remove_decreases_count (Cons Z x) = rewrite ble_n_Sn (count 0 x) in Refl
remove_decreases_count (Cons (S k) x) = rewrite remove_decreases_count x in Refl

bag_count_sum : (s1, s2 : Bag) -> count 0 (sum s1 s2) = (count 0 s1) + (count 0 s2)
bag_count_sum [] s2 = Refl
bag_count_sum (Cons Z x) s2 = rewrite bag_count_sum x s2 in Refl
bag_count_sum (Cons (S k) x) s2 = rewrite bag_count_sum x s2 in Refl


module FreeGroup

import Monoid
import Group
import congruence

%access public export

||| The type of free groups generated by elements of a type
data FreeGroup : (typ : Type) -> Type where
    Iden : (typ : Type) -> (FreeGroup typ)
    Incl : typ -> (FreeGroup typ)
    Inv_incl : typ -> (FreeGroup typ)
    (*) : {typ : Type} -> (FreeGroup typ) -> (FreeGroup typ) -> (FreeGroup typ)

{-
data EqFree : {typ : Type} -> (FreeGroup typ) -> (FreeGroup typ) -> Type where
    same : {typ : Type} -> {a : (FreeGroup typ)} -> (EqFree a a)
    inv_eq : {typ : Type} -> {a : typ} -> ( EqFree (Incl a) (Inv_incl a) )
    assoc_eq : {typ : Type} -> (a, b, c : (FreeGroup typ)) -> ( EqFree ((a*b)*c) (a*(b*c)) )

Transport : {typ : Type} -> {P : (FreeGroup typ) -> Type} -> {a, b : (FreeGroup typ)} ->
            (EqFree a b) -> (P a) -> (P b)

Translation : {typ : Type} -> {a, b : (FreeGroup typ)} -> (EqFree a b) -> (a = b)
-}

||| Group axioms
id_eq : {typ : Type} -> (a : (FreeGroup typ)) -> ( a * (Iden typ)= a , (Iden typ) * a = a )
inv_eq : {typ : Type} -> (a : typ) -> ( (Incl a) * (Inv_incl a) = (Iden typ), (Inv_incl a) * (Incl a) = (Iden typ))
assoc_eq : {typ : Type} -> (a, b, c : (FreeGroup typ)) -> ( (a*b)*c  = a*(b*c) )

--total
||| A proof that each element of the free group has an inverse

FreeInverse : (typ : Type) -> (a : (FreeGroup typ)) -> ( b : (FreeGroup typ) ** ((a * b = (Iden typ)) , (b * a = (Iden typ))))
FreeInverse typ (Iden typ) = ((Iden typ) ** (id_eq (Iden typ)))
FreeInverse typ (Incl a) = ((Inv_incl a) ** (inv_eq a))
FreeInverse typ (a * b) = let

    a_inv_pf = FreeInverse typ a
    b_inv_pf = FreeInverse typ b
    a_inv = (fst a_inv_pf)
    b_inv = (fst b_inv_pf)
    a_pf = (snd a_inv_pf)
    b_pf = (snd b_inv_pf)
    pf1 = assoc_eq b b_inv a_inv
    pf2 = congruence (FreeGroup typ) (FreeGroup typ) (b * b_inv) (Iden typ) (\c => (c * a_inv)) (fst b_pf)
    pf3 = (snd (id_eq (a_inv)))
    pf4 = trans pf2 pf3
    pf5 = congruence (FreeGroup typ) (FreeGroup typ) ((b * b_inv) * a_inv) a_inv (\c => (a * c)) pf4
    pf6 = trans pf5 (fst a_pf)
    pf7 = assoc_eq a (b * b_inv) a_inv
    pf8 = assoc_eq a b b_inv
    pf9 = congruence (FreeGroup typ) (FreeGroup typ) ((a * b) * b_inv) (a * (b * b_inv)) (\c => (c * a_inv)) pf8
    pf10 = assoc_eq (a*b) b_inv a_inv
    pf11 = trans (sym pf10) pf9
    pf12 = trans pf11 pf7
    pf13 = trans pf12 pf6

    in
    ((b_inv * a_inv) ** (pf13, ?rhs))

{-
FreeGroup_is_Group : {typ : Type} -> (IsGroup (FreeGroup typ) (*))
FreeGroup_is_Group = ( assoc_eq , ((Iden ** (\b => (id_eq {a = b}))),
                                  ((Iden ** (\b => (id_eq {a = b}))) ** (\b => (?rhs)))))
-}


module Main

import Data.Vect

Matrix :  Nat -> Nat -> Type -> Type
Matrix n m a = Vect n (Vect m a)

empties : Vect m (Vect 0 a)
empties {m = Z} = []
empties {m = (S k)} = [] :: empties

transpose_helper : (row : Vect m a) -> (row_trans : Vect m (Vect k a)) -> Vect m (Vect (S k) a)
transpose_helper [] [] = []
transpose_helper (x :: xs) (y :: ys) = (x :: y) :: transpose_helper xs ys

transpose_vec: Matrix n m a -> Matrix m n a
transpose_vec [] = empties
transpose_vec (row :: rows) = let row_trans = transpose_vec rows in
  transpose_helper row row_trans

mult_vects : Num a => Vect m a -> Vect m a -> a
mult_vects [] [] = 0
mult_vects (x :: xs) (y :: ys) = x * y + mult_vects xs ys

mult_vect_mat : Num a => Vect m a -> Matrix n m a -> Vect n a
mult_vect_mat {n = Z} xs [] = replicate Z 0
mult_vect_mat {n = (S k)} xs (y :: ys) = (mult_vects xs y) :: mult_vect_mat xs ys

mult_mat : Num a => Matrix l m a -> Matrix m k a -> Matrix l k a
mult_mat [] [] = []
mult_mat [] (x :: xs) = []
mult_mat (x :: xs) as = let transposed = transpose_vec as in
                           (mult_vect_mat x transposed) :: mult_mat xs as

testMatrixA : Matrix 4 2 Nat
--testMatrixA = ( 1 :: 2 :: 3 :: Nil) :: ( 10 :: 20 :: 30 :: Nil) :: (7 :: 8 :: 9 :: Nil) :: (2 :: 4 :: 6 :: Nil) :: Nil
testMatrixA = ( 1 :: 2 :: 3 :: Nil) :: ( 10 :: 20 :: 30 :: Nil) :: (7 :: 8 :: 9 :: Nil) :: (2 :: 4 :: 6 :: Nil) :: Nil

testMatrixB : Matrix 3 4 Nat
testMatrixB = ( 1 :: 2 :: 3 :: 4 :: Nil) :: ( 10 :: 20 :: 30 :: 40 :: Nil) :: (22 :: 33 :: 44 :: 55 :: Nil) :: Nil

main : IO ()
main = putStrLn (show (mult_mat testMatrixA testMatrixB))


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

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 (EqNat num1 num2)
checkEqNat Z Z = Just (Same 0)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              (Just eq) => Just (sameS _ _ eq)
checkEqNat2 : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat2 Z Z = Just Refl
checkEqNat2 Z (S k) = Nothing
checkEqNat2 (S k) Z = Nothing
checkEqNat2 (S k) (S j) = case checkEqNat2 k j of
                               Nothing => Nothing
                               Just prf => Just (cong prf)

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


> module Double.Postulates

> import Data.So

> import Double.Predicates

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

* Arithmetic

> |||
> postulate
> plusZeroLeftNeutral : {x : Double} -> 0.0 + x = x

> |||
> postulate
> plusZeroRightNeutral : {x : Double} -> x + 0.0 = x

> |||
> postulate
> multZeroLeftZero : {x : Double} -> 0.0 * x = 0.0

> |||
> postulate
> multZeroRightZero : {x : Double} -> x * 0.0 = 0.0

> |||
> postulate
> minusSelfZero : {x : Double} -> x - x = 0.0

> |||
> postulate
> plusAssociative : (x : Double) -> (y : Double) -> (z : Double) ->
>                   x + (y + z) = (x + y) + z

* |LTE|:

> ||| LTE is reflexive
> postulate
> reflexiveLTE : (x : Double) -> x `LTE` x

> ||| LTE is transitive
> postulate
> transitiveLTE : (x, y, z : Double) -> x `LTE` y -> y `LTE` z -> x `LTE` z

> ||| LTE is monotone w.r.t. addition
> postulate
> monotonePlusLTE : {a, b, c, d : Double} ->
>                   a `LTE` b -> c `LTE` d -> a + c `LTE` b + d

> ||| LTE is monotone w.r.t. multiplication
> postulate
> monotoneMultLTE : {a, b, c, d : Double} ->
>                   a `LTE` b -> c `LTE` d -> a * c `LTE` b * d

> ||| LTE is monotone w.r.t. "subtraction of a const"
> postulate
> monotoneMinusConstLTE : {a, b, c : Double} ->
>                         a `LTE` b -> a - c `LTE` b - c

> ||| LTE is monotone w.r.t. "division by a const"
> postulate
> monotoneDivConstLTE : {a, b, c : Double} ->
>                       a `LTE` b -> Positive c -> a / c `LTE` b / c

> ||| LTE is unique
> postulate
> uniqueLTE : {x, y : Double} -> (p : x `LTE` y) -> (q : x `LTE` y) -> p = q

* |LT|:

> ||| LT is unique
> postulate
> uniqueLT : {x, y : Double} -> (p : x `LT` y) -> (q : x `LT` y) -> p = q

* Non-negative double precision floating point numbers:

> ||| Non-negative |Double|s are closed w.r.t. "subtraction"
> postulate
> minusPreservesNonNegativity : {x, y : Double} ->
>                               NonNegative x -> NonNegative y -> y `LTE` x -> NonNegative (x - y)

> ||| Non-negative |Double|s are closed w.r.t. division
> postulate
> divPreservesNonNegativity : {x, y : Double} ->
>                             NonNegative x -> NonNegative y -> NonNegative (x / y)

* Positive double precision floating point numbers:

> |||
> postulate
> positivePlusAnyPositive : {x, y : Double} ->
>                           Positive x -> NonNegative y -> Positive (x + y)

> ||| Positive |Double|s are closed w.r.t. division
> postulate
> divPreservesPositivity : {x, y : Double} ->
>                          Positive x -> Positive y -> Positive (x / y)

> |||
> postulate
> divPositiveSelfOne : {x : Double} -> Positive x -> x / x = 1.0

> |||
> postulate
> divZeroPositiveZero : {x : Double} -> Positive x -> 0.0 / x = 0.0

* Ord methods:

> |||
> postulate
> gtLT : {x, y : Double} -> So (x > y) -> So (y < x)

> postulate
> notCompareEQ : {x, y : Double} -> Not (So (x == y)) -> Not (EQ = compare x y)


module PLFI.Part1.Induction

-- http://plfa.github.io/Induction/

import PLFI.Part1.Naturals
import public Syntax.PreorderReasoning

%hide Prelude.(+)
%hide Prelude.(*)

{-

Proof by induction

 ------
 P Zero

   P m
---------
P (Suc m)

-}

{-
Our first proof: associativity

(m + n) + p = m + (n + p)

-------------------------------
(Zero + n) + p = Zero + (n + p)

   (m + n) + p = m + (n + p)
---------------------------------
(Suc m + n) + p = suc m + (n + p)
-}

-- export
-- addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
-- addAssoc Zero    n p = Refl
-- addAssoc (Suc m) n p = cong Suc $ addAssoc m n p

export
addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
addAssoc Zero n p = Calc $
  |~ (Zero + n) + p
  ~~ n + p             ... (Refl)
  ~~ Zero + (n + p)    ... (Refl)
addAssoc (Suc m) n p = Calc $
  |~ ((Suc m) + n) + p
  ~~ Suc (m + n) + p    ... (Refl)
  ~~ Suc ((m + n) + p)  ... (Refl)
  ~~ Suc (m + (n + p))  ... (cong Suc (addAssoc m n p))
  ~~ Suc m + (n + p)    ... (Refl)

{-
addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
addAssoc Zero n p = Calc $
  |~ ((Zero + n) + p)
  ~~ (n + p)                ...(cong (+p) addEquation1)
  ~~ (Zero + (n + p))       ...(sym addEquation1)
addAssoc (Suc m) n p = Calc $
  |~ ((Suc m + n) + p)
  ~~ (Suc (m + n) + p)
  ~~ (Suc ((m + n) + p))
  ~~ (Suc (m + (n + p)))
  ~~ (Suc m + (n + p))
-}

{-
Our second proof: commutativity
m + n = n + m
-}

{-
The first lemma
m + zero = m
-}

export
addIdentityL : (n : N) -> Zero + n = n
addIdentityL n = Refl

-- addIdentityR1 : (n : N) -> n + Zero = n
-- addIdentityR1 Zero = Refl
-- addIdentityR1 (Suc m) = cong Suc (addIdentityR1 m)

export
addIdentityR : (n : N) -> n + Zero = n
addIdentityR Zero = Calc $
  |~ Zero + Zero
  ~~ Zero         ... (Refl)
addIdentityR (Suc m) = Calc $
  |~ (Suc m) + Zero
  ~~ Suc (m + Zero) ... (Refl)
  ~~ Suc m          ... (cong Suc (addIdentityR m))

{-
The second lemma
m + suc n = suc (m + n)
-}

export
addSuccL : (m, n : N) -> (Suc m) + n = Suc (m + n)
addSuccL m n = Refl

export
addSucR : (m, n : N) -> m + (Suc n) = Suc (m + n)
addSucR Zero n = Calc $
  |~ Zero + (Suc n)
  ~~ Suc n           ... (Refl)
  ~~ Suc (Zero + n)  ... (Refl)
addSucR (Suc m) n = Calc $
  |~ (Suc m) + (Suc n)
  ~~ Suc (m + Suc n)   ... (Refl)
  ~~ Suc (Suc (m + n)) ... (cong Suc (addSucR m n))
  ~~ Suc ((Suc m) + n) ... (Refl)

{-
The proposition
m + n = n + m
-}

export
addComm : (n, m : N) -> n + m = m + n
addComm Zero    m = sym (addIdentityR m)
addComm (Suc x) m = Calc $
  |~ (Suc x) + m
  ~~ Suc (x + m) ... (Refl)
  ~~ Suc (m + x) ... (cong Suc (addComm x m))
  ~~ m + (Suc x) ... (sym (addSucR m x))

{-
Our first corollary: rearranging
-}

export
addRearrange : (m,n,p,q : N) -> (m + n) + (p + q) = m + (n + p) + q
addRearrange m n p q = Calc $
  |~ (m + n) + (p + q)
  ~~ m + (n + (p + q)) ... (addAssoc m n (p + q))
  ~~ m + ((n + p) + q) ... (cong (m+) (sym (addAssoc n p q)))
  ~~ (m + (n + p)) + q ... (sym (addAssoc m (n+p) q))
  ~~ m + (n + p) + q   ... (Refl)

{-
Associativity with rewrite
addAssocRW : (m + n) + p = m + (n + p)
-}

addAssocWithRewrite : (m,n,p : N) -> (m + n) + p = m + (n + p)
addAssocWithRewrite Zero n p
  = Refl
addAssocWithRewrite (Suc m) n p
  = rewrite (addAssocWithRewrite m n p) in
    Refl

addAssocWithRewriteN : (m,n,p : N) -> (m + n) + p = m + (n + p)
addAssocWithRewriteN m Zero p
  = rewrite (addIdentityR m) in
    Refl
addAssocWithRewriteN m (Suc x) p
  = rewrite (addSucR m x) in
    rewrite (addSucR m (x + p)) in
    rewrite (addAssocWithRewriteN m x p) in
    Refl

addIdentityRWithRewrite : (n : N) -> n + Zero = n
addIdentityRWithRewrite Zero
  = Refl
addIdentityRWithRewrite (Suc m)
  = rewrite (addIdentityRWithRewrite m) in
    Refl

addSucWithRewrite : (m, n : N) -> m + (Suc n) = Suc (m + n)
addSucWithRewrite Zero n
  = Refl
addSucWithRewrite (Suc m) n
  = rewrite (addSucWithRewrite m n) in Refl

addCommWithRewrite : (n, m : N) -> n + m = m + n
addCommWithRewrite Zero m
  = rewrite (addIdentityRWithRewrite m) in
    Refl
addCommWithRewrite (Suc x) m
  = rewrite (addCommWithRewrite x m) in
    rewrite (addSucWithRewrite m x) in
    Refl

-- Exercise (recommended)

-- addAssoc : (m, n, p : N) -> (m + n) + p = m + (n + p)
-- addComm  : (n, m : N)    -> n + m = m + n

swap : (m,n,p : N) -> m + (n + p) = n + (m + p)
swap m n p = Calc $
  |~ m + (n + p)
  ~~ (m + n) + p ... (sym (addAssoc m n p))
  ~~ (n + m) + p ... (cong (+p) (addComm m n))
  ~~ n + (m + p) ... (addAssoc n m p)

-- Exercise (recommended)

multDistribAddR : (m,n,p : N) -> (m + n) * p = m * p + n * p
multDistribAddR Zero n p = Refl
multDistribAddR (Suc m) n p = Calc $
  |~ p + ((m + n) * p)
  ~~ p + ((m * p) + (n * p)) ... (cong (p+) (multDistribAddR m n p))
  ~~ (p + (m * p)) + (n * p) ... (sym (addAssoc p (m * p) (n * p)))

-- Exercise (recommended)

multAssoc : (m,n,p : N) -> (m * n) * p = m * (n * p)
multAssoc Zero n p = Refl
multAssoc (Suc m) n p = Calc $
  |~ (n + (m * n)) * p
  ~~ (n * p) + ((m * n) * p) ... (multDistribAddR n (m * n) p)
  ~~ (n * p) + (m * (n * p)) ... (cong ((n*p)+) (multAssoc m n p))

-- Exercise (practice)

multZeroR : (n : N) -> Zero = n * Zero
multZeroR Zero = Refl
multZeroR (Suc m) = multZeroR m

multOneL : (n : N) -> 1 * n = n
multOneL n = addIdentityR n

multOneR : (n : N) -> n = n * 1
multOneR Zero    = Refl
multOneR (Suc m) = cong Suc (multOneR m)

multDistribAddL : (m,n,p : N) -> p * (m + n) = p * m + p * n
multDistribAddL m n Zero = Refl
multDistribAddL m n (Suc p) = Calc $
  |~ (m + n) + (p * (m + n))
  ~~ (m + n) + (p * m + p * n)     ... (cong (\x => (m+n)+x) (multDistribAddL m n p))
  ~~ ((m + n) + (p * m)) + (p * n) ... (sym (addAssoc (m + n) (p * m) (p * n)))
  ~~ (m + (n + (p * m))) + (p * n) ... (cong (+(p*n)) (addAssoc m n (p * m)))
  ~~ (m + ((p * m) + n)) + (p * n) ... (cong (\x => (m+x)+(p*n)) (addComm n (p * m)))
  ~~ ((m + (p * m)) + n) + (p * n) ... (cong (\x => x+(p*n)) (sym (addAssoc m (p * m) n)))
  ~~ (m + (p * m)) + (n + (p * n)) ... (addAssoc (m + (p * m)) n (p * n))

multComm : (m,n : N) -> m * n = n * m
multComm Zero n = multZeroR n
multComm (Suc m) n = Calc $
  |~ n + (m * n)
  ~~ n + (n * m)        ... (cong (\x => n+x) (multComm m n))
  ~~ (n * 1) + (n * m)  ... (cong (\x => x+(n*m)) (multOneR n))
  ~~ n * (1 + m)        ... (sym (multDistribAddL 1 m n))
  ~~ n * (Suc m)        ... (Refl)

-- -- Exercise (practice)

-- zeroMonus : (n : N) -> Zero -* n = Zero

-- -- Exercise (practice)

-- monusAssoc : (m,n,p : N) -> m -* n -* p = m -* (n + p)

-- -- Exercise (strech)

-- expDistribLOverMult : (m,n,p : N) -> m ^ (n + p) = (m ^ n) * (m ^ p)
-- expDistribOverMult : (m,n,p : N) -> (m * n) ^ p = (m ^ p) * (n ^ p)
-- expAssoc : (m,n,p : N) -> (m ^ n) ^ p = m ^ (n ^ p)

-- -- Exercise (strech)

-- incFrom : (b : Bin) -> from (inc b) = Suc (from b)
-- fromTo  : (b : Bin) -> to (from b) = b
-- toFrom  : (b : Bin) -> (to n) = n


module Specifications.Group

import public Specifications.Monoid

%default total
%access public export

infixl 8 #

||| specification
isInverseL : Binop s -> s -> (s -> s) -> Type
isInverseL (#) e inv = (x : _) -> inv x # x = e

||| specification
isInverseR : Binop s -> s -> (s -> s) -> Type
isInverseR (#) e inv = (x : _) -> x # inv x = e

||| composed specification
data GroupSpec : Binop s -> s -> (s -> s) -> Type where
  MkGroup : MonoidSpec op e -> isInverseL op e inv -> isInverseR op e inv ->
    GroupSpec op e inv

||| forget
monoid : GroupSpec op e _ -> MonoidSpec op e
monoid (MkGroup m _ _) = m

||| forget
inverseL : GroupSpec op e inv -> isInverseL op e inv
inverseL (MkGroup _ l _) = l

||| forget
inverseR : GroupSpec op e inv -> isInverseR op e inv
inverseR (MkGroup _ _ r) = r

||| composed specification
data AbelianGroupSpec : Binop s -> s -> (s -> s) -> Type where
  MkAbelianGroup : GroupSpec op e inv -> isAbelian op ->
    AbelianGroupSpec op e inv

||| forget
group : AbelianGroupSpec op e inv -> GroupSpec op e inv
group (MkAbelianGroup g _) = g

||| forget
abelian : AbelianGroupSpec op _ _ -> isAbelian op
abelian (MkAbelianGroup _ a) = a


module BST

import NatOrder

-- decideOrder x y = ?decideOrder_rhs

-- ordering : Nat -> Nat ->

data BinaryTree = Empty | HasValue Nat BinaryTree BinaryTree

tree1 : BinaryTree
tree1 = HasValue 5 (HasValue 3 Empty Empty) (HasValue 8 Empty (HasValue 10 Empty Empty))

tree2 : BinaryTree
tree2 = ?tree2_ex

total
insert : BinaryTree -> Nat -> BinaryTree
insert Empty n = HasValue n Empty Empty
insert (HasValue k left right) n =
    case decideOrder n k of
        (LessThan n_lt_k) => HasValue k (insert left n) right
        (Equal n_eq_k) => HasValue k left right
        (GreaterThan n_gt_k) => HasValue k left (insert right n)

total
find : BinaryTree -> Nat -> Bool
find Empty n = False
find (HasValue k left right) n =
    case decideOrder n k of
        (LessThan n_lt_k) => find left n
        (Equal n_eq_k) => True
        (GreaterThan n_gt_k) => find right n

-- find (insert tree n) n --> find (insert Empty n) n --> find (HasValue n Empty Empty) n
total
findTheorem : (tree : BinaryTree) -> (n : Nat) -> find (insert tree n) n = True
findTheorem Empty n = ?findTheorem_rhs_1
findTheorem (HasValue k x y) n = ?findTheorem_rhs_2


import Data.Vect

{- Dependent types allow parts of a value's type to depend on that value. Another
 - common example of a dependent type is a dependent tuple or pair, where the
 - type of the second value depends on the first value.

 - A dependent pair is defined as follows:

     data DPair : (a : Type) -> (P : a -> Type) -> Type where
         MkDPair : {P : a -> Type} -> (x : a) -> P x -> DPair a P

 - Unpacking the types above gives a good intuition for dependent types.
 - `DPair` constructs the type of the dependent tuple from a Type for the first
 - value and a function from the first value giving the type of the second.
 - `MkDPair` takes the function constructing the type as an implicit argument,
 - and constructs the pair from the first value and the second value, where the
 - first value `x` has type `a` and the second value has type `P x` -}

vec : DPair Nat (\n => Vect n Int) -- Idris anon. function syntax is `\x => result`
vec = MkDPair 2 [3, 4]

{- Idris has syntactic sugar for dependent pairs, where `vec` above can
 - equivalently be written as follows. Here, a pair of type `(T1 ** T2)`
 - contains values of those types, and T2 can depend on the value of T1. -}

vec2 : (n : Nat ** Vect n Int) -- Vect n Int depends on the value n : Nat
vec2 = (2 ** [3, 4])           -- the first element is the length of the second

{- We can even leave out information in the type *and* in the values, which
 - the compiler can infer. -}

vec3 : (n ** Vect n Int)  -- n must be a Nat
vec3 = (_ ** [3, 4])      -- the first value must be the length of the second


module Basen

import Data.Fin

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

--List Fin to Nat
tonat: (n: Nat) -> List (Fin(n)) -> Nat
tonat n [] = Z
tonat n (x :: xs) = (tonatFin n x)*(power n (length xs)) + (tonat n xs)

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

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

--left strips FZ from lists
strp: List (Fin n) -> List (Fin n)
strp [] = []
strp (x :: xs) = case x of
                      FZ => strp(xs)
                      (FS y) => x::xs

-- Nat to List Fin n (base n representation)
tofin: Nat -> (n: Nat) -> List (Fin n)
tofin Z (S j) = [FZ]
tofin (S k) (S j) = strp(reverse(rem :: reverse(tofin q (S j)))) where
                    rem = tofinNat (snd(Eucl (S k) (S j))) (S j)
                    q = fst(Eucl (S k) (S j))

--adding two Fin n's
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin n x y z = case (tofin ((tonatFin (S n) x)+ (tonatFin (S n) y) + (tonatFin (S n) z)) (S n)) of
                    [l] => (FZ, l)
                    [k, l] => (k,l)

--adding two reversed lists as specified
addfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinl n [] ys = strp(ys)
addfinl n (x :: xs) [] = strp(x::xs)
addfinl n (x :: xs) (y :: ys) = (snd(addfin n FZ x y)::(addfinl n (addfinl n [fst(addfin n FZ x y)] xs) ys))

--adding two lists
addfinlist: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
addfinlist n xs ys = reverse(addfinl n (reverse xs) (reverse ys))

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

--Unused mulfinNat - multiplies two Fin n's
mulfinNat: (n: Nat) -> Fin (n) -> Fin (n) -> (Fin (n), Fin (n))
mulfinNat (S n) x y =  case tofin ((tonatFin (S n) x)*(tonatFin (S n) y)) (S n) of
                    [l] => (FZ, l)
                    [k,l] => (k,l)

--multiply two reversed lists in Fin S n
mulfinl: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinl n xs [] = []
mulfinl n xs (FZ :: ys) = FZ :: (mulfinl n xs ys)
mulfinl n xs ((FS x) :: ys) = addfinl n (mulfinl n xs ((embn n x)::ys)) xs

--multpily two lists
mulfinList: (n: Nat) -> List (Fin (S n)) -> List (Fin (S n)) -> List (Fin (S n))
mulfinList n xs ys = reverse(mulfinl n (reverse xs) (reverse ys))


module Ex7

import Data.List

%default total

data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

area : Shape -> Double
area (Triangle b h) = 0.5 * b * h
area (Rectangle l b) = l * b
area (Circle r) = pi * r * r

Eq Shape where
  (==) (Triangle x y) (Triangle a b) = x == a && y == b
  (==) (Rectangle x y) (Rectangle a b) = x == a && y == b
  (==) (Circle x) (Circle y) = x == y
  (==) _ _  = False

Ord Shape where
  compare x y = compare (area x) (area y)

testShapes : List Shape
testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4, Rectangle 2 7]

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 ty, Neg ty, Integral ty) => Expr ty -> ty
eval (Val num) = num
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

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

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

Abs ty => Abs (Expr ty) where
  abs = Abs

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

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

e0 : Expr Int
e0 = Add (Val 6) (Mul (Val 3) (Val 12))

e1 : Expr Int
e1 = Add (Mul (Val 3) (Val 6)) (Val 12)

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

foobar : Integer
foobar = let x = the (Expr Integer) 6 * 3 + 12 in
             the Integer (cast x)

foobaz : Int
foobaz = let y = the (Expr Int) 1 + 2 * 3 + 4 * 5 in
             the Int (cast y)

Functor Expr where
  -- map : (a -> b) -> Expr a -> Expr b
  map func (Val n) = Val (func n)
  map func (Add x y) = Add (map func x) (map func y)
  map func (Sub x y) = Sub (map func x) (map func y)
  map func (Mul x y) = Mul (map func x) (map func y)
  map func (Div x y) = Div (map func x) (map func y)
  map func (Abs x) = Abs (map func x)

data Vect : (len : Nat) -> (elem : Type) -> Type where
  Nil : Vect Z elem
  (::) : (x : elem) -> Vect len elem -> Vect (S len) elem

Eq elem => Eq (Vect n elem) where
  (==) [] [] = True
  (==) (x :: xs) (y :: ys) = x == y && xs == ys

Foldable (Vect n) where
  -- foldr : (a -> b -> b) -> b -> Vect n a -> b
  foldr func acc [] = acc
  foldr func acc (x :: xs) = func x (foldr func acc xs)


module Sorted
import Data.Vect
import Card

||| Given vector of cards is sorted by value
||| in descending order
public export data Sorted: Vect n Card -> Type where
  SortEmpty :
    Sorted (the (Vect 0 Card) [])
  SortSingle:
    Sorted [x]
  SortMany:
    (x:Card) -> Sorted (y :: ys) -> (cardValue x) `GTE` (cardValue y) -> Sorted(x::y::ys)

--------------------------------------------------------------------------------
-- HeadIs, HeadIsEither

-- Proof that the specified vector has the specified head.
public export data HeadIs : Vect n e -> e -> Type where
    MkHeadIs : HeadIs (x::xs) x

-- Proof that the specified vector has one of the two specified heads.
--
-- NOTE: Could implement this as an `Either (HeadIs xs x) (HeadIs xs y)`,
--       but an explicit formulation feels cleaner.
public export data HeadIsEither : Vect n e -> (x:e) -> (y:e) -> Type where
    HeadIsLeft  : HeadIsEither (x::xs) x y
    HeadIsRight : HeadIsEither (x::xs) y x

export chooseGte: (x: Nat) -> (y:Nat) -> Either (x `GTE` y) (y `GTE` x)
chooseGte Z Z = Left LTEZero
chooseGte Z (S k) = Right LTEZero
chooseGte (S k) Z = Left LTEZero
chooseGte (S k) (S j) = case chooseGte k j of
                             (Left l) => Left (LTESucc l)
                             (Right r) => Right (LTESucc r)

export tailIsSortedToo : (p1 : Sorted (x :: xs)) -> Sorted xs
tailIsSortedToo SortSingle = SortEmpty
tailIsSortedToo (SortMany x SortSingle _) = SortSingle
tailIsSortedToo (SortMany x (SortMany y z w) _) = SortMany y z w

--=======================================================================================================
-- isSorted
--=======================================================================================================
singleNotSorted : (contra : LTE (cardValue y) (cardValue x) -> Void) -> Sorted (x :: (y :: xs)) -> Void
singleNotSorted contra (SortMany x xs p) = contra p

restNotSorted : (contra : Sorted (y :: xs) -> Void) -> Sorted (x :: (y :: xs)) -> Void
restNotSorted contra (SortMany u v p) = contra v

export isSorted: (y: Vect n Card) -> Dec (Sorted y)
isSorted [] = Yes (SortEmpty)
isSorted (x :: []) = Yes SortSingle
isSorted (x :: y :: xs) = case isLTE (cardValue y) (cardValue x) of
                            (Yes prf_single) => (case isSorted (y::xs) of
                                               (Yes prf_rest) => Yes (SortMany x prf_rest prf_single)
                                               (No contra) => No (restNotSorted contra))
                            (No contra) => No (singleNotSorted contra)