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


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


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')


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?


||| Complex number.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Complex

import Generics.Derive
%language ElabReflection

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

public export
record Complex t where
  constructor MkComplex
  real : t
  imag : t

export
Show t => Show (Complex t) where
  show x = show x.real ++ " + " ++ show x.imag ++ "i"

export
Functor Complex where
  map f x = MkComplex (f x.real) (f x.imag)

%runElab derive "Complex" [Generic, Meta, Eq]

export
(Neg t, Num t) => Num (Complex t) where
  x + y = MkComplex (x.real + y.real) (x.imag + y.imag)
  x * y = MkComplex (x.real * y.real - x.imag * y.imag)
                    (x.real * y.imag + x.imag * y.real)
  fromInteger x = MkComplex (fromInteger x) (fromInteger 0)

export
Neg t => Neg (Complex t) where
  negate x = MkComplex (negate x.real) (negate x.imag)
  x - y    = MkComplex (x.real - y.real) (x.imag - y.imag)

export
isReal : (Num t, Eq t) => Complex t -> Bool
isReal x = x.imag == fromInteger 0

export
isImage : (Num t, Eq t) => Complex t -> Bool

export
plus_commutative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {comm_t: {a,b:t} -> (a + b) = (b + a)}
    -> (x + y) = (y + x)
plus_commutative = rewrite (comm_t {a=x.real} {b=y.real})
                in rewrite (comm_t {a=x.imag} {b=y.imag})
                in Refl

plus_assosiative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {assoc_t: {a,b,c:t} -> (a + b) + c = a + (b + c)}
    -> (x + y) + z = x + (y + z)
plus_assosiative = rewrite (assoc_t {a=x.real} {b=y.real} {c=z.real})
                in rewrite (assoc_t {a=x.imag} {b=y.imag} {c=z.imag})
                in Refl

mult_commutative : (Num t, Neg t)
    => {x, y:Complex t}
    -> {mult_comm_t: {a,b:t} -> a * b = b * a}
    -> {plus_comm_t: {a,b:t} -> a + b = b + a}
    -> (x * y) = (y * x)
mult_commutative = rewrite (mult_comm_t {a=x.real} {b=y.real})
                in rewrite (mult_comm_t {a=x.imag} {b=y.imag})
                in rewrite (mult_comm_t {a=x.real} {b=y.imag})
                in rewrite (mult_comm_t {a=x.imag} {b=y.real})
                in rewrite (plus_comm_t {a=(y.imag * x.real)} {b=(y.real * x.imag)})
                in Refl

distributive : (Num t, Neg t)
    => {x, y:Complex t}
    -> {dist_t: {a,b,c:t} -> a * (b + c) = a * b + a * c}
    -> {plus_commu_t: {a,b:t} -> a + b = b + a}
    -> x * (y + z) = x * y + x * z
distributive = rewrite (dist_t {a=x.real} {b=y.real} {c=z.real})
            in rewrite (dist_t {a=x.imag} {b=y.imag} {c=z.imag})
            in rewrite (dist_t {a=x.real} {b=y.imag} {c=z.imag})
            in rewrite (dist_t {a=x.imag} {b=y.real} {c=z.real})
            in ?lhs_distributive

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

export
conjugate : Neg t => Complex t -> Complex t
conjugate x = MkComplex x.real (negate x.imag)

conjugate_distributive : (Num t, Neg t)
    => {x, y: Complex t}
    -> {pr: {a,b:t} -> negate (a + b) = negate a + negate b}
    -> conjugate (x + y) = conjugate x + conjugate y
conjugate_distributive = rewrite (pr {a =x.imag} {b=y.imag}) in Refl

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Data.List.Palindrome

import Data.List
import Data.List.Views
import Data.List.Views.Extra
import Data.List.Reverse
import Data.List.Equalities

%hide Prelude.reverse
%default total

||| Do geese see God?
public export
data Palindrome : (xs : List a) -> Type where
  Empty  : Palindrome []
  Single : Palindrome [_]
  Multi  : Palindrome xs -> Palindrome (x :: (xs `snoc` x))

||| A Palindrome reversed is itself.
export
palindromeReverse : (xs : List a) -> Palindrome xs -> reverse xs = xs
palindromeReverse [] Empty = Refl
palindromeReverse [_] Single = Refl
palindromeReverse ([x] ++ ys ++ [x]) (Multi pf) =
  rewrite reverseAppend ([x] ++ ys) [x] in
    rewrite reverseAppend [x] ys in
      rewrite palindromeReverse ys pf in
        Refl

private
reversePalindromeEqualsLemma
  : (x, x' : a)
  -> (xs : List a)
  -> reverse (x :: (xs ++ [x'])) = (x :: (xs ++ [x']))
  -> (reverse xs = xs, x = x')
reversePalindromeEqualsLemma x x' xs prf = equateInnerAndOuter flipHeadX
  where
    flipHeadX : reverse (xs ++ [x']) ++ [x] = x :: (xs ++ [x'])
    flipHeadX = rewrite (sym (reverseCons x (xs ++ [x']))) in prf
    flipLastX' : reverse (xs ++ [x']) = x :: xs -> (x' :: reverse xs) = (x :: xs)
    flipLastX' prf = rewrite (sym $ reverseAppend xs [x']) in prf
    cancelOuter : (reverse (xs ++ [x'])) = x :: xs -> reverse xs = xs
    cancelOuter prf = snd (consInjective (flipLastX' prf))
    equateInnerAndOuter
      : reverse (xs ++ [x']) ++ [x] = (x :: xs) ++ [x']
      -> (reverse xs = xs, x = x')
    equateInnerAndOuter prf =
      let (prf', xEqualsX') = snocInjective prf
       in (cancelOuter prf', xEqualsX')

||| Only Palindromes are equal to their own reverse.
export
reversePalindrome : (xs : List a) -> reverse xs = xs -> Palindrome xs
reversePalindrome input prf with (vList input)
  reversePalindrome [] _ | VNil = Empty
  reversePalindrome [x] _ | VOne = Single
  reversePalindrome (x :: (inner `snoc` y)) prf | VCons rec with (reversePalindromeEqualsLemma x y inner prf)
    reversePalindrome (x :: (inner `snoc` y)) prf | VCons rec | (revInnerIsIdentical, xIsY) =
      rewrite xIsY in
        Multi $ reversePalindrome inner revInnerIsIdentical | Force rec


module Quotient_Group

import Monoid
import Group
import Group_property
import Group_property2

%access public export

||| Given a map f : g -> h, the image of f along with the proofs
total
ImageOf : (x : Type) -> (y : Type) -> (f : x -> y) -> Type
ImageOf x y f = (b : y ** (a : x ** ( (f a) = b)))

||| Generates the (right) coset over h of a given element in g
total
Coset: (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
       (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
       (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> Type

Coset h (+) pf1 g (*) pf2 (f ** pfSub) a = (y : g ** (y1 : ImageOf h g f ** ((fst y1)*a = y)))
--Imgfn h g (\r => a*(fst(sbgrp) r))

||| The property that a particular element is in the coset
total
Is_in_Coset : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
              (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
              (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) -> Type

Is_in_Coset h (+) pf1 g (*) pf2 (f ** pfSub) a b = (y1 : ImageOf h g f ** ((fst y1)*a = b))

||| If b is in the coset of a, then a is in the coset of b
total
Coset_property_1 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> (a : g) -> (b : g) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) a b) ->
                   (Is_in_Coset  h (+) pf1 g (*) pf2 (f ** pfSub) b a)

Coset_property_1 h (+) pfh g (*) pfg pfSub a b pf_a_in_Cb = let
                                                            y = fst (fst pf_a_in_Cb)
                                                            x = fst (snd (fst pf_a_in_Cb))
                                                            pf_fx_is_y = (snd (snd (fst pf_a_in_Cb))) -- proof that (f x) = y
                                                            pfy = snd pf_a_in_Cb -- proof that y*a = b

                                                            f = (fst pfSub) -- the inclusion map from h to g
                                                            pfhom = (fst (snd pfSub)) -- proof that f is a homomorphism

                                                            x1 = Inv h (+) pfh x
                                                            y1.1 = (f x1)
                                                            y1.2 = Inv g (*) pfg y
                                                            pf_y12_eq = (Group_property_8 h (+) pfh g (*) pfg f pfhom x1) -- proof that
                                                                                -- y1.1 = y1.2

                                                            in
                                                            ?rhs

{-
||| Property 2 - A proof that C(a) * C(b) and C(a*b) are equal as sets
total
Coset_property_2 : (h : Type) -> ((+) : h -> h -> h) -> (pf1 : IsGroup h (+)) ->
                   (g : Type) -> ((*) : g -> g -> g) -> (pf2 : IsGroup g (*)) ->
                   (Subgroup h (+) pf1 g (*) pf2) -> Type
-}


module Instances.ZZ

import public Data.ZZ
import Common.Util
import Common.Interfaces
import Specifications.OrderedGroup
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Symmetry.Abelian
import Instances.Notation
import public Instances.OrderZZ

%default total
%access public export

implementation Ringops ZZ where
  Zero = Pos 0
  One = Pos 1

zzMonoid : specifyMonoid {s = ZZ}
zzMonoid = MkMonoid plusAssociativeZ plusZeroLeftNeutralZ plusZeroRightNeutralZ

zzGroup : specifyGroup {s = ZZ}
zzGroup = MkGroup zzMonoid plusNegateInverseRZ plusNegateInverseLZ

zzPartialOrder : specifyPartialOrder {leq = LTEZ}
zzPartialOrder = MkPartialOrder lteReflZ lteTransitiveZ lteAntisymmetricZ

zzTotalOrder : specifyTotalOrder {leq = LTEZ}
zzTotalOrder = MkTotalOrder zzPartialOrder lteTotalZ

zzPartiallyOrderedMagma : specifyPartiallyOrderedMagma {leq = LTEZ}
zzPartiallyOrderedMagma = MkPartiallyOrderedMagma zzPartialOrder
  lteLeftTranslationInvariantZ $
  abelianTranslationInvariantLR plusCommutativeZ lteLeftTranslationInvariantZ

zzPartiallyOrderedGroup : specifyPartiallyOrderedGroup {leq = LTEZ}
zzPartiallyOrderedGroup = MkPartiallyOrderedGroup zzGroup
  zzPartiallyOrderedMagma

zzOrderedGroup : specifyOrderedGroup {leq = LTEZ}
zzOrderedGroup = MkOrderedGroup zzPartiallyOrderedGroup lteTotalZ

zzDiscreteOrderedGroup : specifyDiscreteOrderedGroup {leq = LTEZ}
zzDiscreteOrderedGroup = MkDiscreteOrderedGroup zzOrderedGroup
  plusCommutativeZ lteDiscreteZ

zzRing : specifyRing {s = ZZ}
zzRing = MkRing
  (MkPreRing
    multDistributesOverPlusRightZ
    multDistributesOverPlusLeftZ
    plusCommutativeZ)
  zzGroup
  multAssociativeZ

zzOrderedRing : specifyOrderedRing {leq = LTEZ}
zzOrderedRing = MkOrderedRing
  (MkPartiallyOrderedRing zzRing zzPartiallyOrderedMagma)
  lteTotalZ

zzDiscreteOrderedRing : specifyDiscreteOrderedRing {leq = LTEZ}
zzDiscreteOrderedRing = MkDiscreteOrderedRing zzOrderedRing
  lteDiscreteZ multOneLeftNeutralZ multOneRightNeutralZ (LtePosPos LTEZero)


module xquant.Core.Helicity

import xquant.Core.Types
import Data.Matrix.Numeric

%default total

---- Helicity type synonyms ----

Bispinor : Type
Bispinor = Matrix 2 2 Amp

Gamma : Type
Gamma = Matrix 4 4 Amp

---- Constant bispinors: Pauli matrices, antisym tensor ----

private i : Amp
i = 0 :+ 1

%access public

sx : Bispinor
sx = [[0,1],[1,0]]

sy : Bispinor
sy = [[0,i],[-i,0]]

sz : Bispinor
sz = [[1,0],[0,-1]]

ep : Bispinor
ep = [[0,-1],[1,0]]

---- Momentum bispinors σ(p) ----

||| Produce a bispinor from a Minkowski 4-vector
bispin : Mink -> Bispinor
bispin [e,px,py,pz] = (e  <#> Id)
                    + (px <#> sx)
                    + (py <#> sy)
                    + (pz <#> sz)

||| Produce a bispinor from a Minkowski 4-vector;
||| Upstairs spinor index (barred) version
bispin' : Mink -> Bispinor
bispin' [e,px,py,pz] = (e  <#> Id)
                     - (px <#> sx)
                     - (py <#> sy)
                     - (pz <#> sz)

||| Minkowski inner product
mink : Mink -> Mink -> Amp
mink (x0 :: xs) (y0 :: ys) = -(x0 * y0) + (xs <:> ys)

|||
eta : Gamma
eta = diag_ [-1,1,1,1]

gx : Matrix 4 4 Amp
gx = concatMatrix [[0,-sx],[sx,0]]

gy : Matrix 4 4 Amp
gy = concatMatrix [[0,-sy],[sy,0]]

gz : Matrix 4 4 Amp
gz = concatMatrix [[0,-sz],[sz,0]]

g0 : Matrix 4 4 Amp
g0 = concatMatrix {x=2} [[0,Id],[Id,0]]

||| Feynman slash: Dot a minkowski vector
||| into the gamma matrix vector
slash : Mink -> Matrix 4 4 Amp
slash [e,x,y,z] = (e <#> Id)
                + (x <#> gx)
                + (y <#> gy)
                + (z <#> gz)

||| 4 standard gamma matrices for D=4
gammas : Vect 4 Gamma
gammas = [g0,gx,gy,gz]

||| implicit conversion from Float to Complex Float
private implicit toCF : Fl -> Amp
toCF x = x :+ 0

g5 : Gamma
g5 = i <#> foldr1 (<>) gammas

||| Left-handed spinor projection
pL : Gamma
pL = 0.5 <#> (1 - g5)

||| Right-handed spinor projection
pR : Gamma
pR = 0.5 <#> (1 + g5)

||| Generate a vector from function
vecGen : (Fin n -> a) -> Vect n a
vecGen f = map f (fins _)

||| Generate a matrix from function
matGen : (Fin n -> Fin m -> a) -> Matrix n m a
matGen f = vecGen <$> vecGen f

||| Spin matrix
spin : Fin 4 -> Fin 4 -> Gamma
spin j k = i*(1/4) <#> index j gammas <<>> index k gammas


module Extra.Scientific

private
pow : Integer -> Integer -> Integer
pow a 0 = 1
pow a b = if b < 0 then 0 else a * pow a (b - 1)

private
bin10Index : Integer -> Integer
bin10Index n = helper 0
  where
  helper : Integer -> Integer
  helper a = if n < pow 10 a then a else helper (a + 1)

||| Scientific notation representation in the form of `coefficient*10^(exponentation)`
public export
data Scientific : Type where
  MkScientific : (coefficient : Integer) -> (exponentation : Integer) -> Scientific

export
Show Scientific where
  show (MkScientific m n) = show m <+> "e" <+> show n

export
Num Scientific where
  (MkScientific c1 e1) + (MkScientific c2 e2) =
    if e1 < e2
    then MkScientific (c1 + c2 * (10 `pow` (e2 - e1))) e1
    else MkScientific (c1 * (10 `pow` (e1 - e2)) + c2) e2
  (MkScientific m n) * (MkScientific m' n') = MkScientific (m * m') (n * n')
  fromInteger i = MkScientific i 0

export
Neg Scientific where
  negate (MkScientific c e) = MkScientific (-c) e

||| Convert a integer into a `Scientific` with its most significant digit moved to just after the decimal point
export
asDecimal : Integer -> Scientific
asDecimal n = MkScientific n (negate (bin10Index n))

export
toDouble : Scientific -> Double
toDouble (MkScientific m n) = cast m * (10 `pow` cast n)


import Data.Vect

tryIndex : Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         (Just idx) => Just (index idx xs)

vectTake : (num : Fin (S n)) -> Vect n a -> Vect (finToNat num) a
vectTake FZ _ = []
vectTake (FS y) (x :: xs) = x :: vectTake y xs


module CheckEqDec

data Vect : Nat -> (elem : Type) -> Type where
     Nil : Vect Z elem
     (::) : elem -> Vect n elem -> Vect (1 + n) elem

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

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

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

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

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

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

-- Ex 8.3 #2
DecEq a => DecEq (Vect n a) where
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) = case decEq x y of
                                 (Yes prf1) => case decEq xs ys of
                                                   (Yes prf2) => Yes $ rewrite prf1 in rewrite prf2 in Refl
                                                   (No contra2) => No $ tailUnequal contra2
                                 (No contra1) => No $ headUnequal contra1


module Linear

import ZZ
import Rationals
import Data.Vect

%access public export

data SolExists : Type where
  YesExists : SolExists
  DNExist : SolExists

isFactor : Nat -> Nat -> Type
isFactor m n = (k : Nat ** (m * k = n)) -- will be useful in solving Diophantine equations:
                                        -- if the denominator is a factor of the numerator, there is an integer solution

is_a_zero: (a: ZZ) -> Bool
is_a_zero (Pos Z) = True
is_a_zero (Pos (S k)) = False
is_a_zero (NegS k) = False

ApZZ : (f: ZZ -> ZZ)-> n = m -> f n = f m -- like apNat, but for ZZ
ApZZ f Refl = Refl

-- Helper functions for the case ax = 0 --

ZeroSum: (a: ZZ) -> (b: ZZ) -> (a = 0) -> (b = 0) -> (a + b = 0) --sum of two zeroes is zero
ZeroSum (fromInt(0)) (fromInt(0)) Refl Refl = Refl

triviality1: (a: ZZ) -> (b: ZZ) -> (b = 0) -> (a*b=0) -- premultiplying 0 by anything returns 0
triviality1 a b prf = trans (apZZ (\x => a*x) b 0 prf) (multZeroRightZeroZ(a))

triviality2: (a: ZZ) -> (0*a=0) -- 0 times anything is zero
triviality2 a = multZeroLeftZeroZ(a)

triviality3: (a: ZZ) -> (a*0=0) -- 0 times anything is zero
triviality3 a = multZeroRightZeroZ(a)

ZeroProof: (a: ZZ) -> (b: ZZ) -> (b = 0) -> (0*a + 1*b = 0) -- shows that the rational number (0,1) satisfies ax = 0
ZeroProof a b prf = trans (trans (ApZZ (\x=> x + 1*b) (triviality2 a)) (ApZZ (\x => 0 + x) (triviality1 1 b prf))) (ZeroSum 0 0 Refl Refl)

-- Helper functions for the case ax + b = 0

triviality4: (a: ZZ) -> (b: ZZ) -> (a*b = b*a)
triviality4 a b = multCommutativeZ a (b)

triviality5: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a = a*(-b) + a*b )
triviality5 a b = ApZZ (\x=> a*(-b) + x) (triviality4 b a)

triviality6: (a: ZZ) -> (b: ZZ) -> ( (a*(-b)) + (a*b) = a*( (-b)+b ) )
triviality6 a b = sym ( multDistributesOverPlusRightZ a (-b) b )

triviality7: (a: ZZ) -> (b: ZZ) -> ( a*((-b) + b) = 0)
triviality7 a b = trans (ApZZ (\x => a*x) (plusNegateInverseRZ(b))) (triviality3(a))

SolutionProof: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a=0)
SolutionProof a b = trans (trans (triviality5 a b) (triviality6 a b)) (triviality7 a b)

--Solving a linear equation ax + b = 0 in the case when b = 0 (Basically, this shows that ax=0 is uniquely solved by (0,1))

trivialeqSolver : (a: ZZ) -> (b : ZZ) -> (b = 0) -> Either (x : ZZPair ** (SolExists, (fst x)*a + (snd x)*b = 0)) (SolExists)
trivialeqSolver a b prf = Left ((0,1) ** (YesExists, (ZeroProof a b prf)))

-- Solving the linear equation ax+b = 0 in general

eqSolver : (a: ZZ) -> (b : ZZ) -> (ZZNotZero b) -> Either (x : ZZPair ** (SolExists, a*(fst x) + b*(snd x) = 0)) (SolExists)
eqSolver a b prf = case (is_a_zero(a)) of
  (True) => Right (DNExist)
  (False) => Left ((-b, a) ** (YesExists, (SolutionProof a b))) -- The solution is (-b/a), a rational number, with proof.

-- Helper functions for ax + b = c

helper1: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a*(c+(-b))= a*c + a*(-b))
helper1 a b c = multDistributesOverPlusRightZ (a) (c) (-b)

helper2: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> ( a*(c-b) + b*a = a*c+ a*(-b)+ b*a )
helper2 a b c = ApZZ (\x => x+ b*a) (helper1 (a) (b) (c))

helper3: (a: ZZ) -> (b: ZZ) -> (a*(-b)+b*a= 0)
helper3 a b = trans (trans (triviality5 a b) (triviality6 a b)) (triviality7 a b)

helper4: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a*c + a*(-b) + b*a = a*c)
helper4 a b c = rewrite sym (plusAssociativeZ (a*c) (a*(-b)) (b*a)) in
                rewrite helper3 a b in
                rewrite plusZeroRightNeutralZ (multZ a c) in Refl

GeneralProof: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> ( a*(c-b) + b*a = a*c )
GeneralProof a b c = trans (helper2 a b c) (helper4 a b c)

-- Solving the linear equation ax + b = c (2x +3 = 7, for example) over the rationals

GeneralEqSolver: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (a0: ZZNotZero a) -> (b0: ZZNotZero b) -> (c0: ZZNotZero c) ->
(x : ZZPair ** (SolExists, a*(fst x) + b*(snd x) = (snd x)*c))
GeneralEqSolver a b c a0 b0 c0 = ( ( (c-b) , a ) ** (YesExists, (GeneralProof a b c) )) -- Solves the equation with proof

-- Now, we can use the rational solution of the linear equation ax + b = c to check whether this equation has an integer
-- solution; if it did, the denominator of the rational solution would divide the numerator. If it didn't, the equation
-- would have no solutions in the integers.


-- Shape.idr
--
-- Demonstrate union data types

module Shape

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

%name Shape shape, shape1, shape2

||| Calculates area of given shape
export
area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius


-- Exercises_4_1.idr
--
-- Exercises for generic types

import Tree
import Shape
import Picture

||| Converts given List to a binary Tree
listToTree : Ord elem => List elem -> Tree elem
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

||| Converts given Tree to an ordered List
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = let leftList = treeToList left
                                     rightList = treeToList right in
                                     leftList ++ [x] ++ rightList

-- Integer arithmetic
-- ==================

||| Data type for arithmetic expression(s)
data Expr = ||| Int value
            Val Int
          | ||| Arithmetic addition of two expressions
            Add Expr Expr
          | ||| Arithmetic substraction of two expressions
            Sub Expr Expr
          | ||| Arithmetic multiplication of two expressions
            Mult Expr Expr

||| Evaluates given arithmentic expression
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)

-- Maybe comparator
-- ================
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing (Just y) = Just y
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

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

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


import Data.Vect

proofNil : Vect n elem -> Vect (n + 0) elem
proofNil {n} xs = rewrite plusZeroRightNeutral n in xs

proofNext : Vect (1 + n + k) elem -> Vect (n + (1 + k)) elem
proofNext {n} {k} xs =
  let hypothesis = sym $ plusSuccRightSucc n k
  in rewrite hypothesis
  in xs

go : Vect n elem -> Vect m elem -> Vect (n+m) elem
go acc []        = proofNil acc
go acc (x :: xs) = proofNext (go (x::acc) xs)

total myReverse : Vect len elem -> Vect len elem
myReverse xs = go [] xs

-- total invalidReverseList : List a -> List a
-- invalidReverseList input = []

example: Vect 4 String
example = ["1", "2", "3", "4"]

result: Vect 4 String
result = myReverse example


zeroNotSucc : 0 = S k -> Void
zeroNotSucc Refl impossible

succNotZero : S k = 0 -> Void
succNotZero Refl impossible

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

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat 0 0 = Yes Refl
checkEqNat 0 (S k) = No zeroNotSucc
checkEqNat (S k) 0 = No succNotZero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Yes prf => Yes (cong S prf)
                              No contra => No (noRec contra)


module Cordial.Model.Common.Whole

%default total
%access public export

data Whole : Type where
  W : (n : Nat) -> (prf : IsSucc n) -> Whole

data IsOne : Whole -> Type where
  ItIsOne : IsOne (W (S Z) ItIsSucc)

wholeIsNotOne : Not (IsOne $ W (S (S n)) ItIsSucc)
wholeIsNotOne ItIsOne impossible

isOne : (w : Whole) -> Dec (IsOne w)
isOne (W n prf) with (prf)
  isOne (W (S k) prf) | ItIsSucc with (k)
    isOne (W (S k) prf) | ItIsSucc | Z = Yes ItIsOne
    isOne (W (S k) prf) | ItIsSucc | (S j) = No wholeIsNotOne

data IsGreaterThanOne : Whole -> Type where
  IsGT1 : (LTE 2 (S n)) -> IsGreaterThanOne (W (S n) ItIsSucc)

wholeIsOne : Not (IsGreaterThanOne $ W (S Z) ItIsSucc)
wholeIsOne (IsGT1 (LTESucc LTEZero)) impossible
wholeIsOne (IsGT1 (LTESucc (LTESucc _))) impossible

decEqWholeNotEqual : (contra : (k = j) -> Void) -> (W (S k) ItIsSucc = W (S j) ItIsSucc) -> Void
decEqWholeNotEqual contra Refl = contra Refl

isGreaterThanOne : (w : Whole) -> Dec (IsGreaterThanOne w)
isGreaterThanOne (W n prf) with (prf)
  isGreaterThanOne (W (S k) prf) | ItIsSucc with (isLTE 2 (S k))
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (Yes x) = Yes (IsGT1 x)
    isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) with (k)
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | Z = No wholeIsOne
      isGreaterThanOne (W (S k) prf) | ItIsSucc | (No contra) | (S j) = Yes (IsGT1 (LTESucc (LTESucc LTEZero)))

DecEq Whole where
  decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) with (decEq k j)
    decEq (W (S j) ItIsSucc) (W (S j) ItIsSucc) | (Yes Refl) = Yes Refl
    decEq (W (S k) ItIsSucc) (W (S j) ItIsSucc) | (No contra) = No (decEqWholeNotEqual contra)

toNat : Whole -> Nat
toNat (W n prf) = n

fromNat : (x : Nat) -> {auto prf : IsSucc x} -> Whole
fromNat x {prf} = W x prf

data LTE : Whole -> Whole -> Type where
  IsLTE : (prf : LTE min max)
       -> LTE (W min prfA) (W mac prfB)

Show Whole where
  show (W n prf) = show n

Eq Whole where
  (W l prfL) == (W r prfR) = l == r

Cast Whole Integer where
  cast (W w prf) = toIntegerNat w

Ord Whole where
  compare (W l prfL) (W r prfR) = compare l r


nat_induction :
    (prop : Nat -> Type) ->                -- Property to show
    (prop Z) ->                            -- Base case
    ((k : Nat) -> prop k -> prop (S k)) -> -- Inductive step
    (x : Nat) ->                           -- Show for all x
    prop x
nat_induction prop p_Z p_S Z = p_Z
nat_induction prop p_Z p_S (S k) = p_S k (nat_induction prop p_Z p_S k)

plus_ind : Nat -> Nat -> Nat
plus_ind n m
   = nat_induction (\x => Nat)
                   m                      -- Base case, plus_ind Z m
                   (\k, k_rec => S k_rec) -- Inductive step plus_ind (S k) m
                                          -- where k_rec = plus_ind k m
                   n


-- Find the difference between the sum of the squares of the first one hundred natural numbers and the square of the sum.

sumOfSquares : Int -> Int
sumOfSquares n = sum (map (\x => x*x) [1..n])

squareOfSums : Int -> Int
squareOfSums n = (\x => x*x) (sum [1..n])

main : IO ()
main = print ((squareOfSums 100) - (sumOfSquares 100))


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

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

%default total

using (k : Nat)

  public export
  data FinLTE : Fin k -> Fin k -> Type where
    FromNatPrf : {m, n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n

  public export
  Transitive (Fin k) FinLTE where
    transitive (FromNatPrf xy) (FromNatPrf yz) =
      FromNatPrf $ transitive {rel = LTE} xy yz

  public export
  Reflexive (Fin k) FinLTE where
    reflexive = FromNatPrf $ reflexive {rel = LTE}

  public export
  Preorder (Fin k) FinLTE where

  public export
  Antisymmetric (Fin k) FinLTE where
    antisymmetric {x} {y} (FromNatPrf xy) (FromNatPrf yx) =
      finToNatInjective x y $
        antisymmetric {rel = LTE} xy yx

  public export
  PartialOrder (Fin k) FinLTE where

  public export
  Connex (Fin k) FinLTE where
    connex {x = FZ} _ =  Left $ FromNatPrf LTEZero
    connex {y = FZ} _ = Right $ FromNatPrf LTEZero
    connex {x = FS k} {y = FS j} prf =
      case connex {rel = FinLTE} $ prf . (cong FS) of
        Left  (FromNatPrf p) => Left  $ FromNatPrf $ LTESucc p
        Right (FromNatPrf p) => Right $ FromNatPrf $ LTESucc p

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