module Main

import BSTree

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

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

data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = (evaluate x) + (evaluate y)
evaluate (Sub x y) = (evaluate x) - (evaluate y)
evaluate (Mult x y) = (evaluate x) * (evaluate 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) = case compare x y of
                             LT => Just y
                             EQ => Just x
                             GT => Just x


module BoehmBerarducci

%default total

-- NOTE: Issues with scoped implicits:
-- https://github.com/idris-lang/Idris-dev/issues/2346

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

-- NOTE: Issue #2346 / 1
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

-- NOTE: Issue #2346 / 1
-- test_fromNatQ : (n : Nat) -> fromNatQ (iterated n succQ zeroQ) = n
-- test_fromNatQ (S n) = rewrite test_fromNatQ n in Refl
-- test_fromNatQ Z     = Refl

-- TODO: Unknown issue
-- 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

-- NOTE: Issue #2346 / 1
toListQ : {A : Type} -> List A -> ListQ A
toListQ (a :: aa) = consQ a (toListQ aa)
toListQ []        = nilQ


data Bool = True | False

data Direction = North
               | East
               | South
               | West

turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North

||| Represents shapes
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

%name Shape shape, shape1, shape2

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

-- Recursive type
data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

%name Picture pic, pic1, pic2

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

-- Generic type
data BSTree : Type -> Type where
  Empty : Ord e => BSTree e
  Node : Ord e => (left : BSTree e) -> (val : e) -> (right : BSTree e) -> BSTree e

total insert : e -> BSTree e -> BSTree e
insert x Empty = Node Empty x Empty
insert x (Node left y right) = case compare x y of
                                    LT => Node (insert x left) y right
                                    EQ => Node left y right
                                    GT => Node left y (insert x right)


-- -*- idris-interpreter-flags: ("-p" "contrib") -*-

import Data.ZZ
import Data.Vect

data CountChange : ZZ -> Vect n ZZ -> Type where
     C1  : CountChange 0 k        -- 1 way
     C0a : CountChange (NegS a) k -- 0 ways
     C0b : CountChange a []       -- 0 ways
     CC  : CountChange (a - (head k)) k -> CountChange a (tail k) -> CountChange a k -- x + y ways

count : CountChange x y -> Nat
count C1       = 1
count C0a      = 0
count C0b      = 0
count (CC x y) = count x + count y

cc_2_by_1 : CountChange 2 [1]
cc_2_by_1 = CC (CC C1 C0b) C0b

cc_2_by_2_1 : CountChange 2 [2,1]
cc_2_by_2_1 = CC C1 (CC (CC C1 C0b) C0b)

cc_11_by_50_25_10_5_1 : CountChange 11 [50,25,10,5,1]
cc_11_by_50_25_10_5_1 = ?try_it
{- ex 1.14 'tree', generated by 'C-c-a'
cc_11_by_50_25_10_5_1 = CC
                          C0a
                          (CC
                            C0a
                            (CC
                              (CC
                                C0a
                                (CC
                                  C0a
                                  (CC
                                    C1
                                    C0b
                                  )
                                )
                              )
                              (CC
                                (CC
                                  (CC
                                    C0a
                                    (CC
                                      C1
                                      C0b
                                    )
                                  )
                                  (CC
                                    (CC
                                      (CC
                                        (CC
                                          (CC
                                            (CC
                                              C1
                                              C0b
                                            )
                                            C0b
                                          )
                                          C0b
                                        )
                                        C0b
                                      )
                                      C0b
                                    )
                                    C0b
                                  )
                                )
                                (CC
                                  (CC
                                    (CC
                                      (CC
                                        (CC
                                          (CC
                                            (CC
                                              (CC
                                                (CC
                                                  (CC
                                                    (CC
                                                      C1
                                                      C0b
                                                    )
                                                    C0b
                                                  )
                                                  C0b
                                                )
                                                C0b
                                              )
                                              C0b
                                            )
                                            C0b
                                          )
                                          C0b
                                        )
                                        C0b
                                      )
                                      C0b
                                    )
                                    C0b
                                  )
                                  C0b
                                )
                              )
                            )
                          )
-}


-- exercises in "Type-Driven Development with Idris"
-- chapter 4

import Data.Vect

-- check that all functions are total
%default total

--
-- section 4.1
-- see BSTree.idr
-- see Expr.idr
-- see Shape.idr
--

--
-- section 4.2
-- see Vehicle.idr
--

-- first version, does not output the same error than in the book
-- > vectTake1 3 [1,2,3,4,5,6,7]
-- [1, 2, 3] : Vect 3 Integer
-- > vectTake1 8 [1,2,3,4,5,6,7]
-- (input):1:11:When checking argument prf to function Data.Fin.fromInteger:
--         When using 8 as a literal for a Fin 8
--                 8 is not strictly less than 8
vectTake1 : (q : Fin (S n)) -> Vect n t -> Vect (finToNat q) t
vectTake1 FZ _ = []
vectTake1 (FS x) [] impossible
vectTake1 (FS x) (y :: ys) = y :: vectTake1 x ys

-- second version
-- > vectTake2 3 [1,2,3,4,5,6,7]
-- [1, 2, 3] : Vect 3 Integer
-- > vectTake2 8 [1,2,3,4,5,6,7]
-- (input):1:14:When checking argument xs to constructor Data.Vect.:::
--         Type mismatch between
--                 Vect 0 elem (Type of [])
--         and
--                 Vect (S k) t (Expected type)
--
--         Specifically:
--                 Type mismatch between
--                         0
--                 and
--                         S k
vectTake2 : (q : Nat) -> Vect (q+k) t -> Vect q t
vectTake2 Z _ = []
vectTake2 (S k) (x :: xs) = x :: vectTake2 k xs

sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
                                Nothing => Nothing
                                (Just x) => Just (index x xs + index x ys)

--
-- section 4.3
-- see DataStore.idr
--


module Circuits.Common

import Decidable.Equality

import Data.Nat
import Toolkit.Data.Whole

%default total

public export
data DType = LOGIC | BVECT Whole DType

public export
size : DType -> Nat
size LOGIC = (S Z)
size (BVECT (W (S n) ItIsSucc) type)
  = mult (S n) (size type)

Uninhabited (LOGIC = BVECT n k) where
  uninhabited Refl impossible

export
Show DType where
  show LOGIC = "logic"
  show (BVECT n type) = show type <+> concat ["[", show n, "]"]

export
DecEq DType where
  decEq LOGIC LOGIC = Yes Refl
  decEq LOGIC (BVECT k x) = No absurd

  decEq (BVECT k x) LOGIC = No (negEqSym absurd)
  decEq (BVECT k x) (BVECT j y) with (decEq k j)
    decEq (BVECT k x) (BVECT k y) | (Yes Refl) with (decEq x y)
      decEq (BVECT k x) (BVECT k x) | (Yes Refl) | (Yes Refl)
        = Yes Refl
      decEq (BVECT k x) (BVECT k y) | (Yes Refl) | (No contra)
        = No (\Refl => contra Refl)

    decEq (BVECT k x) (BVECT j y) | (No contra)
      = No (\Refl => contra Refl)

public export
data Usage = USED | FREE

Uninhabited (USED = FREE) where
  uninhabited Refl impossible

export
Show Usage where
  show USED = "Used"
  show FREE = "Free"

export
DecEq Usage where
  decEq USED USED = Yes Refl
  decEq USED FREE = No absurd
  decEq FREE USED = No (negEqSym absurd)
  decEq FREE FREE = Yes Refl

-- [ EOF ]


module Divisors

import ZZ
%access public export
%default total
|||IsDivisibleZ a b can be constucted if b divides a
IsDivisibleZ : ZZ -> ZZ -> Type
IsDivisibleZ a b = (n : ZZ ** a = b * n)

|||1 divides everything
oneDiv : (a : ZZ) -> IsDivisibleZ a 1
oneDiv a = (a ** rewrite sym (multOneLeftNeutralZ a) in Refl)

|||Genetes a proof of (a+b) = d*(n+m) from (a=d*n)and (b=d*m)
distributeProof: (a:ZZ)->(b:ZZ)->(d:ZZ)->
  (n:ZZ)->(m:ZZ)->(a=d*n)->(b=d*m)->((a+b) = d*(n+m))
distributeProof a b d n m pf1 pf2 =
  rewrite  (multDistributesOverPlusRightZ d n m) in
    (trans (the (a+b=(d*n)+b) (v1)) v2) where
      v1 =plusConstantRightZ a (d*n) b pf1
      v2 =plusConstantLeftZ b (d*m) (d*n) pf2

|||The theorem d|a =>d|ac
multDiv:(IsDivisibleZ a d) ->(c:ZZ)->(IsDivisibleZ (a*c) d)
multDiv {d} (n**Refl) c =
  ((n*c)** (rewrite sym (multAssociativeZ d n c) in (Refl)))
|||The theorem d|a =>d|ca
multDivLeft:(IsDivisibleZ a d) ->(c:ZZ)->(IsDivisibleZ (c*a) d)
multDivLeft{a} x c = rewrite (multCommutativeZ c a) in (multDiv x c)

|||The theorem d|a and d|b =>d|(a+b)
plusDiv : (IsDivisibleZ a d)->(IsDivisibleZ b d)->(IsDivisibleZ (a+b) d)
plusDiv {d}{a}{b} (n**prf1) (m**prf2) =
  ((n+m)**(distributeProof a b d n m prf1 prf2))
|||The theorem b|a and c|b =>c|a
transDivide : (IsDivisibleZ a b)->(IsDivisibleZ b c)->(IsDivisibleZ a c)
transDivide {c} (x ** pf1) (y ** pf2) =
  (y*x ** (rewrite  multAssociativeZ c y x in
     (rewrite pf1 in (rewrite pf2 in Refl))))

|||If d divides a and b it divides a linear combination of a and b
linCombDiv:(m:ZZ)->(n:ZZ)->(IsDivisibleZ a d)->(IsDivisibleZ b d)->
   (IsDivisibleZ ((a*m)+(b*n)) d)
linCombDiv m n dDiva dDivb =
  plusDiv (multDiv  dDiva m) (multDiv  dDivb n)

|||The theorem that d|a and d|b implies d |(a+b*(-m)
euclidConservesDivisor:(m:ZZ)->(IsDivisibleZ a d)->(IsDivisibleZ b d)->
  (IsDivisibleZ (a+(b*(-m))) d)
euclidConservesDivisor m dDiva dDivb = plusDiv dDiva (multDiv dDivb (-m) )

|||Any integer divides zero
zzDividesZero:(a:ZZ)->(IsDivisibleZ 0 a )
zzDividesZero a = (0**(sym (multZeroRightZeroZ a)))
|||A type that is occupied iff c is a common factor of a and b
IsCommonFactorZ : (a:ZZ) -> (b:ZZ) -> (c:ZZ) -> Type
IsCommonFactorZ a b c = ((IsDivisibleZ a c),(IsDivisibleZ b c))
|||The theorem that  d is a common factor of a and b implies
|||d is a common factor of b and a
commonfactSym: IsCommonFactorZ a b d ->IsCommonFactorZ b a d
commonfactSym (dDiva, dDivb) = (dDivb,dDiva)

|||The GCD type that is occupied iff d = gcd (a,b).
||| Here GCD is defined as that positive integer such that any common factor
||| of a and b divides it
GCDZ : (a:ZZ) -> (b:ZZ) -> (d:ZZ) -> Type
GCDZ a b d = ((IsPositive d),(IsCommonFactorZ a b d),
  ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c)))
|||Anything divides itself
selfDivide:(a:ZZ)->(IsDivisibleZ a a)
selfDivide a = (1**sym (multOneRightNeutralZ a))

|||Generates the proof that if c is a common factor of a and 0 then c divides a
gcdCondition : (a:ZZ) -> ({c:ZZ}->(IsCommonFactorZ a 0 c)->(IsDivisibleZ a c))
gcdCondition  a {c} (cDiva,cDiv0) = cDiva
|||Proves that the GCD of a and 0 is a
gcdOfZeroAndInteger:(a:ZZ)->IsPositive a ->GCDZ a 0 a
gcdOfZeroAndInteger a pf =
  (pf,((selfDivide a),(zzDividesZero a)),((gcdCondition a)))
|||The theorem, d|a =>d|(-a)
dDividesNegative:(IsDivisibleZ a d)->(IsDivisibleZ  (-a) d)
dDividesNegative{a}{d} (x ** pf) =
  ((-x)**(multNegateRightIsNegateZ a d x pf))
|||The theorem that d|(-a) implies d|a
dDividesNegative2:  (IsDivisibleZ (-a) d)->(IsDivisibleZ  a d)
dDividesNegative2 {a}x = rewrite (sym (doubleNegElim a)) in (dDividesNegative x)

|||The theorem c|b and c|(a+bp) then c|a
cDiva :{p:ZZ} ->(cDIvb :(IsDivisibleZ b c))->
  (cDIvExp:IsDivisibleZ (a+(b*p)) c)->(IsDivisibleZ a c)
cDiva {p}{b}{a}{c} cDivb cDivExp =
  rewrite (sym (addAndSubNeutralZ a (b*p))) in (
    plusDiv cDivExp (dDividesNegative(multDiv cDivb (p))))
|||A helper function for euclidConservesGcd function
genFunctionForGcd :(f:({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c)))->
  (({c:ZZ}->(IsCommonFactorZ b (a+(b*(-m)))  c)->(IsDivisibleZ d c)))
genFunctionForGcd f (cDivb,cDivExp) =
  f((cDiva cDivb cDivExp,cDivb))

|||The theorem, gcd(a,b)=d => gcd (b, a+ b(-m))=d
euclidConservesGcd :(m:ZZ)->(GCDZ a b d)->(GCDZ b  (a+(b*(-m))) d)
euclidConservesGcd m  (posProof, (dDiva,dDivb), f) =
  (posProof,(dDivb,(euclidConservesDivisor m  dDiva dDivb)),genFunctionForGcd f)
|||The theorem that if c and d are positive d|c => (d is less than or equal to c)
posDivPosImpliesLte:(IsDivisibleZ c d)->(IsPositive c)->
  (IsPositive d)->LTEZ d c
posDivPosImpliesLte {d}{c}(x ** pf) cPos dPos =
  posLteMultPosPosEqZ {q=x} d c dPos cPos pf

|||The Theorem that if c and d are positive, d|c and c|d =>(c=d)
posDivAndDivByImpliesEqual: (IsDivisibleZ c d)->(IsDivisibleZ d c)->(IsPositive c)
  ->(IsPositive d) -> (c=d)
posDivAndDivByImpliesEqual x y z x1 =lteAndGteImpliesEqualZ dLtec cLted where
  dLtec =posDivPosImpliesLte x z x1
  cLted =posDivPosImpliesLte y x1 z
|||Gcd of a and b is unique
gcdIsUnique: (GCDZ a b d)-> (GCDZ a b c)->(c=d)
gcdIsUnique {a}{b}{c}{d}(dPos, dCommonFactor,fd) (cPos, cCommonFactor,fc) =
  posDivAndDivByImpliesEqual (fc dCommonFactor) (fd cCommonFactor) cPos dPos
|||A helper function for GcdSym
genFunctionForGcdSym:({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))->
   ({c:ZZ}->(IsCommonFactorZ b a c)->(IsDivisibleZ d c))
genFunctionForGcdSym f x = f (commonfactSym x)

|||A helper function for negatingPreservesGcdLeft
genFunctionForGcdNeg:({c:ZZ}->(IsCommonFactorZ (-a) b c)->(IsDivisibleZ d c))->
   ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))
genFunctionForGcdNeg f (cDiva,cDivb) = f (cDivNega,cDivb) where
  cDivNega = (dDividesNegative cDiva)
|||Proof that gcd (a,b)=gcd(b,a)
gcdSymZ: (GCDZ a b d)->(GCDZ b a d)
gcdSymZ (dPos,(dDiva,dDivb),fd) = (dPos, (dDivb, dDiva), (genFunctionForGcdSym fd))

|||Theorem that gcd(-a,b)=gcd(a,b)
negatingPreservesGcdLeft: (GCDZ (-a) b d)->(GCDZ a b d)
negatingPreservesGcdLeft (dPos,(dDivNega,dDivb),fd) =
    (dPos,(dDiva,dDivb),(genFunctionForGcdNeg fd)) where
      dDiva = dDividesNegative2 dDivNega
|||Theorem that gcd (p, -q) = gcd (p,q)
negatingPreservesGcdRight: (GCDZ p (-q) r)->(GCDZ p q r)
negatingPreservesGcdRight {p}{q} x =
  gcdSymZ{a=q}{b=p} (negatingPreservesGcdLeft (gcdSymZ {a=p}{b=(-q)} x))

|||Theorem that if d|rem , d|b and a = rem+(quot*b) then d|a
euclidConservesDivisorWithProof :{a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->
  (a=rem+(quot*b))->(IsDivisibleZ rem d)->(IsDivisibleZ b d)->(IsDivisibleZ a d)
euclidConservesDivisorWithProof {a}{b}{quot}{rem}equality dDivrem dDivb =
  rewrite equality in (plusDiv dDivrem (multDivLeft dDivb quot))

|||Theorem that a = rem +quot*b implies rem = a + (-quot)*b
auxEqProof:{a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->(a=rem+(quot *b))->
   (rem = (a + (-quot)*b))
auxEqProof {a}{b}{quot}{rem}prf =
  (rewrite (multNegateLeftZ quot b) in (sym (subOnBothSides a rem (quot*b) prf)))

|||A helper function for euclidConservesGcdWithProof
genfunction:(a=rem+(quot*b))->  ({c:ZZ}->(IsCommonFactorZ b rem c)->(IsDivisibleZ d c))->
     ({c:ZZ}->(IsCommonFactorZ a b c)->(IsDivisibleZ d c))
genfunction prf f (dDiva,dDivb) = f(dDivb,dDivrem) where
  dDivrem = euclidConservesDivisorWithProof (auxEqProof prf) dDiva dDivb

|||Proof that if a=rem +quot*b and gcd (b,rem)=d, then gcd(a,b)=d
euclidConservesGcdWithProof: {a:ZZ}->{b:ZZ}->{quot:ZZ}->{rem:ZZ}->
  (a=rem+(quot*b))->(GCDZ b rem d)->(GCDZ a b d)
euclidConservesGcdWithProof {a}{b}{quot}{rem}equality (dPos,(dDivb,dDivrem),fd) =
  (dPos,(dDiva,dDivb),(genfunction equality fd)) where
     dDiva = euclidConservesDivisorWithProof equality dDivrem dDivb


-- Code based on the question in the Idris mailing list

import Data.Vect

%default total

public export
group : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect n (Vect m a)
group Z     _ _  = []
group (S n) m xs = let (l, r) = splitAt m xs in l :: group n m r

public export
group' : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect m (Vect n a)
group' n m xs = group m n $ rewrite multCommutative m n in xs

export
splitAtConcatRev : (n : Nat) -> (xs : Vect (n + m) a) -> {0 l : Vect n a} -> {0 r : Vect m a} -> (0 _ : splitAt n xs = (l, r)) -> l ++ r = xs
splitAtConcatRev Z _ Refl = Refl
splitAtConcatRev (S n) (x::xs) {l} prf with (splitAt n xs) proof sprf
  splitAtConcatRev (S n) (x::xs) {l=x::l} Refl | (l, r) = cong (x::) $ splitAtConcatRev n xs sprf

public export
concat_group_id : (n : Nat) -> (m : Nat) -> (v : Vect (n * m) a) -> concat (group n m v) = v
concat_group_id Z     _ [] = Refl
concat_group_id (S n) m xs with (splitAt m xs) proof prf
  _ | (l, r) = rewrite concat_group_id n m r in splitAtConcatRev m xs prf


module DataVect

import public Data.Fin
import Language.Reflection

%access public export
%default total

infixr 7 :>

data Vec : Nat -> Type -> Type where
  V0   :                 Vec  Z    a
  (:>) : a -> Vec n a -> Vec (S n) a

implementation Eq a => Eq (Vec n a) where
  (==)       V0        V0  = True
  (==) (l :> ls) (r :> rs) = l == r && ls == rs

implementation Show a => Show (Vec n a) where
  show       V0  = "V0"
  show (x :> xs) = show x ++ " :> " ++ show xs

vappend : Vec m a -> Vec n a -> Vec (m + n) a
vappend       V0  ys = ys
vappend (x :> xs) ys = x :> vappend xs ys

vtake : (m : Nat) -> Vec (m + n) a -> Vec m a
vtake  Z          xs  = V0
vtake (S k) (x :> xs) = x :> vtake k xs

vdrop : (n : Nat) -> Vec (n + m) a -> Vec m a
vdrop  Z          xs  =        xs
vdrop (S k) (x :> xs) = vdrop k xs

vlength : Vec n _ -> Nat
vlength {n} _ = n

vchop : (m : Nat) -> Vec (m + n) a -> (Vec m a, Vec n a)
vchop m xs = (vtake m xs, vdrop m xs)
{-
vchop' : (m : Nat) -> Vec (m + n) a -> (Vec m a, Vec n a)
vchop'  Z          xs  = (V0, xs)
vchop' (S k) (x :> xs) = (x :> Prelude.Basics.fst yszs, Prelude.Basics.snd yszs)
  where yszs = vchop' k xs
-}

-- TODO

arity : (n : Nat) -> (a : Type) -> Type
arity  Z    x = x
arity (S n) x = x -> arity n x

-- varity :: Arity n x -> Vec n x -> x
-- varity x       V0  =           x
-- varity f (x :> xs) = varity (f x) xs


module Monoids

%default total

{-
  interface Semigroup ty where
    (<+>) : ty -> ty -> ty

  interface Semigroup ty => Monoid ty where
    neutral : ty
-}

-- lets' define IntS as Monoids under both addition and multiplication

[PlusIntSemi] Semigroup Int where
  (<+>) x y = x + y

[PlusIntMonoid] Monoid Int using PlusIntSemi where
  neutral = 0

[MultIntSemi] Semigroup Int where
  (<+>) x y = x * y

[MultIntMonoid] Monoid Int using MultIntSemi where
  neutral = 1


module pigeonhole

-- a try to prove pegionhole principle

import Data.Fin
import Data.Vect

%access public export
%default total

same_hole : (n : Nat) -> (m : Nat) -> (Vect n (Fin m)) -> Type
same_hole n m v = (p : (Fin n) ** (q : (Fin n) **
                  ( prf : ((p = q) -> Void) ** ( (index p v) = (index q v)))))

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

||| proof that Fin Z is empty
aux_prf_1 : (Fin Z) -> Void
aux_prf_1 q impossible

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

||| the type of proofs that a particular element is in the vector or not
data There_is : (n : Nat) -> (m : Nat) -> (v : Vect n (Fin m)) -> (a : Fin m) -> Type where
    Yes : (k : (Fin n) ** ( (index k v) = a)) -> (There_is n m v a)
    No : ( (k : (Fin n) ** ( (index k v) = a)) -> Void ) -> (There_is n m v a)

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

||| finds the first index with the given entry, or returns that there is no such index

is_there : (n : Nat) -> (m : Nat) -> (a : Fin m) -> (v : Vect n (Fin m)) ->
           (There_is n m v a)

-- for vectors of length zero this is false clearly.
is_there Z m a v = No contra where
    contra : ( (k : (Fin Z) ** ( (index k v) = a)) -> Void )
    contra = aux_prf_1 . fst

-- for vectors of non zero length it  checks if the first element is a.
is_there (S n) m a (x :: v) = case (decEq x a) of

    -- If yes gives it as the proof
    Yes prf => Yes (FZ ** prf)

    -- if not then recursively checks the remaining part.
    No contra => (case (is_there n m a v) of

                      -- If the element is in the remaining part then gives the proof
                      Yes prf1 => (let
                          k = fst prf1
                          prf2 = snd prf1
                          in
                          ( Yes ( (FS k) ** prf2) ) )

                      -- if the element is not in the remaining part recursively
                      -- constructs the contradiction

                      No not_in_v => (No (\k => case  k of
                                                (FZ ** prf3) => (contra prf3) --
                                                ((FS l) ** prf4) => (not_in_v (l ** prf4 ) ))))

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

swapHelper : (m : Nat) -> (a , b, x : (Fin m)) -> (Dec (x = a)) -> (Dec (x = b)) -> (Fin m)
swapHelper m a b x (Yes pf) _ = b
swapHelper m a b x (No con) (Yes pf) = a
swapHelper m a b x (No con1) (No con2) = x

----------------------------------------------------------------------------------------------------------------
||| swaps two element in a vector
swap : (n : Nat) -> (m : Nat) -> (a, b : Fin m) -> (v : Vect n (Fin m)) -> (Vect n (Fin m))
swap Z _ _ _ _ = []
swap (S n) m a b (x :: v) = (swapHelper m a b x (decEq x a) (decEq x b)) :: (swap n m a b v)
{-
    case (decEq x a) of
        Yes prf => b :: (swap n m a b v)
        No prf => case (decEq x b) of
            Yes prf => a :: (swap n m a b v)
            No prf => x :: (swap n m a b v)
-}

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

simple_case : (n : Nat) -> (v : Vect (S n) (Fin n) ) -> (same_hole (S n) n v)
simple_case Z v = void (aux_prf_1 (Vect.index FZ v ))
simple_case (S n) v = ?rhs


module RingExamples

import Ring
import RingProperties
import Group
import Group_property
import ZZ
import ZZUtils
import Monoid

%access public export

ZZAbGrp: IsAbelianGrp ZZ (+)
ZZAbGrp = ((Assoc, (((Pos Z)**PrfZ), (((Pos Z)**PrfZ)**PfInv))), CommutativeZ) where
  Assoc: (l,c,r:ZZ) -> (l+c)+r = l +(c+r)
  Assoc l c r = sym (plusAssociativeZ l c r)
  PrfZ: (a: ZZ) -> (a+(Pos Z) = a, (Pos Z) + a = a)
  PrfZ a = (plusZeroRightNeutralZ a, plusZeroLeftNeutralZ a)
  PfInv: (a: ZZ) -> DPair ZZ (\a_inv => ((a + a_inv = Pos Z), (a_inv + a = Pos Z)))
  PfInv a = MkDPair (negate a) (plusNegateInverseLZ a, plusNegateInverseRZ a)
  CommutativeZ: (a: ZZ) -> (b: ZZ) -> (a + b = b+a)
  CommutativeZ = plusCommutativeZ

ZZAssoc: Associative ZZ (*)
ZZAssoc l c r = sym (multAssociativeZ l c r)

ZZDist: IsDistributive ZZ (+) (*)
ZZDist l c r = (multDistributesOverPlusRightZ l c r, multDistributesOverPlusLeftZ c r l)

ZZMultCommutes: Commutative ZZ (*)
ZZMultCommutes = multCommutativeZ

ZZIsCRing: IsCommRing ZZ (+) (*)
ZZIsCRing = ((ZZAbGrp, (ZZAssoc, ZZDist)), ZZMultCommutes)

ZZCRing: CRing ZZ
ZZCRing = MkCRing ZZ (+) (*) ZZIsCRing


module Ex3

import Data.Vect

%default total

myLength : List a -> Nat
myLength [] = 0
myLength (_ :: xs) = 1 + myLength xs

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

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

myVectMap : (a -> b) -> Vect n a -> Vect n b
myVectMap _ [] = []
myVectMap f (x :: xs) = f x :: myVectMap f xs

transposeMatrix : { n : _ } -> Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMatrix [] = replicate n []
transposeMatrix (x :: xs) = let xsTrans = transposeMatrix xs in
                                zipWith (::) x xsTrans

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

subMatrix : (Neg elem, Num elem) => Vect m (Vect n elem) -> Vect m (Vect n elem) -> Vect m (Vect n elem)
subMatrix [] [] = []
subMatrix (x :: xs) (y :: ys) = zipWith (-) x y :: subMatrix xs ys

multMatrix : Num elem => { m, n, o : _ } -> Vect m (Vect n elem) -> Vect n (Vect o elem) -> Vect m (Vect o elem)
multMatrix xs ys = let ysTrans = transposeMatrix ys in
                       aux xs ysTrans

  where
    dotProduct : { n : _ } -> Vect n elem -> Vect n elem -> elem
    dotProduct [] [] = 0
    dotProduct (x :: xs) (y :: ys) = x * y + dotProduct xs ys

    aux :  {m, n, o : _} -> Vect m (Vect n elem) -> Vect o (Vect n elem) -> Vect m (Vect o elem)
    aux [] _ = []
    aux (x :: xs) ys = map (\y => dotProduct x y) ys :: aux xs ys


module Bltnat

howdy : Nat
howdy = 25

public export
beq_nat : Nat -> Nat -> Bool
beq_nat Z Z = True
beq_nat Z (S k) = False
beq_nat (S k) Z = False
beq_nat (S k) (S j) = beq_nat k j

leb : Nat -> Nat -> Bool
leb Z _ = True
leb (S k) (S j) = leb k j
leb _ _ = False
-- alternate and with better ordering: leb (S k) Z = False

tl1 : leb 2 2 = True
tl1 = Refl
tl2 : leb 2 4 = True
tl2 = Refl
tl3 : leb 2555 1 = False
tl3 = Refl

blt_nat : Nat -> Nat -> Bool
blt_nat k j = case beq_nat k j of
                   False => leb k j
                   True => False

tblt1 : blt_nat 2 2 = False
tblt1 = Refl
tblt2 : blt_nat 2 4 = True
tblt2 = Refl
tblt3 : blt_nat 2342 2 = False
tblt3 = Refl


module Test.Spec

import Specdris.Spec
import Control.Permutation
import Data.Vect

export
specSuite : IO ()
specSuite =
  spec $ do
    describe "circulate" $ do
      it "should work (1/2)" $ do
        show circ `shouldBe` "(01234)"
      it "should work (2/2)" $ do
        sigma circulate [0, 1, 2, 3, 4] `shouldBe` [1, 2, 3, 4, 0]
    describe "isEven" $ do
      it "should work" $ do
        map isEven ps `shouldBe` [False, True]
      it "should work with exp" $ do
        map (isEven . exp 2) ps `shouldBe` [True, True]
    describe "trivial" $ do
      it "should permute a vector" $
        toVector trivial `shouldBe` [0, 3, 2, 1]
      it "work on reversed" $
        toVector reverse `shouldBe` [3, 2, 1, 0]
    describe "cycle precursor" $ do
      it "should give a fixNat function" $
        fixNat trivial 1 `shouldBe` 3
      it "should give a orbit function" $
        finOrbit trivial 1 `shouldBe` [1, 3]
    describe "show" $ do
      it "should pretty-print for n < 10" $ do
        show trivial `shouldBe` "(13)"
    describe "compose" $ do
      it "should compose nicely (1/2)" $ do
        toVector (trivial <+> disjoint) `shouldBe` [2, 3, 0, 1]
      it "should compose nicely (2/2)" $ do
        show (trivial <+> swap) `shouldBe` "(02)(13)"
    describe "invert" $ do
      it "should invert a permutation" $
        inverse trivial `shouldBe` trivial
      it "should satisfy x⁻¹x=e" $
        inverse trivial <+> trivial `shouldBe` neutral
    describe "issue #2" $ do
      it "should hold" $
        neutral <+> circSmall `shouldBe` circSmall

        -- TODO property test: composing disjoint swaps should commute!
        -- Also associativity. or better yet proofs?
  where trivial : Permutation 4
        trivial = pi (FS 0) (FS 2)
        disjoint : Permutation 4
        disjoint = pi (FZ) (FS 1)
        big : Permutation 11
        big = pi (FS 0) (FS 9)
        swap : Permutation 4
        swap = pi FZ (FS 1)
        ps : Vect 2 (Permutation 2)
        ps = enumerateStrict
        circSmall : Permutation 3
        circSmall = circulate
        x : Permutation 3
        x = pi FZ (FS 1)
        circ : Permutation 5
        circ = circulate


module Chapter4
import Data.Vect

data Bool = False | True

-- Enumeration types.  Literally an enum from C.
{-
From wiki:
> An enumerated type can be seen as a degenerate case: a tagged union of unit
> types. It corresponds to a set of nullary constructors and may be implemented
> as a simple tag variable, since it holds no additional data besides the value
> of the tag.
-}
data Direction = North
               | East
               | South
               | West

turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North

-- Union types.  Why are they called union?  This is different
-- from a union in C.
-- From above, we see that this is basically a union of 'product types'.
{-
From wiki:
> The expression of an instance of a product type will be a tuple, and
> is called a "tuple type" of expression. A product of types is a direct
> product of two or more types.
In other words it is an union of structs (which it is).
-}
-- With documentation.  Note that we first have the | separator
-- and right after we have the ||| for documentation.
data Shape = ||| Triangle with base and height
             Triangle Double Double
           | ||| Rectangle with width and height
             Rectangle Double Double
           | ||| Circle with radius.
             Circle Double

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

data Shape2 : Type where
  -- need to use 2 suffix else we get a conflict with above.
  Triangle2 : Double -> Double -> Shape2
  Rectangle2 : Double -> Double -> Shape2
  Circle2 : Double -> Shape2

-- Recursive types
data MyNat = MyZ | MyS MyNat  -- Peano arithmetic <3

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

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 s) = area s
pictureArea (Combine p1 p2) = pictureArea p1 + pictureArea p2
pictureArea (Rotate r p) = pictureArea p  -- pictureArea ?h  will be autocompleted
pictureArea (Translate x y p) = pictureArea p

data Infinite = Forever Infinite  -- this typechecks though!  why?

-- Generic data types
-- These are "templates" in C++ world.  They don't exist in C land, except
-- for maybe arrays/pointers of type T.

data Biggest = NoTriangle | Size Double  -- really this is maybe.

biggestTriangle : Picture -> Biggest
-- would have been nice to introduce the @ syntax before.  I knew it from Haskell.
biggestTriangle (Primitive (t@(Triangle x y))) = Size (area t)
biggestTriangle (Primitive (Rectangle x y)) = NoTriangle
biggestTriangle (Primitive (Circle x)) = NoTriangle
-- Holly carp that is manual!
-- need to use >>=
biggestTriangle (Combine x y) = case biggestTriangle x of
                                     NoTriangle => case biggestY of
                                                        NoTriangle => NoTriangle
                                                        Size size2 => Size size2
                                     Size size => case biggestY of
                                                       NoTriangle => Size size
                                                       Size size2 => Size (max size size2)
                                where
                                    biggestY : Biggest
                                    biggestY = biggestTriangle y
biggestTriangle (Rotate r p) = biggestTriangle p
biggestTriangle (Translate x y p) = biggestTriangle p

--data Maybe type = Nothing | Just type

safeDivide : Double -> Double -> Maybe Double
safeDivide x y = if y /= 0 then Just (x / y)
                           else Nothing

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree tree, tree1

insert : Ord a => a -> Tree a -> Tree a
insert x Empty = Node Empty x Empty
insert x orig@(Node left y right) = case compare x y of
                                    LT => Node (insert x left) y right
                                    EQ => orig  -- now we introduce @ patterns
                                    GT => Node left y (insert x right)

data BSTree : Type -> Type where
  BEmpty : Ord a => BSTree a
  BNode  : Ord a => (left : BSTree a) -> (val : a) -> (right : BSTree a) -> BSTree a

insert2 : a -> BSTree a -> BSTree a
insert2 x BEmpty = BNode BEmpty x BEmpty
insert2 x orig@(BNode left val right) = case compare x val of
                                             LT => BNode (insert2 x left) val right
                                             EQ => orig
                                             GT => BNode left val (insert2 x right)

-- Exercises!
-- Ex1
listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

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

-- Ex3 (classic)
data Expr : Type where
  Val : Int -> Expr
  Add : (t1 : Expr) -> (t2 : Expr) -> Expr
  Sub : (s1 : Expr) -> (s2 : Expr) -> Expr
  Mul : (f1 : Expr) -> (f2 : Expr) -> Expr

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add t1 t2) = evaluate t1 + evaluate t2
evaluate (Sub s1 s2) = evaluate s1 - evaluate s2
evaluate (Mul f1 f2) = evaluate f1 * evaluate f2

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

biggestTriangle2 : Picture -> Maybe Double
biggestTriangle2 (Primitive t@(Triangle x y)) = Just (area t)
biggestTriangle2 (Primitive (Rectangle x y)) = Nothing
biggestTriangle2 (Primitive (Circle x)) = Nothing
biggestTriangle2 (Combine p1 p2) = maxMaybe (biggestTriangle2 p1) (biggestTriangle2 p2)
biggestTriangle2 (Rotate r p) = biggestTriangle2 p
biggestTriangle2 (Translate x y p) = biggestTriangle2 p

-- Dependent types.  Woot!
-- Redefined in ex1
--data PowerSource = Petrol | Pedal

-- How is this type fundamentally different from Maybe a?
--data Vehicle : PowerSource -> Type where
--  Bicycle : Vehicle Pedal
--  Car     : (fuel : Nat) -> Vehicle Petrol
--  Bus     : (fuel : Nat) -> Vehicle Petrol
--
--wheels : Vehicle power -> Nat
--wheels Bicycle = 2
--wheels (Car fuel) = 4
--wheels (Bus fuel) = 4
--
--refuel : Vehicle Petrol -> Vehicle Petrol
--refuel (Car fuel) = Car (fuel + 20)
--refuel (Bus fuel) = Car (fuel + 10)
--refuel Bicycle impossible

data MyWeirdType : Type -> Type where
  A : MyWeirdType (Maybe Int)
  B : Nat -> MyWeirdType Double
  C : Nat -> MyWeirdType (Maybe Double)

myWeirdFunction1 : MyWeirdType Double
myWeirdFunction1 = B 5

myWeirdFunction2 : a -> MyWeirdType a
myWeirdFunction2 x = ?myWeirdFunction2_rhs  -- can this be defined in any way?

-- See Vect.idr

-- Ex1,2
data PowerSource = Pedal | Petrol | Electric
data Vehicle : PowerSource -> Type where
  Bicycle : Vehicle Pedal
  Unicycle : Vehicle Pedal
  Motorcycle : (fuel : Nat) -> Vehicle Petrol
  PetrolCar : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol
  Tram : Vehicle Electric
  ElectricCar : Vehicle Electric
-- Feels like a slightly contrived example...
-- there is power in it in terms of how depending on the PowerSource
-- Vehicle has a different definition (i.e. in terms of fuel).

wheels : Vehicle p -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Motorcycle fuel) = 2
wheels (PetrolCar fuel) = 4
wheels (Bus fuel) = 4

-- Ex 3,4
vectTake : (k : Fin n) -> Vect n a -> Vect (finToNat k) a
vectTake FZ xs = []
--vectTake (FS k') xs = ?vectTake_rhs_2  -- case on xs (it can't be [])
--vectTake (FS k') (x :: xs) = ?vectTake_rhs_1  -- search on ?rhs
vectTake (FS k') (x :: xs) = x :: vectTake k' xs  -- BAM programs that write themselves.

-- Remember, types are proofs so you can freely substitute 'proof'
-- with the word type
data LT : Nat -> Nat -> Type where
  LTZero : Chapter4.LT Z (S n)
  LTSucc : Chapter4.LT a b -> Chapter4.LT a (S b)

-- I like this version since it clearly shows what we need.
-- It is not as easy to workwith though.
vectTake' : LTE k n -> Vect n a -> Vect k a
vectTake' LTEZero xs = []
vectTake' (LTESucc k') (x :: xs) = x :: vectTake' k' xs

-- Ex5
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = map (\i => (Data.Vect.index i xs) + (Data.Vect.index i ys))
                               (integerToFin pos n)

-- Now go to DataStore.idr


module Rationals

--Type for divisibility
data isDivisor : Integer -> Integer -> Type where
  AllDivZ : (m : Integer) -> isDivisor m 0
  OneDivAll : (m : Integer) -> isDivisor 1 m
  MulDiv : (c : Integer) -> isDivisor n m -> isDivisor ((\l => l*c) n) ((\l => l*c) m)

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

isFactorInt : Integer -> Integer -> Type  --Needed for defining Integer division
isFactorInt m n = (k : Integer ** (m * k = n))

divides : (m: Integer) -> (n: Integer) -> (k: Integer ** (m * k = n)) -> Integer
divides m n k = (fst k)

Pair : Type
Pair = (Integer, Integer)

Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat) --Euclidean algorithm implemented by Chinmaya
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)
{-
gcdab : Nat -> Nat -> Nat -- Produces the GCD of two numbers. This will be useful to produce the simplified form of a rational number.
gcdab b Z = b
gcdab a b = gcdab b (snd (Eucl a b))
-}

--Integer implemetation of gcd
gccd : (Integer, Integer) -> Integer
gccd (a, b) = if (isNotZero (toNat b)) then next else a where
  next = gccd (b, toIntegerNat (modNat (toNat a) (toNat b)))

data NotZero : Integer -> Type where --Proof that a number is not zero, needed to construct Q
  OneNotZero : NotZero 1
  NegativeNotZero : ( n: Integer ) -> NotZero n -> NotZero (-n)
  PositiveNotZero : ( m: Integer ) -> LTE 1 (fromIntegerNat m)  -> NotZero m

--Type for equality of two Rationals
data EqRat : Pair -> Pair -> Type where
  IdEq : (m : Pair) -> EqRat m m
  MulEq : (c : Integer) -> EqRat n m -> EqRat ((fst n)*c,(snd n)*c) m

make_rational : (p: Nat) -> (q: Integer) -> NotZero q -> Pair
make_rational p q x = (toIntegerNat(p), q)

InclusionMap : (n : Nat) -> Pair --Includes the naturals in Q
InclusionMap n = make_rational n 1 OneNotZero

AddRationals : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
AddRationals x a y b = ((fst x)*(snd y) + (snd x)*(fst y), (snd x)*(snd y))

MultiplyRationals : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
MultiplyRationals x a y b =((fst x)*(fst y), (snd x)*(snd y))

--Need proof that MultInverse x * x = 1
MultInverse : (x: Pair) -> NotZero (fst x) -> NotZero (snd x) -> Pair
MultInverse x y z = ((snd x), (fst x))

AddInverse : (x: Pair) -> NotZero (snd x) -> Pair
AddInverse x a = (-(fst x), (snd x))

Subtraction : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (snd y) -> Pair
Subtraction x a y b = AddRationals x a (AddInverse y b) b

Division : (x: Pair) -> NotZero (snd x) -> (y: Pair) -> NotZero (fst y) -> NotZero (snd y) -> Pair
Division x a y b c = MultiplyRationals x a (MultInverse y b c) b

--SimplifyRational : (x: Pair) -> NotZero (snd x) -> Pair
--SimplifyRational x a = (divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x))) ___ (fst x), divides (gcdab fromIntegerNat((fst x)) fromIntegerNat((snd x)) __ (snd x))

--To prove that the SimplifyRational works, we can just check if the output is equal to the input
-- To be done
simplifyRational : (x : Pair) -> Pair
simplifyRational (a, b) = (sa, sb) where
  sa = cast {from=Double} {to=Integer} (da / g) where
    da = cast {from=Integer} {to=Double} a
    g = cast {from=Integer} {to=Double} (gccd (a,b))
  sb = cast {from=Double} {to=Integer} (db / g) where
    db = cast {from=Integer} {to=Double} b
    g = cast {from=Integer} {to=Double} (gccd (a,b))

--Above, I will need to supply a proof that the GCD divides the two numbers. Then, the function defined above will produce the rational in simplified form.


-- The Great Theorem Prover Showdown (https://github.com/hwayne/lets-prove-leftpad/)
--
-- Code here is nearly completely copied from @porglezomp's Idris implementation, just for the
-- purpose of self edification.

module LeftPad

import Data.Vect

-- As I am totally new to theorem proving, I hereby write down some confusions about this proof:
--
-- * This implementation seems to sidestep the proof of the post-condition that the suffix does be
--   the original string. Is it still sound?
-- * The use of dependent pair seems redundant?
-- * Is `rewrite` deprecated by the new Elaborator Reflection system?

-- `minus` is saturating subtraction
-- `maximum` has branch `maximum Z m` but not `maximum m Z`
-- The 3rd case:
--     - Goal := maximum (S k) (S n) = (S n - S k) + S k
--     - maximum (S k) (S n) = S (maximum k n)
--     - Goal => S (maximum k n) = (S n - S k) + S k
--     - Induction hypothesis := maximum k n = (n - k) + k
--     - Goal => S ((n - k) + k) = (S n - S k) + S k
--
--     - plusSuccRightSucc l r := S (l + r) = l + S r
--     - plusSuccRightSucc (n - k) k => S ((n - k) + k) = (n - k) + S k
--     - Goal => (n - k) + S k = (S n - S k) + S k
--     - minus (S left) (S right) = minus left right
--     - Goal => trivial

eq_max : (n, k : Nat) -> maximum k n = plus (n `minus` k) k
eq_max n     Z     = rewrite minusZeroRight n in
                     rewrite plusZeroRightNeutral n in
                     Refl
eq_max Z     (S _) = Refl
eq_max (S n) (S k) = rewrite sym $ plusSuccRightSucc (n `minus` k) k in
                     rewrite eq_max n k in
                     Refl

leftPad : (padChar : Char) -> (n : Nat) -> (xs : Vect k Char) -> Vect (maximum k n) Char
leftPad {k} padChar n xs = rewrite eq_max n k
  in
    replicate (n `minus` k) padChar ++ xs


module RemoveElem

import Data.Vect

-- Dependent pair implementation of removeElem for fun
depPRemElem : DecEq a => (value : a) -> (xs : Vect n a) -> (len ** Vect len a)
depPRemElem value [] = (_ ** [])
depPRemElem value (x :: xs) = case decEq value x of
                                   (Yes prf) => (_ ** xs)
                                   (No contra) => (_ ** (x :: (snd $ depPRemElem value xs)))

maryInVector : Elem "Mary" ["Pete", "Bob", "Mary"]
maryInVector = There (There Here)

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

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

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


module Main

pythag : Int -> List (Int, Int, Int)
pythag n = [ (x, y, z) | z <- [1..n], y <- [1..z], x <- [1..y],
                           x*x + y*y == z*z ]

main : IO ()
main = putStrLn (show (pythag 50))


module Main

import Data.Vect

{-
  This actually won't type check.

  Even though `a` is implementing the Decidable Equality interface,
  at some point the recursion might end up calling `removeElem value []`
  which this function is not defined for (since [] is a Vect Z a).

  So there's really no guarantee that the value will appear in the vector,
  and thus it's possible to reach the end of the vector without ever finding it.

  Some options here would be

  1. to consider the case for `[]`, and change the signature to return
     `Maybe (Vect n a)` -- if we reach the empty case, we might as well return
      Nothing.

  2. Return a dependant pair (length ** Vect lenght a) so we don't make an
     assumption on the length

  3. Have a type-level predicate that ensures that the element is in the vector
-}
removeElem__nope : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a
removeElem__nope value (x :: xs) = case decEq value x of
                                  Yes prf => xs
                                  No contr => ?x_removeElem_value_xs

{-
  Let's implement option 3 by defining a specific type that tells us that a
  given element is indeed part of the vector

  Elem is actually already part of Data.Vect, so here it's defined as Elem'
  but we'll use Data.Vect.Elem instead
-}

data Elem' : a -> Vect k a -> Type where
  -- x is the first value of the vector
  Here : Elem' x (x :: xs)

  -- if x is in xs, it's also in y :: xs
  There : (later : Elem' x xs) -> Elem' x (y :: xs)

oneInVector : Elem 1 [1,2,3]
oneInVector = Here

somewhereElseInVector : Elem 1 [2,3,1]
somewhereElseInVector = There (There Here)

notInVector : Elem 1 [3,4]
notInVector = There (There ?notInVector_rhs2)

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

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

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

{-
  Now let's try to make a Letter data type that will only accept being
  constructed with alpha characters
-}

Alphabet : Vect 52 Char
Alphabet = ['a',
           'b',
           'c',
           'd',
           'e',
           'f',
           'g',
           'h',
           'i',
           'j',
           'k',
           'l',
           'm',
           'n',
           'o',
           'p',
           'q',
           'r',
           's',
           't',
           'u',
           'v',
           'w',
           'x',
           'y',
           'z',
           'A',
           'B',
           'C',
           'D',
           'E',
           'F',
           'G',
           'H',
           'I',
           'J',
           'K',
           'L',
           'M',
           'N',
           'O',
           'P',
           'Q',
           'R',
           'S',
           'T',
           'U',
           'V',
           'W',
           'X',
           'Y',
           'Z']

data Letter : Char -> Type where
  MkLetter : (c : Char) -> { auto prf : Elem c Alphabet } -> Letter c


module SplayHeap

import Heap

%default total
%access private

export
data SplayHeap a = E | T (SplayHeap a) a (SplayHeap a)

partition : Ord a => a -> SplayHeap a -> (SplayHeap a, SplayHeap a)
partition pivot E = (E, E)
partition pivot t@(T a x b) =
  if x <= pivot then
    case b of
      E         => (t, E)
      T b1 y b2 =>
        if y <= pivot then
          let (small, big) = partition pivot $ assert_smaller t b2
          in (T (T a x b1) y small, big)
        else
          let (small, big) = partition pivot $ assert_smaller t b1
          in (T a x small, T big y b2)
  else
    case a of
      E         => (E, t)
      T a1 y a2 =>
        if y <= pivot then
          let (small, big) = partition pivot $ assert_smaller t a2
          in (T a1 y small, T big x b)
        else
          let (small, big) = partition pivot $ assert_smaller t a1
          in (small, T (T big y a2) x b)

export
Heap SplayHeap where
  empty = E
  isEmpty E = True
  isEmpty _ = False

  insert x t = let (a, b) = partition x t in T a x b

  merge E t = t
  merge (T a x b) t = let (ta, tb) = partition x t
    in T (assert_total $ merge ta a) x (assert_total $ merge tb b)

  findMin E = idris_crash "empty heap"
  findMin (T E x b) = x
  findMin (T a x b) = findMin a

  deleteMin E = idris_crash "empty heap"
  deleteMin (T E x b) = b
  deleteMin (T (T E x b) y c) = T b y c
  deleteMin (T (T a x b) y c) = T (deleteMin a) x (T b y c)


module Setoid

%default total
%access public export

Reflx: {A : Type} -> (R: A -> A -> Type) -> Type
Reflx {A} R = (x : A) -> R x x

Symm: {A : Type} -> (R: A -> A -> Type) -> Type
Symm {A} R = (x : A) -> (y : A) -> R x y -> R y x

Trans: {A : Type} -> (R: A -> A -> Type) -> Type
Trans {A} R = (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z

data IsEquivalence: {A : Type} -> (R: A -> A -> Type) -> Type where
    EqProof: {A: Type} -> (R: A -> A -> Type) -> Reflx {A} R -> Symm {A} R -> Trans {A} R -> IsEquivalence {A} R

record Setoid where
    constructor MkSetoid
    Carrier: Type
    Equivalence: Carrier -> Carrier -> Type
    isEquivalence: IsEquivalence Equivalence


-- Untyped lambda calculus implemntation in Idris

data Term
  = Var Nat          -- A variable is represented by its de-bruijn index
  | Abs Term         -- An abstraction introduces a new function
  | App Term Term    -- One term applied to another

-- Variables are either free or bound
data VarType
  = Free
  | Bound

-- Turns the type into a function that can be used to determine
-- whether a variable with brujin index 'i' within 'n' abstractions
-- is Free/Bound. ('i' -> 'n' -> Bool)
varPred : VarType -> Nat -> Nat -> Bool
varPred Free  = (>)
varPred Bound = (==)

-- Iterates through the AST of a Term, applying 'f' on
-- variables of type 'ty'.
termMap : VarType -> (Nat -> Nat -> Term) -> Term -> Term
termMap ty f = go 0 where
    -- 'n' represents the number of abstractions the current term is
    go : Nat -> Term -> Term
    go n (Var i) with (varPred ty i n)
        | True       = f n i                    -- If the variable matches the desired type, apply f
        | False      = Var i                    -- Else leave it unchanged
    go n (Abs body)  = Abs $ go (succ n) body   -- Recurse, incrementing n as we will be under another abstraction
    go n (App t1 t2) = App (go n t1) (go n t2)  -- Function application does not introduce an abstraction, so leave n unchanged

-- Apply a function to all of the indices of free variables
mapFreeIndices : (Nat -> Nat) -> Term -> Term
mapFreeIndices f t = termMap Free (const $ Var . f) t

-- Substitute 't1' into 't2' at the top level (replacing variables with index 0)
substitute : Term -> Term -> Term
substitute t1 t2 = termMap Bound (\n => const $ mapFreeIndices (+n) t1) t2

-- Perform a beta reduction (aka function application). First decrement all
-- free variable indices in the body, since function application removes the
-- top level abstraction. Then substitute the function argument into the body.
betaReduce : Term -> Term -> Term
betaReduce body arg = substitute arg $ mapFreeIndices Nat.pred body

-- Perform one reductive step. If no step could be applied, return Nothing
simplify : Term -> Maybe Term
simplify (App (Abs body) arg@(Abs _)) = Just $ betaReduce body arg            -- Use function application if possible
simplify (App f@(Abs _) arg)          = App f <$> simplify arg                -- Simplify the argument, so function application can be used next
simplify (App f arg)                  = flip App arg <$> simplify f           -- Simplify the function, so function application can be used next
simplify t                            = Nothing                               -- No simplification rules apply, so return Nothing

-- Evaluate a term down to it's normal form. This uses strict evaluation.
-- Note that this may not terminate: this a "feature" of untyped lc.
-- Here we keep simplifying until no more simplifying steps are available.
eval : Term -> Term
eval t = maybe t eval $ simplify t


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

> interface DecEq a where
>   decEq : (x : a) -> (y : a) -> Dec (x = y)

> zeroNotSucc : Z = (S k) -> Void
> zeroNotSucc Refl impossible

> recNotEq : (k = j -> Void) -> (S k) = (S j) -> Void

> DecEq Nat where
>   decEq Z Z = Yes Refl
>   decEq Z (S k) = No zeroNotSucc
>   decEq (S k) Z = No ?succNotZero
>   decEq (S k) (S j) with (decEq k j)
>     decEq (S j) (S j) | (Yes Refl) = Yes Refl
>     decEq (S k) (S j) | (No contra) = No ?recNotEqLift

> isElem : DecEq a => (x : a) -> (xs : List a) -> Maybe (Elem x xs)
> isElem x [] = Nothing
> isElem x (y :: xs) with (decEq x y)
>   isElem y (y :: xs) | (Yes Refl) = Just Here
>   isElem x (y :: xs) | (No contra) with (isElem x xs)
>     isElem x (y :: xs) | (No contra) | Nothing = Nothing
>     isElem x (y :: xs) | (No contra) | (Just z) = Just (There z)


module Control.Algebra.Laws

import Control.Algebra

%default total

-- Monoids

||| Inverses are unique.
public export
uniqueInverse : MonoidV ty => (x, y, z : ty) ->
  y <+> x = neutral {ty} -> x <+> z = neutral {ty} -> y = z
uniqueInverse x y z p q =
  rewrite sym $ monoidNeutralIsNeutralL y in
    rewrite sym q in
      rewrite semigroupOpIsAssociative y x z in
  rewrite p in
    rewrite monoidNeutralIsNeutralR z in
      Refl

-- Groups

||| Only identity is self-squaring.
public export
selfSquareId : Group ty => (x : ty) ->
  x <+> x = x -> x = neutral {ty}
selfSquareId x p =
  rewrite sym $ monoidNeutralIsNeutralR x in
    rewrite sym $ groupInverseIsInverseR x in
  rewrite sym $ semigroupOpIsAssociative (inverse x) x x in
    rewrite p in
      Refl

||| Inverse elements commute.
public export
inverseCommute : Group ty => (x, y : ty) ->
  y <+> x = neutral {ty} -> x <+> y = neutral {ty}
inverseCommute x y p = selfSquareId (x <+> y) prop where
  prop : (x <+> y) <+> (x <+> y) = x <+> y
  prop =
    rewrite sym $ semigroupOpIsAssociative x y (x <+> y) in
      rewrite semigroupOpIsAssociative y x y in
    rewrite p in
      rewrite monoidNeutralIsNeutralR y in
        Refl

||| Every element has a right inverse.
public export
groupInverseIsInverseL : Group ty => (x : ty) ->
  x <+> inverse x = neutral {ty}
groupInverseIsInverseL x =
  inverseCommute x (inverse x) (groupInverseIsInverseR x)

||| -(-x) = x
public export
inverseSquaredIsIdentity : Group ty => (x : ty) ->
  inverse (inverse x) = x
inverseSquaredIsIdentity {ty} x =
  uniqueInverse
    (inverse x)
    (inverse $ inverse x)
    x
    (groupInverseIsInverseR $ inverse x)
    (groupInverseIsInverseR x)

||| If every square in a group is identity, the group is commutative.
public export
squareIdCommutative : Group ty => (x, y : ty) ->
  ((a : ty) -> a <+> a = neutral {ty}) ->
  x <+> y = y <+> x
squareIdCommutative x y p =
  uniqueInverse (x <+> y) (x <+> y) (y <+> x) (p (x <+> y)) prop where
    prop : (x <+> y) <+> (y <+> x) = neutral {ty}
    prop =
      rewrite sym $ semigroupOpIsAssociative x y (y <+> x) in
        rewrite semigroupOpIsAssociative y y x in
      rewrite p y in
        rewrite monoidNeutralIsNeutralR x in
          p x

||| -0 = 0
public export
inverseNeutralIsNeutral : Group ty =>
  inverse (neutral {ty}) = neutral {ty}
inverseNeutralIsNeutral {ty} =
  rewrite sym $ cong inverse (groupInverseIsInverseL (neutral {ty})) in
    rewrite monoidNeutralIsNeutralR $ inverse (neutral {ty}) in
      inverseSquaredIsIdentity (neutral {ty})

-- ||| -(x + y) = -y + -x
-- public export
-- inverseOfSum : Group ty => (l, r : ty) ->
--   inverse (l <+> r) = inverse r <+> inverse l
-- inverseOfSum {ty} l r =
--   -- expand
--   rewrite sym $ monoidNeutralIsNeutralR $ inverse $ l <+> r in
--     rewrite sym $ groupInverseIsInverseR r in
--       rewrite sym $ monoidNeutralIsNeutralL $ inverse r in
--         rewrite sym $ groupInverseIsInverseR l in
--   -- shuffle
--   rewrite semigroupOpIsAssociative (inverse r) (inverse l) l in
--     rewrite sym $ semigroupOpIsAssociative (inverse r <+> inverse l) l r in
--       rewrite sym $ semigroupOpIsAssociative (inverse r <+> inverse l) (l <+> r) (inverse $ l <+> r) in
--   -- contract
--   rewrite sym $ monoidNeutralIsNeutralL $ inverse l in
--     rewrite groupInverseIsInverseL $ l <+> r in
--       rewrite sym $ semigroupOpIsAssociative (inverse r <+> (inverse l <+> neutral)) l (inverse l <+> neutral) in
--         rewrite semigroupOpIsAssociative l (inverse l) neutral in
--           rewrite groupInverseIsInverseL l in
--             rewrite monoidNeutralIsNeutralL $ the ty neutral in
--               Refl

||| y = z if x + y = x + z
public export
cancelLeft : Group ty => (x, y, z : ty) ->
  x <+> y = x <+> z -> y = z
cancelLeft x y z p =
  rewrite sym $ monoidNeutralIsNeutralR y in
    rewrite sym $ groupInverseIsInverseR x in
      rewrite sym $ semigroupOpIsAssociative (inverse x) x y in
        rewrite p in
      rewrite semigroupOpIsAssociative (inverse x) x z in
    rewrite groupInverseIsInverseR x in
  monoidNeutralIsNeutralR z

||| y = z if y + x = z + x.
public export
cancelRight : Group ty => (x, y, z : ty) ->
  y <+> x = z <+> x -> y = z
cancelRight x y z p =
  rewrite sym $ monoidNeutralIsNeutralL y in
    rewrite sym $ groupInverseIsInverseL x in
      rewrite semigroupOpIsAssociative y x (inverse x) in
        rewrite p in
      rewrite sym $ semigroupOpIsAssociative z x (inverse x) in
    rewrite groupInverseIsInverseL x in
  monoidNeutralIsNeutralL z

||| ab = 0 -> a = b^-1
public export
neutralProductInverseR : Group ty => (a, b : ty) ->
  a <+> b = neutral {ty} -> a = inverse b
neutralProductInverseR a b prf =
  cancelRight  b a (inverse b) $
    trans prf $ sym $ groupInverseIsInverseR b

||| ab = 0 -> a^-1 = b
public export
neutralProductInverseL : Group ty => (a, b : ty) ->
  a <+> b = neutral {ty} -> inverse a = b
neutralProductInverseL a b prf =
  cancelLeft a (inverse a) b $
    trans (groupInverseIsInverseL a) $ sym prf

||| For any a and b, ax = b and ya = b have solutions.
public export
latinSquareProperty : Group ty => (a, b : ty) ->
  ((x : ty ** a <+> x = b),
    (y : ty ** y <+> a = b))
latinSquareProperty a b =
  ((((inverse a) <+> b) **
    rewrite semigroupOpIsAssociative a (inverse a) b in
      rewrite groupInverseIsInverseL a in
        monoidNeutralIsNeutralR b),
  (b <+> (inverse a) **
    rewrite sym $ semigroupOpIsAssociative b (inverse a) a in
      rewrite groupInverseIsInverseR a in
        monoidNeutralIsNeutralL b))

||| For any a, b, x, the solution to ax = b is unique.
public export
uniqueSolutionR : Group ty => (a, b, x, y : ty) ->
  a <+> x = b -> a <+> y = b -> x = y
uniqueSolutionR a b x y p q = cancelLeft a x y $ trans p (sym q)

||| For any a, b, y, the solution to ya = b is unique.
public export
uniqueSolutionL : Group t => (a, b, x, y : t) ->
  x <+> a = b -> y <+> a = b -> x = y
uniqueSolutionL a b x y p q = cancelRight a x y $ trans p (sym q)

-- ||| -(x + y) = -x + -y
-- public export
-- inverseDistributesOverGroupOp : AbelianGroup ty => (l, r : ty) ->
--   inverse (l <+> r) = inverse l <+> inverse r
-- inverseDistributesOverGroupOp l r =
--   rewrite groupOpIsCommutative (inverse l) (inverse r) in
--     inverseOfSum l r

||| Homomorphism preserves neutral.
public export
homoNeutral : GroupHomomorphism a b =>
  to (neutral {ty=a}) = neutral {ty=b}
homoNeutral =
  selfSquareId (to neutral) $
    trans (sym $ toGroup neutral neutral) $
      cong to $ monoidNeutralIsNeutralL neutral

||| Homomorphism preserves inverses.
public export
homoInverse : GroupHomomorphism a b => (x : a) ->
  the b (to $ inverse x) = the b (inverse $ to x)
homoInverse x =
  cancelRight (to x) (to $ inverse x) (inverse $ to x) $
    trans (sym $ toGroup (inverse x) x) $
      trans (cong to $ groupInverseIsInverseR x) $
        trans homoNeutral $
          sym $ groupInverseIsInverseR (to x)

-- Rings

||| 0x = x
public export
multNeutralAbsorbingL : Ring ty => (r : ty) ->
  neutral {ty} <.> r = neutral {ty}
multNeutralAbsorbingL {ty} r =
  rewrite sym $ monoidNeutralIsNeutralR $ neutral <.> r in
    rewrite sym $ groupInverseIsInverseR $ neutral <.> r in
  rewrite sym $ semigroupOpIsAssociative (inverse $ neutral <.> r) (neutral <.> r) (((inverse $ neutral <.> r) <+> (neutral <.> r)) <.> r) in
    rewrite groupInverseIsInverseR $ neutral <.> r in
  rewrite sym $ ringOpIsDistributiveR neutral neutral r in
    rewrite monoidNeutralIsNeutralR $ the ty neutral in
  groupInverseIsInverseR $ neutral <.> r

||| x0 = 0
public export
multNeutralAbsorbingR : Ring ty => (l : ty) ->
  l <.> neutral {ty} = neutral {ty}
multNeutralAbsorbingR {ty} l =
  rewrite sym $ monoidNeutralIsNeutralL $ l <.> neutral in
    rewrite sym $ groupInverseIsInverseL $ l <.> neutral in
  rewrite semigroupOpIsAssociative (l <.> ((l <.> neutral) <+> (inverse $ l <.> neutral))) (l <.> neutral) (inverse $ l <.> neutral) in
    rewrite groupInverseIsInverseL $ l <.> neutral in
  rewrite sym $ ringOpIsDistributiveL l neutral neutral in
    rewrite monoidNeutralIsNeutralL $ the ty neutral in
  groupInverseIsInverseL $ l <.> neutral

||| (-x)y = -(xy)
public export
multInverseInversesL : Ring ty => (l, r : ty) ->
  inverse l <.> r = inverse (l <.> r)
multInverseInversesL l r =
  rewrite sym $ monoidNeutralIsNeutralR $ inverse l <.> r in
    rewrite sym $ groupInverseIsInverseR $ l <.> r in
      rewrite sym $ semigroupOpIsAssociative (inverse $ l <.> r) (l <.> r) (inverse l <.> r) in
  rewrite sym $ ringOpIsDistributiveR l (inverse l) r in
    rewrite groupInverseIsInverseL l in
  rewrite multNeutralAbsorbingL r in
    monoidNeutralIsNeutralL $ inverse $ l <.> r

||| x(-y) = -(xy)
public export
multInverseInversesR : Ring ty => (l, r : ty) ->
  l <.> inverse r = inverse (l <.> r)
multInverseInversesR l r =
  rewrite sym $ monoidNeutralIsNeutralL $ l <.> (inverse r) in
    rewrite sym $ groupInverseIsInverseL (l <.> r) in
      rewrite semigroupOpIsAssociative (l <.> (inverse r)) (l <.> r) (inverse $ l <.> r) in
  rewrite sym $ ringOpIsDistributiveL l (inverse r) r in
    rewrite groupInverseIsInverseR r in
  rewrite multNeutralAbsorbingR l in
    monoidNeutralIsNeutralR $ inverse $ l <.> r

||| (-x)(-y) = xy
public export
multNegativeByNegativeIsPositive : Ring ty => (l, r : ty) ->
  inverse l <.> inverse r = l <.> r
multNegativeByNegativeIsPositive l r =
    rewrite multInverseInversesR (inverse l) r in
    rewrite sym $ multInverseInversesL (inverse l) r in
    rewrite inverseSquaredIsIdentity l in
    Refl

||| (-1)x = -x
public export
inverseOfUnityR : RingWithUnity ty => (x : ty) ->
  inverse (unity {ty}) <.> x = inverse x
inverseOfUnityR x =
  rewrite multInverseInversesL unity x in
    rewrite unityIsRingIdR x in
      Refl

||| x(-1) = -x
public export
inverseOfUnityL : RingWithUnity ty => (x : ty) ->
  x <.> inverse (unity {ty}) = inverse x
inverseOfUnityL x =
  rewrite multInverseInversesR x unity in
    rewrite unityIsRingIdL x in
      Refl


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

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

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

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

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

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

-}


public export
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

-- Ex 8.1 #1
same_cons : {xs : List a} -> {ys : List a} -> xs = ys -> x :: xs = x :: ys
same_cons prf = cong prf
-- Or alternative:
-- same_cons Refl = Refl

-- Ex 8.1 #2
same_lists : {xs : List a} -> {ys : List a} -> x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

-- Ex 8.1 #3
data ThreeEq : a -> b -> c -> Type where
     CreateThreeEq : ThreeEq z z z

-- Ex 8.1 #4
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS z z z CreateThreeEq = CreateThreeEq


module Data.Fin.Extra

import Data.Fin
import Data.Nat

%default total

||| Proof that an element **n** of Fin **m** , when converted to Nat is smaller than the bound **m**.
export
elemSmallerThanBound : (n : Fin m) -> LT (finToNat n) m
elemSmallerThanBound FZ = LTESucc LTEZero
elemSmallerThanBound (FS x) = LTESucc (elemSmallerThanBound x)

||| Proof that application of finToNat the last element of Fin **S n** gives **n**.
export
finToNatLastIsBound : {n : Nat} -> finToNat (Fin.last {n}) = n
finToNatLastIsBound {n=Z} = Refl
finToNatLastIsBound {n=S k} = rewrite finToNatLastIsBound {n=k} in Refl

||| Proof that an element **n** of Fin **m** , when converted to Nat is smaller than the bound **m**.
export
finToNatWeakenNeutral : {m : Nat} -> {n : Fin m} -> finToNat (weaken n) = finToNat n
finToNatWeakenNeutral {n=FZ} = Refl
finToNatWeakenNeutral {m=S (S _)} {n=FS _} = cong S finToNatWeakenNeutral

-- ||| Proof that it's possible to strengthen a weakened element of Fin **m**.
-- export
-- strengthenWeakenNeutral : {m : Nat} -> (n : Fin m) -> strengthen (weaken n) = Right n
-- strengthenWeakenNeutral {m=S _} FZ = Refl
-- strengthenWeakenNeutral {m=S (S _)} (FS k) = rewrite strengthenWeakenNeutral k in Refl

||| Proof that it's not possible to strengthen the last element of Fin **n**.
export
strengthenLastIsLeft : {n : Nat} -> strengthen (Fin.last {n}) = Left (Fin.last {n})
strengthenLastIsLeft {n=Z} = Refl
strengthenLastIsLeft {n=S k} = rewrite strengthenLastIsLeft {n=k} in Refl

||| Enumerate elements of Fin **n** backwards.
export
invFin : {n : Nat} -> Fin n -> Fin n
invFin FZ = last
invFin {n=S (S _)} (FS k) = weaken (invFin k)

||| Proof that an inverse of a weakened element of Fin **n** is a successive of an inverse of an original element.
export
invWeakenIsSucc : {n : Nat} -> (m : Fin n) -> invFin (weaken m) = FS (invFin m)
invWeakenIsSucc FZ = Refl
invWeakenIsSucc {n=S (S _)} (FS k) = rewrite invWeakenIsSucc k in Refl

||| Proof that double inversion of Fin **n** gives the original.
export
doubleInvFinSame : {n : Nat} -> (m : Fin n) -> invFin (invFin m) = m
doubleInvFinSame {n=S Z} FZ = Refl
doubleInvFinSame {n=S (S k)} FZ = rewrite doubleInvFinSame {n=S k} FZ in Refl
doubleInvFinSame {n=S (S _)} (FS x) = trans (invWeakenIsSucc $ invFin x) (cong FS $ doubleInvFinSame x)

||| Proof that an inverse of the last element of Fin (S **n**) in FZ.
export
invLastIsFZ : {n : Nat} -> invFin (Fin.last {n}) = FZ
invLastIsFZ {n=Z} = Refl
invLastIsFZ {n=S k} = rewrite invLastIsFZ {n=k} in Refl

-- ||| Proof that it's possible to strengthen an inverse of a succesive element of Fin **n**.
-- export
-- strengthenNotLastIsRight : (m : Fin (S n)) -> strengthen (invFin (FS m)) = Right (invFin m)
-- strengthenNotLastIsRight m = strengthenWeakenNeutral (invFin m)
--
||| Either tightens the bound on a Fin or proves that it's the last.
export
strengthen' : {n : Nat} -> (m : Fin (S n)) -> Either (m = Fin.last) (m' : Fin n ** finToNat m = finToNat m')
strengthen' {n = Z} FZ = Left Refl
strengthen' {n = S k} FZ = Right (FZ ** Refl)
strengthen' {n = S k} (FS m) = case strengthen' m of
    Left eq => Left $ cong FS eq
    Right (m' ** eq) => Right (FS m' ** cong S eq)

||| A view of Nat as a quotient of some number and a finite remainder.
public export
data FractionView : (n : Nat) -> (d : Nat) -> Type where
    Fraction : (n : Nat) -> (d : Nat) -> {auto ok: GT d Z} ->
                (q : Nat) -> (r : Fin d) ->
                q * d + finToNat r = n -> FractionView n d

||| Converts Nat to the fractional view with a non-zero divisor.
export
divMod : (n, d : Nat) -> {auto ok: GT d Z} -> FractionView n d
divMod Z (S d) = Fraction Z (S d) Z FZ Refl
divMod {ok=_} (S n) (S d) =
    let Fraction {ok=ok} n (S d) q r eq = divMod n (S d) in
    case strengthen' r of
        Left eq' => Fraction {ok=ok} (S n) (S d) (S q) FZ $
            rewrite sym eq in
                rewrite trans (cong finToNat eq') finToNatLastIsBound in
                    cong S $ trans
                        (plusZeroRightNeutral (d + q * S d))
                        (plusCommutative d (q * S d))
        Right (r' ** eq') => Fraction {ok=ok} (S n) (S d) q (FS r') $
            rewrite sym $ plusSuccRightSucc (q * S d) (finToNat r') in
                cong S $ trans (sym $ cong (plus (q * S d)) eq') eq


-- Matrix.idr
--
-- Matrix arithmetics with dependent types

module Matrix

import Data.Vect

-- matrix addition
addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)

-- matrix multiplication
multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)

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

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

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


-- tryIndex.idr
--
-- Demonstrates Fin type for indexing Vect
--

import Data.Vect

||| Returns the element at given index or Nothing if out-of-bounds
tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         (Just idx) => Just (index idx xs)


module Lists

%access public export
%default total

--proof that something is an element of the list
total
isElementOfList : (typ : Type) -> (ls : List typ) -> (a : typ) -> Type
isElementOfList typ ls a = (n : Nat ** (fromMaybe (index' n ls) = a))

--proof that right addition preserves equality (somehow cong was messing up)
total
addl: (x: Type) -> (z: List x) -> (l = y) -> (l ++ z = y ++ z)
addl x z Refl = Refl

-- Proof that the auxiliary reverseOnto used to define rev behaves the way it should (semi-pseudo-contravariantly as I choose to call it)
total
revontoeq: (x: Type) -> (y: List x) -> (l: List x) -> ((reverseOnto y l)  = ((reverseOnto [] l) ++ y))
revontoeq x y [] = Refl
revontoeq x [] (z :: xs) = sym (appendNilRightNeutral (reverseOnto [] (z::xs)))
revontoeq x (y :: ys) (z :: xs) = trans (trans (revontoeq x (z::y::ys) xs) ((appendAssociative (reverseOnto [] xs) [z] (y::ys)))) (sym (addl x (y::ys) (revontoeq x [z] xs)))

--Proof that reverse is pseudo-contravariant on concatenation
total
reviscontra: (x: Type) -> (y: List x) -> (l: List x) -> (reverse(y++l) =  reverse(l)++reverse(y))
reviscontra x [] z = sym (appendNilRightNeutral (reverseOnto [] z))
reviscontra x (y :: xs) z = trans (trans (trans (revontoeq x [y] (xs++z)) (addl x [y] (reviscontra x xs z))) (sym (appendAssociative (reverse z) (reverse xs) [y]))) (cong(sym (revontoeq x [y] xs)))

-- Proof that the reverse function is self-inverse
total
reveq: (x: Type) -> (l: List x) -> (l = reverse(reverse l))
reveq x [] = Refl
reveq x (y :: xs) = sym (trans (trans (cong(reviscontra x [y] xs)) (reviscontra x (reverse xs) (reverse [y]))) (cong(sym (reveq x xs))))


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

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

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

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

filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter p Nil = (_ ** [])
filter p (x :: xs)
    = case filter p xs of
           (_ ** xs') => if p x then (_ ** x :: xs')
                                else (_ ** xs')

cons : t -> (x : Nat ** Vect x t) -> (x : Nat ** Vect x t)
cons val xs
    = record { fst = S (fst xs),
               snd = (val :: snd xs) } xs

cons' : t -> (x : Nat ** Vect x t) -> (x : Nat ** Vect x t)
cons' val
    = record { fst $= S,
               snd $= (val ::) }

Show a => Show (Vect n a) where
    show xs = "[" ++ show' xs ++ "]" where
        show' : forall n . Vect n a -> String
        show' Nil        = ""
        show' (x :: Nil) = show x
        show' (x :: xs)  = show x ++ ", " ++ show' xs


> module Num.Refinements

> %default total

> %access public export

> |||
> interface (Num t) => NumPlusZeroNeutral t where
>   plusZeroLeftNeutral  : (x : t) -> 0 + x = x
>   plusZeroRightNeutral : (x : t) -> x + 0 = x

> |||
> interface (NumPlusZeroNeutral t) => NumPlusAssociative t where
> -- interface (Num t) => NumPlusAssociative t where
>   plusAssociative : (x, y, z : t) -> x + (y + z) = (x + y) + z

> |||
> interface (NumPlusAssociative t) => NumMultZeroOne t where
> -- interface (Num t) => NumMultZeroOne t where
>   multZeroRightZero   : (x : t) -> x * 0 = 0
>   multZeroLeftZero    : (x : t) -> 0 * x = 0
>   multOneRightNeutral : (x : t) -> x * 1 = x
>   multOneLeftNeutral  : (x : t) -> 1 * x = x

> |||
> interface (NumMultZeroOne t) => NumMultDistributesOverPlus t where
> -- interface (Num t) => NumMultDistributesOverPlus t where
>   multDistributesOverPlusRight : (x, y, z : t) -> x * (y + z) = (x * y) + (x * z)
>   multDistributesOverPlusLeft  : (x, y, z : t) -> (x + y) * z = (x * z) + (y * z)


-- exercises in "Type-Driven Development with Idris"
-- chapter 9

-- check that all functions are total
  %default total

--
-- section 9.1
--

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

-- > the (Elem' 2 [1, 2, 4]) (There Here)
-- There Here : Elem' 2 [1, 2, 4]
-- > the (Elem' 7 [1, 2, 4]) (There Here)
-- (input):1:26-35:When checking an application of constructor Main.There:
--         Type mismatch between
--                 Elem' 2 [2, 4] (Type of Here)
--         and
--                 Elem' 7 [2, 4] (Expected type)
--
--         Specifically:
--                 Type mismatch between
--                         2
--                 and
--                         7

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

-- > the (Last [1,2,3] 3) $ LastCons (LastCons LastOne)
-- LastCons (LastCons LastOne) : Last [1, 2, 3] 3

noLastInEmpty : Last [] value -> Void
noLastInEmpty LastOne impossible
noLastInEmpty (LastCons _) impossible

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

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

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


module SkewBinaryRandomAccessList

import RandomAccessList

%default total
%access private

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

export
data SkewList a = SL (List (Int, Tree a))

ncCons : a -> List (Int, Tree a) -> SkewList a
ncCons x ts = SL ((1, Leaf x) :: ts)

export
RandomAccessList SkewList where
  empty = SL []
  isEmpty (SL ts) = isNil ts

  cons x (SL ts@((w1, t1) :: (w2, t2) :: tts)) =
    if w1 == w2 then SL ((1 + w1 + w2, Node x t1 t2) :: tts) else ncCons x ts
  cons x (SL ts) = ncCons x ts

  head (SL []) = idris_crash "empty list"
  head (SL ((_, Leaf x) :: ts)) = x
  head (SL ((w, Node x t1 t2) :: ts)) = x

  tail (SL []) = ?RandomAccessList_rhs_1
  tail (SL ((_, Leaf x) :: ts)) = SL ts
  tail (SL ((w, Node x t1 t2) :: ts)) = let hw = assert_total $ w `div` 2 in
    SL ((hw, t1) :: (hw, t2) :: ts)

  lookup i (SL ts) = look i ts
   where
    lookTree : Int -> Int -> Tree a -> a
    lookTree _ 0 (Leaf x) = x
    lookTree _ i (Leaf x) = idris_crash "bad subscript"
    lookTree w 0 (Node x t1 t2) = x
    lookTree w i (Node x t1 t2) = let w' = assert_total $ w `div` 2 in
      if i <= w' then lookTree w' (i - 1) t1 else lookTree w' (i - 1 - w') t2

    look i []             = idris_crash "bad subscript"
    look i ((w, t) :: ts) =
      if i < w then lookTree w i t else look (i - w) ts

  update i y (SL ts) = SL (upd i ts)
   where
    updTree : Int -> Int -> Tree a -> Tree a
    updTree _ 0 (Leaf x) = Leaf y
    updTree _ i (Leaf x) = idris_crash "bad subscript"
    updTree w 0 (Node x t1 t2) = Node y t1 t2
    updTree w i (Node x t1 t2) = let w' = assert_total $ w `div` 2 in
      if i <= w' then Node x (updTree w' (i - 1) t1) t2
      else Node x t1 (updTree w' (i - 1 - w') t2)

    upd i [] = idris_crash "bad subscript"
    upd i ((w, t) :: ts) =
      if i < w then (w, updTree w i t) :: ts else (w, t) :: upd (i - w) ts


module Main

import Data.SortedSet
import Data.String

toIntList : List String -> List Integer
toIntList [] = []
toIntList (x :: xs) = maybe (toIntList xs) (\x => x :: (toIntList xs)) (parseInteger x)

firstRepeat : List Integer -> Integer
firstRepeat [] = 0
firstRepeat (x :: xs) = firstRepeatAux 0 infF (insert 0 empty) where
  infF : Stream Integer
  infF = cycle (x :: xs)

  firstRepeatAux : Integer -> Stream Integer -> SortedSet Integer -> Integer
  firstRepeatAux freq (x :: xs) visited =
    let nextFreq = freq + x in
    if (contains nextFreq visited)
    then nextFreq
    else firstRepeatAux nextFreq xs (insert nextFreq visited)

readLine : File -> IO String
readLine f = do l <- fGetLine f
                pure (either (\_ => "") (\x => x) l)

readLines : File -> IO (List String)
readLines f = readLinesAcc [] where
  readLinesAcc : List String -> IO (List String)
  readLinesAcc acc = if (not !(fEOF f))
                     then readLinesAcc (!(readLine f) :: acc)
                     else pure (reverse acc)

main : IO ()
main = case !(openFile "01.input" Read) of
         Left error => putStrLn "Error opening file"
         Right f =>
           let frequencies = toIntList !(readLines f) in
           do putStrLn $ "Part 1: " ++ (show (foldr (+) 0 frequencies))
              putStrLn $ "Part 2: " ++ (show (firstRepeat frequencies))


||| Matrix operations with vector space dimensionalities enforced
||| at the type level. Uses operations from classes in `Control.Algebra`
||| and `Control.Algebra.VectorSpace`.
module Data.Matrix.Algebraic

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

import public Data.Matrix

%default total

infixr 2 <:>  -- vector inner product
infixr 2 ><   -- vector outer product
infixr 2 <<>> -- matrix commutator
infixr 2 >><< -- matrix anticommutator
infixl 3 <\>  -- row times a matrix
infixr 4 </>  -- matrix times a column
infixr 5 <>   -- matrix multiplication
infixr 7 \&\  -- vector tensor product
infixr 7 <&>  -- matrix tensor product

-----------------------------------------------------------------------
--               Vectors as members of algebraic classes
-----------------------------------------------------------------------

instance Semigroup a => Semigroup (Vect n a) where
  (<+>)= zipWith (<+>)

instance Monoid a => Monoid (Vect n a) where
  neutral = replicate _ neutral

instance Group a => Group (Vect n a) where
  inverse = map inverse

instance AbelianGroup a => AbelianGroup (Vect n a) where {}

instance Ring a => Ring (Vect n a) where
  (<.>) = zipWith (<.>)

instance RingWithUnity a => RingWithUnity (Vect n a) where
  unity = replicate _ unity

instance RingWithUnity a => Module a (Vect n a) where
  (<#>) r = map (r <.>)

instance RingWithUnity a => Module a (Vect n (Vect l a)) where
  (<#>) r = map (r <#>)
-- should be Module a b => Module a (Vect n b), but results in 'overlapping instance'

-----------------------------------------------------------------------
--                        (Ring) Vector functions
-----------------------------------------------------------------------

||| Inner product of ring vectors
(<:>) : Ring a => Vect n a -> Vect n a -> a
(<:>) w v = foldr (<+>) neutral (zipWith (<.>) w v)

||| Tensor multiply (⊗) ring vectors
(\&\) : Ring a => Vect n a -> Vect m a -> Vect (n * m) a
(\&\) {n} {m} v w = zipWith (<.>) (oextend m v) (orep n w) where
  orep : (n : Nat) -> Vect m a -> Vect (n * m) a
  orep n v = concat $ replicate n v
  oextend : (n : Nat) -> Vect k a -> Vect (k * n) a
  oextend n w = concat $ map (replicate n) w

||| Standard basis vector with one nonzero entry, ring data type and vector-length unfixed
basis : RingWithUnity a => (Fin d) -> Vect d a
basis i = replaceAt i unity neutral

-----------------------------------------------------------------------
--                         Ring Matrix functions
-----------------------------------------------------------------------

||| Matrix times a column vector
(</>) : Ring a => Matrix n m a -> Vect m a -> Vect n a
(</>) m v = map (v <:>) m

||| Matrix times a row vector
(<\>) : Ring a => Vect n a -> Matrix n m a -> Vect m a
(<\>) r = map (r <:>) . transpose

||| Matrix multiplication
(<>) : Ring a => Matrix n k a ->
                 Matrix k m a ->
                 Matrix n m a
(<>) m1 m2 = map (<\> m2) m1

||| Tensor multiply (⊗) for ring matrices
(<&>) : Ring a => Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) (w1 * w2) a
(<&>) m1 m2 = zipWith (\&\) (stepOne m1 m2) (stepTwo m1 m2) where
  stepOne : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w1 a
  stepOne {h2} m1 m2 = concat $ map (replicate h2) m1
  stepTwo : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w2 a
  stepTwo {h1} m1 m2 = concat $ replicate h1 m2

||| Outer product between ring vectors
(><) : Ring a => Vect n a -> Vect m a -> Matrix n m a
(><) x y = col x <> row y

||| Matrix commutator
(<<>>) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a
(<<>>) m1 m2 = (m1 <> m2) <-> (m2 <> m1)

||| Matrix anti-commutator
(>><<) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a
(>><<) m1 m2 = (m1 <> m2) <+> (m2 <> m1)

||| Identity matrix
Id : RingWithUnity a => Matrix d d a
Id = map (\n => basis n) (fins _)

||| Square matrix from diagonal elements
diag_ : Monoid a => Vect n a -> Matrix n n a
diag_ = zipWith (\f => \x => replaceAt f x neutral) (fins _)

||| Combine two matrices to make a new matrix in block diagonal form
blockDiag : Monoid a => Matrix n n a -> Matrix m m a -> Matrix (n+m) (n+m) a
blockDiag g h = map (++ replicate _ neutral) g ++ map ((replicate _ neutral) ++) h

-----------------------------------------------------------------------
--                           Determinants
-----------------------------------------------------------------------

||| Alternating sum
altSum : Group a => Vect n a -> a
altSum (x::y::zs) = (x <-> y) <+> altSum zs
altSum [x]        = x
altSum []         = neutral

||| Determinant of a 2-by-2 matrix
det2 : Ring a => Matrix 2 2 a -> a
det2 [[x1,x2],[y1,y2]] = x1 <.> y2 <-> x2 <.> y1

||| Determinant of a square matrix
det : Ring a => Matrix (S (S n)) (S (S n)) a -> a
det {n} m = case n of
  Z     => det2 m
  (S k) => altSum . map (\c => indices FZ c m <.> det (subMatrix FZ c m))
         $ fins (S (S (S k)))

-----------------------------------------------------------------------
--                      Matrix Algebra Properties
-----------------------------------------------------------------------

-- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes


module BoundedGCD

%default total
%access public export

notLTEimpliesLT : (a: Nat) -> (b: Nat) -> (LTE a b -> Void) -> LTE (S b) a
notLTEimpliesLT Z b contra = void (contra (LTEZero))
notLTEimpliesLT (S k) Z f = LTESucc (LTEZero)
notLTEimpliesLT (S k) (S j) contra =
  LTESucc (notLTEimpliesLT k j previousContra) where
    previousContra = \evidence : (LTE k j) => contra (LTESucc evidence)

subWithBound: (n: Nat) -> (m: Nat) -> (LTE m n) -> (k: Nat ** LTE k n)
subWithBound n Z LTEZero = (n ** lteRefl)
subWithBound (S p) (S q) (LTESucc pf) = case subWithBound p q pf of
                                             (x ** pf) =>
                                                (x ** lteSuccRight pf)

boundedGCD : (bnd: Nat) -> (n: Nat) -> (m: Nat) -> (LTE n bnd) -> (LTE (S m) bnd) -> Nat
boundedGCD (S b) Z m x (LTESucc y) = m
boundedGCD (S b) (S k) Z x (LTESucc y) = (S k)
boundedGCD (S b) (S Z) (S j) (LTESucc x) (LTESucc y) = S Z
boundedGCD (S b) (S k) (S Z) (LTESucc x) (LTESucc y) = S Z
boundedGCD (S b) (S (S (k))) (S (S (j))) (LTESucc x) (LTESucc y) =
  case isLTE j k of
        (Yes prf) => case subWithBound k j prf of
                           (diff ** pf) => boundedGCD b (S (S j)) diff y (lteTransitive (LTESucc pf) x)
        (No contra) =>
          let
            ineq = notLTEimpliesLT j k contra
          in
            boundedGCD b (S (S j)) (S (S k)) y (lteTransitive (LTESucc (LTESucc ineq)) y)

gcdAlgo : Nat -> Nat -> Nat
gcdAlgo k j = case isLTE (S j) k of
                   (Yes prf) => boundedGCD k k j lteRefl prf
                   (No contra) =>
                      let
                        ineq = notLTEimpliesLT (S j) k contra
                      in
                        boundedGCD (S j) k j  (lteSuccLeft ineq) lteRefl


|||
||| A type-checkable division algorithm.
|||
||| CC-BY 2020 James B. Wilson
||| Department of Mathematics
||| Colorado State University
|||

data LT = {m:Nat} ->  (n:Nat) ->  Type
mkLessThan : {m:Nat} -> (n:Nat) -> (k:Nat) -> (e:n+k+1=m) -> LessThan m

data GTE = {m:Nat} ->  (n:Nat) ->  Type
mkGreaterThanEqual : {m:Nat} -> (n:Nat) -> (k:Nat) -> (e:n=m+k) -> GTE m

||| Proposition: For all positive natural numbers m and all natural numbers n,
||| there exists a natural number q, and natural number r < m, such that n=qm+r.
div :  (m:Nat) -> (n:Fin m) -> (q:Nat ** (r:Nat ** (n=(q*m+r+q)))
div m n = (Z ** (n ** Refl))
div m n = lift (div m n-m) where lift (q**(r**e)) = ((q+1)**(r**cong {f} e)))

---div S(m) n:Fin m = (q,n, refl:n=n)
---div S(m) n       = (1+q,r, cong(e):n=q*S(m)+r) where (q,r,e) = div(S(m),n-m)


module Decidable.Finite.Fin

import Data.Nat
import Data.Nat.Order
import Data.Fin
import Decidable.Decidable.Extra
import Data.Fin.Extra

||| Given a decidable predicate on Fin n,
||| it's decidable whether any number in Fin n satisfies it.
public export
finiteDecEx : {n : Nat} -> {0 p : Fin n -> Type} ->
  (pdec : (k : Fin n) -> Dec (p k)) ->
  Dec (k ** p k)
finiteDecEx {n = Z} pdec = No (absurd . fst)
finiteDecEx {n = S n} pdec =
  case pdec FZ of
    Yes pz => Yes (FZ ** pz)
    No npz => case finiteDecEx {n = n} (\ k => pdec (FS k)) of
      Yes (k ** pk) => Yes (FS k ** pk)
      No npk => No $ \case
        (FZ ** pz) => absurd (npz pz)
        (FS k ** pk) => absurd (npk (k ** pk))

||| Given a decidable predicate on Fin n,
||| it's decidable whether all numbers in Fin n satisfy it.
public export
finiteDecAll : {n : Nat} -> {0 p : Fin n -> Type} ->
  (pdec : (k : Fin n) -> Dec (p k)) ->
  Dec ((k : Fin n) -> p k)
finiteDecAll pdec  = notExistsNotForall pdec $ finiteDecEx (\ x => negateDec (pdec x))


module TakeN

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 n_xs => Exact (x :: n_xs)
takeN (S k) (x :: xs) with (takeN k xs)
  takeN (S k) (x :: xs) | Fewer = Fewer
  takeN (S k) (x :: _) | Exact n_xs = Exact (x :: n_xs)

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

halves : List a -> (List a, List a)
halves xs with (takeN ((length xs) `div` 2) xs)
  halves _ | Fewer = ([], []) -- impossible?
  halves (lft ++ rgt) | Exact _ = (lft, rgt)


module Main

import Data.Vect

readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

data VectUnknown : Type -> Type where
     MkVect : (len : Nat) -> Vect len a -> VectUnknown a

-- We can use implicit underscore notation because there is only one valid value for length in the below
readVect : IO (VectUnknown String)
readVect = do x <- getLine
              if (x == "") then pure (MkVect _ [])
              else do MkVect _ xs <- readVect
                      pure (MkVect _ (x :: xs))

readVectPair : IO (len ** Vect len String)
readVectPair = do x <- getLine
                  if (x == "") then pure (_ ** [])
                  else do (_ ** xs) <- readVectPair
                          pure (_ ** (x :: xs))

printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) = putStrLn (show xs ++ " (length " ++ show len ++ ")")

-- We cannot use the below format to define VectUnknown because we need to state the length of the Vector
-- data MyVectUnknown = MyMkVect Nat Vect

zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVectPair
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <- readVectPair
               case exactLength len1 vec2 of
                    Nothing      => putStrLn "Vectors are of different lengths"
                    (Just vec2') => printLn (zip vec1 vec2')


import Data.Vect

-- Page 50

-- Exercise 2
{- reversei : List Char -> List Char
reversei [] = []
reversei (x :: xs) = reversei xs ++ [x]

reverse : String -> String
reverse x = pack $ reversei $ unpack x -}

-- Exercise 2
palindrome2 : String -> Bool
palindrome2 x = x == reverse x

-- Exercise 3
palindrome3 : String -> Bool
palindrome3 x = toLower x == (reverse $ toLower x)

-- Exercise 6
counts : String -> (Nat, Nat)
counts x = (length $ words x, length x)

-- Exercise 7
top_ten : Ord a => List a -> List a
top_ten xs = take 10 $ reverse $ sort xs

-- Page 75
length_ : List a -> Nat
length_ [] = 0
length_ (x :: xs) = S (length_ xs)

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

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

map2_ : (a -> b) -> Vect n a -> Vect n b
map2_ f [] = []
map2_ f (x :: xs) = f x :: (map2_ f xs)

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

--transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
--transposeMat [] = createEmpties
--transposeMat (x :: xs) = ?transposeMat_rhs_2

dotProduct : Num a => Vect m a -> Vect m a -> Vect m a
dotProduct = zipWith (+)

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix l1 l2 = zipWith dotProduct l1 l2

-- Extra
double : Vect n a -> Vect (n * 2) a
double [] = []
double (x :: xs) = [x, x] ++ double xs

-- countTo : (m : Nat) -> Vect m Nat
-- countTo Z = []
-- countTo (S k) = countTo k ++ [S k]

addOrNothing : a -> Maybe (Vect k a) -> Maybe (Vect (S k) a)
addOrNothing x Nothing = Nothing
addOrNothing x (Just xs) = Just (x :: xs)

takeList : (n : Nat) -> List a -> Maybe (Vect n a)
takeList Z xs = Just []
takeList (S k) [] = Nothing
takeList (S k) (x :: xs) = addOrNothing x (takeList k xs)


module Main

data Binary : Nat -> Type where
    BEnd : Binary Z
    BO : Binary n -> Binary (n + n)
    BI : Binary n -> Binary (S (n + n))

Show (Binary n) where
    show (BO x) = show x ++ "0"
    show (BI x) = show x ++ "1"
    show BEnd = ""

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

total
parity : (n:Nat) -> Parity n
parity Z     = Even {n=Z}
parity (S Z) = Odd {n=Z}
parity (S (S k)) with (parity k)
    parity (S (S (j + j)))     | Even ?= Even {n=S j}
    parity (S (S (S (j + j)))) | Odd  ?= Odd {n=S j}

natToBin : (n:Nat) -> Binary n
natToBin Z = BEnd
natToBin (S k) with (parity k)
   natToBin (S (j + j))     | Even  = BI (natToBin j)
   natToBin (S (S (j + j))) | Odd  ?= BO (natToBin (S j))

intToNat : Int -> Nat
intToNat 0 = Z
intToNat x = if (x>0) then (S (intToNat (x-1))) else Z

main : IO ()
main = do putStr "Enter a number: "
          x <- getLine
          print (natToBin (fromInteger (cast x)))
          putStrLn ""

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

Main.natToBin_lemma_1 = proof
  intros
  rewrite plusSuccRightSucc j j
  rewrite sym (plusSuccRightSucc j j)
  trivial

parity_lemma_1 = proof
    intros
    rewrite sym (plusSuccRightSucc j j)
    trivial

parity_lemma_2 = proof {
    intro;
    intro;
    rewrite sym (plusSuccRightSucc j j);
    trivial;
}


import Data.Fin

data PowerSource = Petrol | Pedal

||| Vehicle here is a function from PowerSource to a type
data Vehicle : PowerSource -> Type where
  Bycicle : Vehicle Pedal
  Car : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle power -> Nat
wheels Bycicle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Car 200
refuel Bycicle impossible

||| After looking into the definition of `integerToFin` in
||| https://github.com/idris-lang/Idris-dev/blob/master/libs/base/Data/Fin.idr
||| it seems that my original approach wasn't that far off, but maybe...
integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin x Z = Nothing
integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

integerToFin' : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin' x Z = Nothing
integerToFin' x n  = case compare (cast x) n of
                          GT => Nothing
                          EQ => Nothing
                          -- LT => Just (the (Fin n) (cast x))
                          -- what's the way?