> module Num.Properties

> import Data.Fin
> import Data.Vect
> import Syntax.PreorderReasoning

> import Matrix.Matrix
> import Matrix.Operations
> import Num.Refinements
> import Num.Operations

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

The following

> foldrVectLemma : {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) ->
>                  (a : A) -> (as : Vect n A) ->
>                  foldr f e (a :: as) = f a (foldr f e as)

should hold by definition and

< foldrVectLemma f e a as = Refl

should, in principle, type check. In fact, however, |foldr| is
implemented in terms of an accumulator and a proof of |foldrVectLemma|
is not that simple. We start from the "classical" (traditional)
definition of |foldr| for vectors:

> total foldrClassic : (t -> acc -> acc) -> acc -> Vect n t -> acc
> foldrClassic f e []      = e
> foldrClassic f e (x::xs) = f x (foldrClassic f e xs)

In the Idris libraries |foldrImpl| is used instead, but we can prove
the following specification:

> foldrImplLemma : {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) -> (go : B -> B) ->
>                  (as : Vect n A) ->
>                  foldrImpl f e go as = go (foldrClassic f e as)
> foldrImplLemma f e go []        = Refl
> foldrImplLemma f e go (a :: as) =
>     ( foldrImpl f e go (a :: as) )
>   ={ Refl }=
>     ( foldrImpl f e (go . (f a)) as )
>   ={ foldrImplLemma f e (go . (f a)) as }=
>     ( (go . (f a)) (foldrClassic f e as) )
>   ={ Refl }=
>     ( go (f a (foldrClassic f e as)) )
>   ={ Refl }=
>     ( go (foldrClassic f e (a :: as) ) )
>   QED
> %freeze foldrImplLemma

Then we can specialise to when |go| is |id| as in the definition of
|foldr|:

> foldrImplCorr :  {A, B : Type} -> {n : Nat} ->
>                  (f : A -> B -> B) -> (e : B) ->
>                  (as : Vect n A) ->
>                  foldrImpl f e Prelude.Basics.id as = foldrClassic f e as
> foldrImplCorr f e as = foldrImplLemma f e Prelude.Basics.id as
> %freeze foldrImplCorr

Now we can continue with the proof:

> foldrVectLemma g e a as =
>     ( foldr g e (a :: as) )
>   ={ Refl }=
>     ( foldrImpl g e id (a :: as) )
>   ={ foldrImplCorr g e (a :: as) }=
>     ( foldrClassic g e (a :: as) )
>   ={ Refl }=
>     ( g a (foldrClassic g e as) )
>   ={ cong {f = g a} (sym (foldrImplCorr g e as)) }=
>     ( g a (foldrImpl g e id as) )
>   ={ Refl }=
>     ( g a (foldr g e as) )
>   QED
> %freeze foldrVectLemma

Finally we get to the one-step unfolding of |sum|:

> sumLemma : (Num t) => (x : t) -> (xs : Vect m t) -> sum (x :: xs) = x + sum xs
> sumLemma x xs = ( sum (x :: xs) )
>               ={ Refl }=
>                 ( foldr (+) (fromInteger 0) (x :: xs) )
>               ={ foldrVectLemma (+) (fromInteger 0) x xs }=
>                 ( x + foldr (+) (fromInteger 0) xs )
>               ={ Refl }=
>                 ( x + sum xs )
>               QED
> %freeze sumLemma

The corresponding lemma for append (|++|) follows from the definition
of append (because it is not defined in terms of |foldrImpl|)

> appendLemma : (x : t) -> (xs : Vect m t) -> (ys : Vect n t) ->
>               ((x :: xs) ++ ys) = (x :: (xs ++ ys))
> appendLemma x xs ys =
>     ( (x :: xs) ++ ys )
>   ={ Refl }=
>     ( x :: (xs ++ ys) )
>   QED
> %freeze appendLemma

> |||
> multSumLemma : (NumMultDistributesOverPlus t) =>
>                (x : t) -> (xs : Vect m t) ->
>                x * sum xs = sum (multSV x xs)
> multSumLemma x  Nil      = ( x * (fromInteger 0) )
>                          ={ multZeroRightZero x }=
>                            ( fromInteger 0 )
>                          ={ Refl }=
>                            ( sum Data.Vect.Nil )
>                          QED
> multSumLemma x (y :: ys) = ( x * (sum (y :: ys)) )
>                          ={ cong (sumLemma y ys) }=
>                            ( x * (y + sum ys) )
>                          ={ Num.Refinements.multDistributesOverPlusRight x y (sum ys) }=
>                            ( (x * y) + (x * sum ys) )
>                          ={ cong (multSumLemma x ys) }=
>                            ( x * y + sum (multSV x ys) )
>                          ={ sym (sumLemma (x * y) (multSV x ys)) }=
>                            ( sum (x * y :: multSV x ys) )
>                          ={ Refl }=
>                            ( sum (multSV x (y :: ys)) )
>                          QED
> %freeze multSumLemma

> sumsTo : Num t => (s : t) -> (xs : Vect m t) -> Type
> sumsTo s xs = (sum xs = s)

> sumOne : Num t => (xs : Vect m t) -> Type
> sumOne = sumsTo (fromInteger 1)

> lemma0 : (NumPlusZeroNeutral t) => (x : t) -> sum (Data.Vect.(::) x Nil) = x
> lemma0 x = ( x + 0 )
>          ={ plusZeroRightNeutral x }=
>            ( x )
>          QED

> lemma1 :  (NumMultDistributesOverPlus t) =>
>           (x : t) -> (xs : Vect n t) ->
>           sumOne xs -> sumsTo x (multSV x xs)
> lemma1 x xs pxs =
>     ( sum (multSV x xs) )
>   ={ sym (multSumLemma x xs) }=
>     ( x * sum xs )
>   ={ cong pxs }=
>     ( x * fromInteger 1 )
>   ={ multOneRightNeutral x }=
>     x
>   QED

> sumPlusAppendLemma :  NumPlusAssociative t =>
>                       (xs : Vect n t) -> (ys : Vect m t) ->
>                       (sum xs + sum ys) = sum (xs ++ ys)
> sumPlusAppendLemma Nil       ys = plusZeroLeftNeutral (sum ys)
> sumPlusAppendLemma (x :: xs) ys =
>     ( sum (x :: xs) + sum ys )
>   ={ cong {f = (+ sum ys)} (sumLemma x xs) }=
>     ( (x + sum xs) + sum ys )
>   ={ sym (plusAssociative x (sum xs) (sum ys)) }=
>     ( x + (sum xs + sum ys) )
>   ={ cong (sumPlusAppendLemma xs ys) }=
>     ( x + sum (xs ++ ys) )
>   ={ sym (sumLemma x (xs ++ ys)) }=
>     ( sum (x :: (xs ++ ys)) )
>   ={ Refl }=
>     ( sum ((x :: xs) ++ ys) )
>   QED
>
> sumMapConcat : (NumPlusAssociative t) => (xss : Matrix m n t) ->
>                sum (map sum xss) = sum (Vect.concat xss)
> sumMapConcat Nil           = Refl
> sumMapConcat (row :: rows) =
>     ( sum (map sum (row :: rows)) )
>   ={ Refl }=
>     ( sum (sum row :: map sum rows) )
>   ={ sumLemma (sum row) (map sum rows) }=
>     ( sum row + sum (map sum rows) )
>   ={ cong (sumMapConcat rows) }=
>     ( sum row + sum (Vect.concat rows) )
>   ={ sumPlusAppendLemma row (Vect.concat rows) }=
>     ( sum (row ++ Vect.concat rows) )
>   ={ Refl }=
>     ( sum (Vect.concat (row :: rows)) )
>   QED

The |multVMLemma| requires both NumAssocPlus and
NumMultDistributesOverPlus and currently there is some problem with
"multiple constraints" so we changed the NumRefinements classes to a
chain instead of a tree.

> ||| 'Tail' of a finite dependently typed function
> depTail : {n : Nat} -> {P : Fin (S n) -> Type} ->
>           ((k : Fin (S n)) -> P k) -> ((j : Fin n) -> P (FS j))
> depTail f k = f (FS k)

> |||
> multVMLemma0 : (NumMultDistributesOverPlus t) =>
>                (xs : Vect m t) -> (xss : Matrix m n t) ->
>                ((k : Fin m) -> sumOne (row k xss)) ->
>                sum (Vect.concat (multVM xs xss)) = sum xs
> multVMLemma0 {m = Z}    {n}  Nil       Nil        _  = Refl
> multVMLemma0 {m = S m'} {n} (x :: xs) (ys :: yss) ps =
>     ( sum (Vect.concat (multVM (x :: xs) (ys :: yss))) )
>   ={ Refl }=
>     ( sum (Vect.concat ((multSV x ys) :: (multVM xs yss))) )
>   ={ sym (sumMapConcat ((multSV x ys) :: (multVM xs yss))) }=
>     ( sum (map sum ((multSV x ys) :: (multVM xs yss))) )
>   ={ Refl }=
>     ( sum (sum (multSV x ys) :: (map sum (multVM xs yss))) )
>   ={ cong {f = \ X => sum (X :: (map sum (multVM xs yss)))}
>           (lemma1 x ys (ps FZ)) }=
>     ( sum (x :: (map sum (multVM xs yss))) )
>   ={ sumLemma x (map sum (multVM xs yss)) }=
>     ( x + sum (map sum (multVM xs yss)) )
>   ={ cong (sumMapConcat (multVM xs yss)) }=
>     ( x + sum (Vect.concat (multVM xs yss)) )
>   ={ cong (multVMLemma0 xs yss (depTail {P = \ k => sumOne (row k (ys :: yss))} ps)) }=
>     ( x + sum xs )
>   ={ sym (sumLemma x xs) }=
>     ( sum (x :: xs) )
>   QED

> multVMLemma : (NumMultDistributesOverPlus t) =>
>               (m : Nat) ->
>               (xs : Vect m t) -> sumOne xs ->
>               (n : Nat) ->
>               (xss : Matrix m n t) ->
>               ((k : Fin m) -> sumOne (row k xss)) ->
>               sumOne (Vect.concat (multVM xs xss))
> multVMLemma m xs pxs n xss pxss =
>     ( sum (Vect.concat (multVM xs xss)) )
>   ={ multVMLemma0 xs xss pxss }=
>     ( sum xs )
>   ={ pxs }=
>     ( fromInteger 1 )
>   QED

> {-
> ||| Alternative - no case analysis, but would need a few lemmas.
> multVMLemma m xs pxs n xss pxss =
>     ( sum (Vect.concat (multVM xs xss)) )
>   ={ sym (sumMapConcat (multVM xs xss)) }=
>     ( sum (map sum     (multVM xs xss)) )
>   ={ Refl }=
>     ( sum (map sum (map (uncurry multSV)  (zip xs xss))) )
>   ={ ?mapFunctorLemma }=
>     ( sum (map (sum .    uncurry multSV ) (zip xs xss)) )
>   ={ ?mapZipLemma }=
>     ( sum (zipWith (\x, xs => sum (multSV x xs)) xs xss) )
>   ={ ?roughlyLemma1UnderLambdas }=
>     ( sum (zipWith (\x, xs => x         ) xs xss) )
>   ={ ?lala4 }=
>     ( sum xs )
>   ={ pxs }=
>     ( fromInteger 1 )
>   QED
> -}

> {-

> ---}


module Sigma

import Basic
import Unit
import Void

infixr 0 #
public export
data Sigma : (a : Type) -> (p : a -> Type) -> Type where
  (#) : (x : a) -> p x -> Sigma a p

public export
Pair : Type -> Type -> Type
Pair a b = Sigma a (const b)

public export
pr1 : Sigma a p -> a
pr1 (x # _) = x

public export
pr2 : (s : Sigma a p) -> p (pr1 s)
pr2 (_ # y) = y

public export
SigmaInduction : (q : Sigma a p -> Type)
              -> ((x : a) -> (y : p x) -> q (x # y))
              -> (s : Sigma a p) -> q s
SigmaInduction _ f (x # y) = f x y

public export
uncurry : (q : Sigma a p -> Type)
       -> ((x : a) -> (y : p x) -> q (x # y))
       -> (s : Sigma a p) -> q s
uncurry = SigmaInduction

public export
curry : (q : Sigma a p -> Type)
     -> ((s : Sigma a p) -> q s)
     -> ((x : a) -> (y : p x) -> q (x # y))
curry _ f x y = f (x # y)


-- vim: set ft=idris sw=2 ts=2:
--
-- fibonacci.idr
-- Calculate Fibonacci numbers in the Idris programming language
--

module Fibonacci

-- Naive implementation
export
fib_naive : Int -> Int
fib_naive 0 = 0
fib_naive 1 = 1
fib_naive n = fib_naive (n - 1) + fib_naive (n - 2)

-- Tail-call friendly version
export
fib : Nat -> Nat
fib n = fib_aux Z (S Z) n where
  fib_aux : Nat -> Nat -> Nat -> Nat
  fib_aux a b Z = a
  fib_aux a b (S n) = fib_aux b (plus a b) n


module CH07

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

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

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

area : Shape -> Double
area (Triangle x y) = x * y / 2
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

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

Eq Shape where
  (Triangle x0 y0) == (Triangle x1 y1)   = x0 == x1 && y0 == y1
  (Rectangle x0 y0) == (Rectangle x1 y1) = x0 == x1 && y0 == y1
  (Circle x0) == (Circle x1)             = x0 == x1
  _ == _                                 = False

Ord Shape where
  compare shape0 shape1 = compare (area shape0) (area shape1)

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

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

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

(Neg ty, Integral ty, Eq ty) => Eq (Expr ty) where
  l == r = (eval l) == (eval r)

(Neg from_ty, Integral from_ty) => Cast (Expr from_ty) from_ty where
  cast expr = eval expr

Functor Expr where
  map f (Val n)   = Val $ f n
  map f (Add l r) = Add (map f l) (map f r)
  map f (Sub l r) = Sub (map f l) (map f r)
  map f (Mul l r) = Mul (map f l) (map f r)
  map f (Div l r) = Div (map f l) (map f r)
  map f (Abs e)   = Abs $ map f e

Functor (Vect n) where
  map f Nil       = Nil
  map f (x :: xs) = f x :: map f xs

Foldable (Vect n) where
  foldr f acc Nil       = acc
  foldr f acc (x :: xs) = f x (foldr f acc xs)

  foldl f acc Nil       = acc
  foldl f acc (x :: xs) = foldl f (f acc x) xs

Eq e => Eq (Vect n e) where
  Nil == Nil             = True
  (x :: xs) == (y :: ys) = x == y && xs == ys


module Data.Bool.Algebra

import Control.Algebra
import Data.Bool.Xor

%default total

-- && is Bool -> Lazy Bool -> Bool,
-- but Bool -> Bool -> Bool is required
and : Bool -> Bool -> Bool
and True True = True
and _ _ = False

Semigroup Bool where
  (<+>) = xor

SemigroupV Bool where
  semigroupOpIsAssociative = xorAssociative

Monoid Bool where
  neutral = False

MonoidV Bool where
  monoidNeutralIsNeutralL True = Refl
  monoidNeutralIsNeutralL False = Refl

  monoidNeutralIsNeutralR True = Refl
  monoidNeutralIsNeutralR False = Refl

Group Bool where
  -- Each Bool is its own additive inverse.
  inverse = id

  groupInverseIsInverseR True = Refl
  groupInverseIsInverseR False = Refl

AbelianGroup Bool where
  groupOpIsCommutative = xorCommutative

Ring Bool where
  (<.>) = and

  ringOpIsAssociative True True True = Refl
  ringOpIsAssociative True True False = Refl
  ringOpIsAssociative True False True = Refl
  ringOpIsAssociative True False False = Refl
  ringOpIsAssociative False True True = Refl
  ringOpIsAssociative False False True = Refl
  ringOpIsAssociative False True False = Refl
  ringOpIsAssociative False False False = Refl

  ringOpIsDistributiveL True True True = Refl
  ringOpIsDistributiveL True True False = Refl
  ringOpIsDistributiveL True False True = Refl
  ringOpIsDistributiveL True False False = Refl
  ringOpIsDistributiveL False True True = Refl
  ringOpIsDistributiveL False False True = Refl
  ringOpIsDistributiveL False True False = Refl
  ringOpIsDistributiveL False False False = Refl

  ringOpIsDistributiveR True True True = Refl
  ringOpIsDistributiveR True True False = Refl
  ringOpIsDistributiveR True False True = Refl
  ringOpIsDistributiveR True False False = Refl
  ringOpIsDistributiveR False True True = Refl
  ringOpIsDistributiveR False False True = Refl
  ringOpIsDistributiveR False True False = Refl
  ringOpIsDistributiveR False False False = Refl

RingWithUnity Bool where
  unity = True

  unityIsRingIdL True = Refl
  unityIsRingIdL False = Refl

  unityIsRingIdR True = Refl
  unityIsRingIdR False = Refl


module NewEden.NaturalAxioms

import Prelude.Either

import NewEden.Algebra

{- NaturalProperties -

   An incomplete (http://www.dicosmo.org/Articles/zeroisnfa.pdf), non-recursive,
   axiomatic description of the natural numbers defined in terms of functions on a
   given type t.

   Despite the fact that this is *not* a full description of the behavior of the
   Peano naturals, it is probably good enough to do anything of practical interest
   to most people (even mathematicians, in most cases).
-}

data NaturalProperties : (t:Type) -> Type where
  ProofNaturalProperties :
      (Zero:t)
   -> (One:t)
   -> (lemmaDistinction: (Zero = One -> Void))
   -> (plus: (t -> t -> t))
   -> (lemmaPlusCommut: CommutativeFunction t plus)
   -> (lemmaPlusMonoid: Monoid t plus Zero)
   -> (lemmaPlusNoInverses: StrictMonoid lemmaPlusMonoid)
   -> (lemmaPlusMonomorphic: ((a:t) -> MonomorphicFunction $ plus a))
   -> (multiply: (t -> t -> t))
   -> (lemmaMultCommut: CommutativeFunction t multiply)
   -> (lemmaMultMonoid: Monoid t multiply One)
   -> (lemmaMultNoInverses: StrictMonoid lemmaMultMonoid)
   -> (lemmaMultiplyMonomorphic: ((a:t) -> MonomorphicFunction $ multiply a))
   -> (lemmaMultByZeroIsZero: ((a:t) -> multiply a Zero = Zero))
   -> (lemmaDistributive: ((a:t) -> (b:t) -> (c:t) -> multiply a (plus b c) = plus (multiply a b) (multiply a c)))
   -> (lemmaSequence: ((a:t) -> (b:t) -> (p1: (a = Zero -> Void)) -> (p2: plus a b = One) -> a = One))
   -> (compare:((a:t) -> (b:t) -> Either (a = b) (Either ((c ** ((plus a c = b, (c = Zero -> Void))))) (c ** ((plus b c = a, (c = Zero -> Void)))))))
   -> NaturalProperties t


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

splitList : (xs : List a) -> SplitList xs
splitList xs = splitList' xs xs
  where
    splitList' : (counter : List a) -> (input : List a) -> SplitList input
    splitList' _ [] = SplitNil
    splitList' _ [x] = SplitOne
    splitList' (_ :: _ :: counter) (item :: items)
      = case splitList' counter items of
             SplitNil => SplitOne
             SplitOne {x} => SplitPair [item] [x]
             (SplitPair lefts rights) => SplitPair (item :: lefts) rights
    splitList' _ items = SplitPair [] items

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


module TypeTrans.Array

-- Module to represent Vector types, we use
-- Array as it's not already a taken construct
-- in the Idris prelude

import Data.Vect
import Data.List

%default total

-- A Shape is a Vector which represents the structure
-- of an Array e.g. the shape of [[1,2,3],[1,2,3]] would be [2,3]
Shape : Type
Shape = List Nat

-- Rank represents the number of dimensions in an
-- Array, e.g. the rank of [[]] would be 2
Rank : Type
Rank = Nat

Array : Shape -> Type -> Type
Array [] t  = t
Array (v::vs) t = Vect v (Array vs t)

-- Give number of dimensions in the given Array
dim : Array xs t -> Nat
dim arr {xs} = length xs

-- Given a Vector returns the number of items
-- in the vector
length' : Vect n t -> Nat
length' v {n} = n

-- Give the shape of a given array
shape : Array xs t -> Shape
shape arr {xs} = xs

-- Gives a count of the total amount of elements in
-- a vector based on its dimensions
size : Array xs t -> Nat
size arr {xs} = foldr (*) 1 xs

-- Proof that a zero dimensional array cannot
-- contain more than zero dimensions
arrayCannotBeEmpty : Array (0::xs) t -> Void
arrayCannotBeEmpty (v::vs) impossible

-- | Lift a 0 dimensional Vector  into a 1 dimensional
--  Vector
singleton : Array (xs) t -> Array (1::xs) t
singleton t = [t]

-- | Inverse operation from singletonV, reduce dimension
-- of a 1 dimensional Vector with a single value into
-- a 0 dimensional Vector
invSingleton : Array (1::xs) t -> Array (xs) t
invSingleton [t] = t

-- | Map operation on an Array, maps
--   all base elements
mapA : (a -> b) -> Array xs a -> Array xs b
mapA f v {xs=[]}  = f v
mapA f v {xs = (y::ys)} = map (mapA f) v

mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)
mapM _ Nil = return Vect.Nil
mapM f (x::xs) = do
  x' <- f x
  xs' <- mapM f xs
  return (Vect.(::) x' xs')

mapM_ : Monad m => (a -> m b) -> Vect n a -> m ()
mapM_ _ Nil = return ()
mapM_ f (x::xs) = do
  f x
  mapM_ f xs

mapMA : Monad m => (a -> m b) -> Array xs a -> m (Array xs b)
mapMA f v {xs=[]} = f v
mapMA f v {xs = (y::ys)} = mapM (mapMA f) v

mapMA_ : Monad m => (a -> m b) -> Array xs a -> m ()
mapMA_ f v = do
  mapMA f v
  return ()

mapML : Monad m => (a -> m b) -> List a -> m (List b)
mapML _ [] = return []
mapML f (x::xs) = do
    x' <- f x
    xs' <- mapML f xs
    return (x'::xs')

mapML_ : Monad m => (a -> m b) -> List a -> m ()
mapML_ f v = do
  mapML f v
  return ()

-- | Reduce the dimensions of a 2+ dimensional vector
redDim : Array (x1::x2::xs) t -> Array (x1*x2::xs) t
redDim [] = []
redDim (v::vs) = v ++ redDim vs

-- | Flaten an Array down to 1 dimension
flattenA : Array (x::xs) t -> (n ** Array [S n] t)
flattenA v {x = Z} = void (arrayCannotBeEmpty v)
flattenA v {x=S m} {xs=[]}  = (_ ** v)
flattenA v {xs = (y::ys)} = (flattenA (redDim v))

-- | FoldL operation on Array
foldlA : (a -> b -> a) -> a -> Array (x::xs) b -> a
foldlA f e v with (flattenA v)
  | (_ ** v') = foldlA' f e v'
  where foldlA' : (a -> b -> a) -> a -> Array [(S ys)] b -> a
        foldlA' f e v = foldl f e v

-- | Foldl1 operation on an Array
foldlA1 : (a -> a -> a) -> Array (x::xs) a -> a
foldlA1 f v with (flattenA v)
  | (_ ** v') = foldlA1' f v'
  where foldlA1' : (a -> a -> a) -> Array [(S ys)] a -> a
        foldlA1' f v = foldl1 f v

-- | Transpose a 2+ dimensional Vector, switches first and second dimensions
transposeA : Array (x1::x2::xs) t -> Array (x2::x1::xs) t
transposeA = transpose

-- Given a 1+ dimensional Vector in which the size of the highest dimension
-- sz_d0 = m * n, increases the Vector by 1 dimension by taking m lots
-- of n values
incDim : Array (m * n::xs) t -> Array (m::n::xs) t
incDim v {m = Z}  = []
incDim v {m = S r} {n} =
    let (fstN, rest) = (take n v, drop n v) in
        fstN :: (incDim rest)

reshape' : Array (x1::(m * x2)::xs) t -> Array((x1 * m)::x2::xs) t
reshape' [] = []
reshape' (v::vs) = incDim v ++ reshape' vs

reshape : Array (x1::(m * x2)::xs) t -> Array ((m * x1)::x2::xs) t
reshape v {m} {x1} = rewrite (multCommutative m x1) in reshape' v

invReshape' : Array ((x1 * m)::x2::xs) t -> Array (x1::(m * x2)::xs) t
invReshape' v {x1 = Z} = []
invReshape' v {x1 =S r} = map redDim $ incDim v

invReshape : Array ((m * x1)::x2::xs) t -> Array (x1::(m * x2)::xs) t
invReshape v = invReshape' $ flip v
  where flip : Array ((m * x1)::x2::xs) t -> Array ((x1 * m)::x2::xs) t
        flip v {m} {x1} = rewrite multCommutative x1 m in v

-- Section for reshaping a vector keeping the dimensionality
-- the same except showing that the most outer dimension
-- is comprised of 2 factors multiplied together

-- Proof dividing 0 by a non zero number gives 0
divZProof : (m : Nat) -> (nz : Not (m = Z)) -> divNatNZ 0 m nz = 0
divZProof Z nz = void (nz Refl)
divZProof (S Z) _ = Refl
divZProof (S (S n)) _ = Refl

-- Proof modulo 0 by a non zero number gives 0
modZProof : (m : Nat) -> (nz : Not (m = Z)) -> modNatNZ 0 m nz = 0
modZProof Z nz = void (nz Refl)
modZProof (S Z) _ = Refl
modZProof (S (S n)) _ = Refl

-- Proof modNatNZ (m * n) n = 0
modMProof : (m : Nat) -> (n: Nat) -> {default SIsNotZ nz : Not (m = Z)} -> modNatNZ (mult m n) m nz = 0
modMProof Z _ {nz} = void (nz Refl)
modMProof _ Z ?= Z
modMProof m n ?= Z

-- TODO fill these out latee
TypeTrans.Array.modMProof_lemma_1 = proof
  intro
  intro
  exact believe_me Z

TypeTrans.Array.modMProof_lemma_2 = proof
  intro
  intro
  exact believe_me Z

-- Proof of the Quotient Remainder theorem for the specific
-- case of remainder = mod n m, and quotient = div n m
divModProof : (m : Nat) -> (n : Nat) ->
                           (nz : Not (m = Z)) ->
                           (n = m * (divNatNZ n m nz) + (modNatNZ n m nz))
divModProof Z _ nz = void (nz Refl) -- Contraction m /= Z by supplied nz proof
divModProof m Z nz ?= Z -- Proof when n = 0 for all m
divModProof m n nz ?= n

TypeTrans.Array.divModProof_lemma_1 = proof
  intros
  rewrite sym (divZProof m nz)
  rewrite sym (modZProof m nz)
  rewrite sym (plusZeroRightNeutral (mult m 0))
  rewrite sym (multZeroRightZero m)
  trivial

-- TODO Temporary "believe_me" proof, should be replaced
-- with the proof that n = m * (n `div` m) + (n `mod` m) if/when possible
TypeTrans.Array.divModProof_lemma_2 = proof
  intro
  intro
  exact believe_me n

-- Proof that when m divides n that n = m * (n / m) in the case of
-- integer division
factorDivProof : (m : Nat) -> (n : Nat) ->
                        (nz : Not (m = Z)) ->
                        (mz : modNatNZ n m nz = Z) -> n = m * (divNatNZ n m nz)

factorDivProof Z _ nz _ = void (nz Refl) -- Contradiction, m /= Z by supplied nz proof
factorDivProof m Z nz _ ?= Z
factorDivProof m n nz mz ?= n

TypeTrans.Array.factorDivProof_lemma_1 = proof
  intros
  rewrite sym (divZProof m nz)
  rewrite sym (multZeroRightZero m)
  trivial

-- Considering this is a special case of the Quotient Remainder theorem
-- (remainder = 0) we show that this is contained within it, and use that
-- proof to prove this proof
TypeTrans.Array.factorDivProof_lemma_2 = proof
  intros
  rewrite (plusZeroRightNeutral (m * divNatNZ n m nz))
  rewrite mz
  rewrite (divModProof m n nz)
  trivial

-- Given a Vector of size n and a natural number m, and the conditions that m | n and m != 0
-- transforms the Vector of size n into a  Vector of size (m * (n `div` m)) which is equivalent
reshapeByFactor : (m : Nat) -> Array (n::ns) t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Array ((m * (divNatNZ n m nz))::ns) t

reshapeByFactor Z _ {nz} = void (nz Refl)
reshapeByFactor m xs {n} {nz} {mz} = rewrite sym (factorDivProof m n nz mz) in xs

-- Split in one step
splitA : (m : Nat) -> Array (n::ns) t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Array (m ::(divNatNZ n m nz)::ns) t
splitA m a {mz} {nz} = incDim $ reshapeByFactor m a {mz = mz} {nz = nz}

-- Helper functions for reshaping Vectors instead of Arrays,
-- as Unification behaviour is being a bit strange atm,

-- Flatten a 2d vector into a 1d vector
merge : Vect x1 (Vect x2 t) -> Vect (x1 * x2) t
merge [] = []
merge (v::vs) = v ++ merge vs

incDimV : Vect (m * n) t -> Vect m (Vect n t)
incDimV v {m = Z}  = []
incDimV v {m = S r} {n} =
    let (fstN, rest) = (take n v, drop n v) in
        fstN :: (incDimV rest)

reshapeByFV : (m : Nat) -> Vect n t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Vect (m * divNatNZ n m nz) t

reshapeByFV Z _ {nz} = void (nz Refl)
reshapeByFV m xs {n} {nz} {mz} = rewrite sym (factorDivProof m n nz mz) in xs

splitV : (m : Nat) -> Vect n t ->
                               {default SIsNotZ nz : Not (m = Z)} ->
                               {auto mz : modNatNZ n m nz = Z} ->
                               Vect m (Vect (divNatNZ n m nz) t)
splitV m a {mz} {nz} = incDimV $ reshapeByFV m a {mz = mz} {nz = nz}

doubleToNat : Double -> Nat
doubleToNat d = fromIntegerNat $ cast d

-- Generate all factors for a given number
factors : Nat -> List Nat
factors (S Z) = [(S Z)]
factors n = assert_total $ lows ++ (reverse $ map (div n) lows)
    where lows = filter ((== 0) . modNat n) [1..doubleToNat .floor . sqrt $ cast n]

-- Get all factors of the largest dimension in
-- the given Vector
factorsV : Array (x::xs) t -> List Nat
factorsV {x} _ = factors x

-- Generate all factor pairs of a given natural number
factorPairs : Nat -> List (Nat, Nat)
factorPairs n = assert_total $ map (\f => (f, div n f)) fs
  where fs = factors n

-- Sacrificing totality for functionality, split an Array into a higher
-- dimension
partial
splitA2 : (n : Nat) -> Array (x::xs) t -> Array (n :: div x n :: xs) t
splitA2 n xs {x} = split' n (div x n) (toList xs)
  where
        partial
        getN : (n : Nat) -> List t -> Vect n t
        getN Z l = []
        getN (S n) (x::xs) = x::(getN n xs)

        partial
        split' : (m : Nat) -> (n : Nat) -> List t -> Vect m (Vect n t)
        split' Z _ _ = []
        split' (S m) n xs = (getN n xs)::(split' m n (drop n xs))

infixr 5 !!;
partial
(!!) : {a : Type} -> List a -> Nat -> a
(x::xs) !! Z = x
(x::xs) !! (S n) = xs !! n

-- Split an array by the nth factor of its highest dimension,
-- returns a Sigma Type containing the given factor with the split array
partial
splitNFactor: (n : Nat) -> Array (x::xs) t -> (f : Nat ** Array (f :: div x f :: xs) t)
splitNFactor n xs {x} = (f ** (splitA2 f xs))
  where f = factors x !! n

-- Generate all possible vector combinations using the factors of the highest
-- dimension of the given vector, returns a list of sigma values containing the
-- largest dimension of each split array along with the split array itself
partial
splitFactors : Array (x::xs) t -> List (f : Nat ** Array (f :: div x f :: xs) t)
splitFactors xs {x} = map (\f => (f ** splitA2 f xs)) (factors x)

partial
convertFactors : (f ** Array (f :: div x f :: xs) t) -> (ys ** Array ys t)
convertFactors (f ** ys) {x} {xs} = assert_total $ ((f :: div x f :: xs) ** ys)

partial
splitFactorsGeneric : Array (x::xs) t -> List (ys ** Array ys t)
splitFactorsGeneric xs = map convertFactors $ splitFactors xs

toVect : Array (x::xs) t -> Vect x (Array xs t)
toVect = id

fromVect : Vect n t -> Array [n] t
fromVect = id

partial
printVect : (Show t) => Vect xs t -> IO()
printVect xs = do
  print "[ "
  mapM_ (\x => print x >>= \_ => print " ") xs
  print "]"

partial
printArr : (Show t) => Array xs t -> IO ()
printArr vs {t} = printArr' vs >>= \_ => putStrLn ""
  where
    printArr' : (Show t) => Array xs t -> IO ()
    printArr' v {xs=[]} = print v >>= \_ => putStr ""
    printArr' v {xs = (y::ys)} = do
      putStr "["
      case v of
        [] => putStr ""
        (a::as) => do
          mapM_ (\x => printArr' x >>= \_ => putStr ",") $ init (a::as)
          printArr' (last (a::as))

      putStr "]"

partial
printSigmaArr : (Show t) => (xs ** Array xs t) -> IO ()
printSigmaArr v {t} with (v)
  | (xs ** vs) = printArr vs {t}

partial
printArrs : (Show t) => List (xs ** Array xs t) -> IO ()
printArrs vs {t} = mapML_ (\v => printSigmaArr v {t}) vs


module SC

-- import Data.Stream

{-
interface Comonad (w : Type -> Type) where
  extract   : w a -> a
  duplicate : w a -> w (w a)

Comonad Stream where
  extract   (x :: _)  = x
  duplicate (x :: xs) = (x :: xs) :: duplicate xs
-}

data Cofree : (Type -> Type) -> Type -> Type where
  (::) : a -> Inf (f (Cofree f a)) -> Cofree f a

Functor f => Functor (Cofree f) where
  map f (x :: xs) = f x :: map (map f) xs

duplicate : (Functor f) => Cofree f a -> Cofree f (Cofree f a)
duplicate (x :: xs) = (x :: xs) :: map duplicate xs

pure : Cofree f a -> a
pure (x :: _) = x

(>>=) : (Functor f) => Cofree f a -> (Cofree f a -> b) -> Cofree f b
w >>= g = map g (duplicate w)

extend : (Functor f) => (Cofree f a -> b) -> (Cofree f a) -> Cofree f b
extend g w = map g (duplicate w)

data Id a = MkId a

Functor Id where
  map f (MkId x) = MkId (f x)

Strm : Type -> Type
Strm = Cofree Id

iterate : (f : a -> a) -> (x : a) -> Strm a
iterate f x = x :: MkId (iterate f (f x))

zeros : Strm Int
zeros = 0 :: MkId zeros

test : Strm Int
test = do
  x <- zeros
  pure x

data Cofree : (Type -> Type) -> Type -> Type where
  (::) : a -> Inf (f (Cofree f a)) -> Cofree f a

data ZP a = MkZP a a
data MV = L | R

Functor ZP where
  map f (MkZP x y) = MkZP (f x) (f y)

browsing : (forall b . f b -> i -> b) -> Cofree f a -> List i -> a
browsing idx (a :: as) []        = a
browsing idx (a :: as) (k :: ks) = browsing idx (idx as k) ks

Zipper : Type -> Type
Zipper = Cofree ZP

move : ZP a -> MV -> a
move (MkZP l r) L = l
move (MkZP l r) R = r

moves : List MV -> Zipper a -> Zipper a
moves m = extend (\x => browsing move x m)

-- https://chrispenner.ca/posts/representable-cofree-zippers
-- moveLeft : Zipper a -> Zipper a


-- Minimal implicational logic, PHOAS approach, initial encoding

module Pi.ArrMp

%default total

-- Types

infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc a

-- Terms

infixl 1 :$
data Tm : Cx -> Ty -> Type where
  var  : isTrue a tc                -> Tm tc a
  lam' : (isTrue a tc -> Tm tc b)   -> Tm tc (a :=> b)
  (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b

lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

syntax "lam" {a} ":=>" [b] = lam'' (\a => b)

Thm : Ty -> Type
Thm a = {tc : Cx} -> Tm tc a

-- Example theorems

aI : Thm (a :=> a)
aI =
  lam x :=> x

aK : Thm (a :=> b :=> a)
aK =
  lam x :=>
    lam y :=> x

aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c)
aS =
  lam f :=>
    lam g :=>
      lam x :=> f :$ x :$ (g :$ x)

tSKK : Thm (a :=> a)
tSKK {a} =
  aS {b = a :=> a} :$ aK :$ aK


import Data.Nat
import Data.Vect

myReverse1 : Vect n a -> Vect n a
myReverse1 [] = []
myReverse1 {n = S k} (x :: xs)
        = let result = myReverse1 xs ++ [x] in
              rewrite plusCommutative 1 k in result

myReverse : Vect n a -> Vect n a
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x])
  where
    reverseProof : Vect (k + 1) a -> Vect (S k) a
    reverseProof {k} result = rewrite plusCommutative 1 k in result


import Data.Vect

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

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

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

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

--reverse fourInts

--map (\x => x+1) fourInts


-- ----------------------------------------------------------- [ DataTypes.idr ]
-- Module      : Chapter.DataTypes
-- Description : Definitions from Chapter 4 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.DataTypes

%access export

-- ------------------------------------------------------- [ 4.1.2 Union Types ]

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

%name Shape shape, shape1, shape2

namespace Shape

  ||| Calculate the area of a shape.
  area : Shape -> Double
  area (Triangle base  height)  = 0.5 * base * height
  area (Rectangle width height) = width * height
  area (Circle radius)          = pi * radius * radius

-- --------------------------------------------------- [ 4.1.3 Recursive Types ]

public export
data Picture = ||| A primitive shape.
               Primitive Shape
             | ||| A combination of two other pictures.
               Combine Picture Picture
             | ||| A picture rotated through an angle.
             Rotate Double Picture
             | ||| A picture translated to a different location.
             Translate Double Double Picture

%name Picture pic, pic1, pic2

namespace Picture

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

-- ------------------------------------------------ [ 4.1.4 Generic Data Types ]

||| A binary search tree.
public export
data Tree elem = ||| A tree with no data.
                 Empty
               | ||| A node with a left subtree, a value, and a right subtree.
                 Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

||| Insert a value into a binary search tree.
||| @ x a value to insert
||| @ tree a binary search tree to insert into
insert : Ord elem => (x : elem) -> (tree : Tree elem) -> Tree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
       = case compare x val of
              LT => Node (insert x left) val right
              EQ => orig
              GT => Node left val (insert x right)

-- --------------------------------------------------------------------- [ EOF ]


module Grover

import Data.Nat
import Data.Vect
import Decidable.Equality
import Unitary
import Injection
import LinearTypes
import Lemmas
import Control.Linear.LIO
import QStateT
import AlterningBitsOracle
import QuantumOp

%default total

|||GROVER'S ALGORITHM
|||1. Start with |0> ¤ n
|||2. Apply H ¤ n
|||3. Grover iteration
|||   3.1 : Apply oracle
|||   3.2 : Apply H ¤ n
|||   3.3 : Amplification
|||   3.4 : Apply H ¤ n

------------- AMPLIFICATION-------------

public export total
amplification : (n : Nat) -> Unitary n
amplification 0 = IdGate
amplification 1 = IdGate
amplification (S k) =
  let x = tensorn (S k) (X 0 IdGate)
      h1 = H k {prf = lemmaLTSucc k} x
      c = multipleQubitControlledNOT (S k) . h1
      h2 = H k {prf = lemmaLTSucc k} c
  in x . h2

---------------GROVER ITERATION--------------

public export total
groverIteration : (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> Unitary (n + p)
groverIteration n oracle =
  let h = tensorn n (H 0 IdGate)
  in (h # IdGate) . (amplification n # IdGate) . (h # IdGate) . oracle

public export total
repeatGroverIteration : (k : Nat) -> (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> Unitary (n + p)
repeatGroverIteration 0 n _ = IdGate
repeatGroverIteration (S k) n oracle = (groverIteration n oracle) . (repeatGroverIteration k n oracle)

----------------GROVER'S ALGORITHM------------------

xhAncilla : (p : Nat) -> Unitary p
xhAncilla 0 = IdGate
xhAncilla (S p) = let xh = (H 0 IdGate) . (X 0 IdGate) in rewrite sym $ lemmaplusOneRight p in IdGate # xh

hxAncilla : (p : Nat) -> Unitary p
hxAncilla 0 = IdGate
hxAncilla (S p) = let xh = (X 0 IdGate) . (H 0 IdGate) in rewrite sym $ lemmaplusOneRight p in IdGate # xh

public export total
grover' : (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> (nbIter : Nat) -> Unitary (n + p)
grover' n oracle nbIter =
  let h = (tensorn n (H 0 IdGate)) # xhAncilla p
  in (IdGate # hxAncilla p) . (repeatGroverIteration nbIter n oracle) . h

public export total
grover : QuantumOp t =>
         (n : Nat) -> {p : Nat} -> (oracle : Unitary (n + p)) -> (nbIter : Nat) -> IO (Vect n Bool)
grover n oracle nbIter = do
    let circuit = grover' n oracle nbIter
    w <- run (do
                 q <- newQubits {t=t} (n + p)
                 q <- applyUnitary q circuit
                 v <- measureAll q
                 pure v
                 )
    pure (take n w)

--------------------------SMALL TEST---------------------------

--Example with the alternating bits oracle

public export
testGrover : IO (Vect 4 Bool)
testGrover =
  grover {t = SimulatedOp} 4 {p = 1} (solve 2) 1

public export
testG : (nbIter : Nat) -> IO (Vect 3 Nat)
testG 0 = pure [0,0,0]
testG (S k) = do
  [a,b,c] <- testG k
  v <- testGrover
  case v of
       [True,False,True,False] => pure [S a,b,c]
       [False,True,False,True] => pure [a,S b,c]
       _ => pure [a,b,S c]


module Quantities.FreeAbelianGroup

import Quantities.Power

%default total
%access public export

mergeWithBy : (k -> k -> Ordering) -> (v -> v -> v) ->
              List (k, v) -> List (k, v) -> List (k, v)
mergeWithBy _ _ [] ys = ys
mergeWithBy _ _ xs [] = xs
mergeWithBy order combine ((k1, v1) :: xs) ((k2, v2) :: ys) = let o = order k1 k2 in
  if o == LT then (k1, v1) :: mergeWithBy order combine xs ((k2, v2) :: ys)
  else if o == GT then (k2, v2) :: mergeWithBy order combine ((k1, v1) :: xs) ys
  else (k1, combine v1 v2) :: mergeWithBy order combine xs ys

mergeWith : Ord k => (v -> v -> v) ->
            List (k, v) -> List (k, v) -> List (k, v)
mergeWith = mergeWithBy compare

filterValues : (v -> Bool) -> List (k, v) -> List (k, v)
filterValues p = filter (p . snd)

mapValue : (v -> w) -> List (k, v) -> List (k, w)
mapValue f = map (\(k, v) => (k, f v))

data FreeAbGrp : Type -> Type where
  MkFreeAbGrp : {a : Type} -> (List (a, Integer)) -> FreeAbGrp a

mkFreeAbGrp : Ord a => List (a, Integer) -> FreeAbGrp a
mkFreeAbGrp = MkFreeAbGrp . filterValues (\x => x /= 0)
                          . foldr (\x => mergeWith (+) [x]) []

unit : FreeAbGrp a
unit = MkFreeAbGrp []

implicit
inject : a -> FreeAbGrp a
inject x = MkFreeAbGrp [(x, 1)]

freeAbGrpPower : FreeAbGrp a -> Integer -> FreeAbGrp a
freeAbGrpPower _ 0 = unit
freeAbGrpPower (MkFreeAbGrp xs) i = MkFreeAbGrp $ mapValue (i*) xs

freeAbGrpInverse : FreeAbGrp a -> FreeAbGrp a
freeAbGrpInverse x = freeAbGrpPower x (-1)

infixl 6 <<+>>
(<<+>>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
(MkFreeAbGrp xs) <<+>> (MkFreeAbGrp ys) = MkFreeAbGrp $ filterValues (\x => x /= 0) $ mergeWithBy compare (+) xs ys

implementation Eq a => Eq (FreeAbGrp a) where
  (MkFreeAbGrp xs) == (MkFreeAbGrp ys) = xs == ys

implementation Ord a => Ord (FreeAbGrp a) where
  compare (MkFreeAbGrp xs) (MkFreeAbGrp ys) = compare xs ys

implementation [freeabgrppower] Power (FreeAbGrp a) where
  (^) = freeAbGrpPower

implementation Ord a => Semigroup (FreeAbGrp a) where
  (<+>) = (<<+>>)

implementation Ord a => Monoid (FreeAbGrp a) where
  neutral = unit

implementation Ord a => Group (FreeAbGrp a) where
  inverse = freeAbGrpInverse

implementation Ord a => AbelianGroup (FreeAbGrp a) where

-- Lift a function A -> G to a group homomorphism between the freely generated
-- abelian group of A to the group G.
lift : (Group g, Power g) => (a -> g) -> FreeAbGrp a -> g
lift f (MkFreeAbGrp xs) = concatMap (\(x, i) => ((f x) ^ i)) xs

inject_lift_lem : (Group g, Power g) => (f : a -> g) -> (x : a) -> lift f (inject x) = f x
inject_lift_lem f x = really_believe_me (Refl {x=(lift f (inject x))})

lift_power_lem : (Group g, Power g, Ord a) => (f : a -> g) -> (x : FreeAbGrp a) ->
                 (i : Integer) -> lift f (x ^ i) = lift f x ^ i
lift_power_lem f x i = really_believe_me (Refl {x=(lift f (x ^ i))})

lift_mult_lem : (Ord a, Group g, Power g) => (f : a -> g) -> (x : FreeAbGrp a) ->
                (y : FreeAbGrp a) -> lift f (x <+> y) = lift f x <+> lift f y
lift_mult_lem f x y = really_believe_me (Refl {x=(lift f (x <+> y))})

freeabgrppower_correct : (Ord a) => (x : FreeAbGrp a) -> (i : Integer) -> freeAbGrpPower x i = (^) x i
freeabgrppower_correct x i = really_believe_me (Refl {x=(freeAbGrpPower x i)})


import Data.List.Views

list1: List Int
list1 = [1,2,3]

data ListLast: List a -> Type where
  Empty: ListLast []
  NonEmpty: (xs: List a) -> (x: a) -> ListLast (xs ++ [x])

total listLast: (xs: List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) = case listLast xs of
  Empty => NonEmpty [] x
  (NonEmpty ys y) => NonEmpty (x :: ys) y

total describeHelper: (input: List Int) -> (form: ListLast input) -> String
describeHelper []          Empty           = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x) = "NonEmpty - All but one: " ++ show xs

total describeListEnd: List Int -> String
describeListEnd xs with (listLast xs)
  describeListEnd []          | Empty           = "Empty!"
  describeListEnd (ys ++ [x]) | (NonEmpty ys x) = "Non-empty :) All but last: " ++ show ys

myReverse: List a -> List a
myReverse input with (listLast input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs

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

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

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

total mergeSort2: Ord a => List a -> List a
mergeSort2 input with (splitRec input)
  mergeSort2 []   | SplitRecNil = []
  mergeSort2 [x]  | SplitRecOne = [x]
  mergeSort2 (lefts ++ rights) | (SplitRecPair lrec rrec) =
    merge (mergeSort2 lefts  | lrec)
          (mergeSort2 rights | rrec)

example: List Int
example = [6,5,4,3,3,1,3,7,3,4,5,1,2,1,2,4,6,9,6]


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

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

insert_helper : Ord a => (x : a) -> Tree a -> Tree a
insert_helper x t = insert x t

listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = let inserted = listToTree xs  in
                         insert_helper x inserted

treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node left x right) = let leftList  = (treeToList left)
                                     rightList = x :: treeToList right
                                     in leftList ++ rightList

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node left value right) = let leftFold = foldr func acc left
                                               rightFold = foldr func leftFold right in
                                               func value rightFold


{-
data Nat = Z | S Nat

plus : Nat -> Nat -> Nat
plus Z y = y
plus (S x) y = S (plus x y)
-}

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

%name Vect xs, ys, zs

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

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

create_empties : Vect m (Vect 0 elem)
create_empties {m = Z} = []
create_empties {m = (S k)} = [] :: create_empties

transpose_helper : (row : Vect m elem) -> (rest_trans : Vect m (Vect k elem)) ->
                   Vect m (Vect (S k) elem)
transpose_helper [] [] = []
transpose_helper (rowval :: xs) (restrow :: ys) = (rowval :: restrow) :: transpose_helper xs ys

transpose_vec : Vect n (Vect m elem) -> Vect m (Vect n elem)
transpose_vec [] = create_empties
transpose_vec (row :: rest) = let rest_trans = transpose_vec rest in
                                  transpose_helper row rest_trans

------- A main program to read dimensions, generate and tranpose a vector

implementation Functor (Vect m) where
    map m [] = []
    map m (x :: xs) = m x :: map m xs

implementation Show a => Show (Vect m a) where
    show x = show (toList x)
      where
        toList : Vect m a -> List a
        toList [] = []
        toList (y :: xs) = y :: toList xs

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

mkVect : (n, m : Nat) -> Vect n (Vect m Int)
mkVect Z m = []
mkVect (S k) m = countTo m :: map (map (+ cast m)) (mkVect k m)

main : IO ()
main = do putStr "Rows: "
          let r : Nat = 5
          putStr "Columns: "
          let c : Nat = 6
          printLn (mkVect r c)
          putStrLn "Transposed:"
          printLn (transpose_vec (mkVect r c))


> module BoundedNat.BoundedNat

> import Sigma.Sigma

> %default total

> %access public export

> ||| Natural numbers bounded by LT
> LTB : Nat -> Type
> LTB b = Sigma Nat (\ n  => LT n b)

> ||| Natural numbers bounded by LTE
> LTEB : Nat -> Type
> LTEB b = Sigma Nat (\ n  => LTE n b)


||| The cardinal directions
data Direction = North
               | East
               | South
               | West

total turn : Direction -> Direction
turn North = East
turn East = South
turn South = West
turn West = North

||| A Shape
data Shape = ||| A triangle
             Triangle Double Double
           | ||| A rectangle
             Rectangle Double Double
           | ||| A circle
             Circle Double

total area : Shape -> Double
area (Triangle x y) = 0.5 * x * y
area (Rectangle x y) = x * y
area (Circle x) = pi * x * x

||| A shape defined as a type function
data Shape' : Type where
  Triangle' : Double -> Double -> Shape'
  Rectangle' : Double -> Double -> Shape'
  Circle' : Double -> Shape'

data Nat = Z | S Nat

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


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

%name Vect xs, ys, zs

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


checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (num1 = num2)
checkEqNat 0 0 = Just Refl
checkEqNat 0 (S k) = Nothing
checkEqNat (S k) 0 = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              Just prf => Just (cong S prf)

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

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


module xquant.Core.Spectrum

import public xquant.Core.Types
import public xquant.Core.NonZero
import Data.Matrix.Algebraic

%default total

data SysType = Finite Nat | Infinite

||| Spectrum – list of energies – for
||| a finite-dimensional system
data FSpectrum : Nat -> Type where
  FSpect : Vect n Fl -> FSpectrum n

||| Finite system degeneracy, i.e.,
||| state multiplicity by energy level
data FDegen : Nat -> Type where
  FDeg : {v : Vect n Nat} -> NVect v -> FDegen n

size : FDegen n -> Nat
size (FDeg {v} _) = sum v

rep : FDegen n -> Type
rep fd = StateSpace (size fd) Amp

data FSystem : Nat -> Type where
  FSys : (fd : FDegen n) ->
         FSpectrum n ->
         rep fd ->
         FSystem n

||| Infinite system spectrum
data ISpectrum = ISpect (Nat -> Fl)

||| Infinite system degeneracy
||| (state multiplicity by energy level)
data IDegen : Type where
  IDeg : (Nat -> NonZ) -> IDegen


module VecSort

import Data.Vect

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

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

-- Exercises
my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = S (my_length xs)

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

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

my_map2 : (a -> b) -> Vect n a -> Vect n b  -- why doesn't this overload?
my_map2 f [] = []
--my_map2 f (x :: xs) = ?my_map2_rhs_2  -- <leader>o to search and...
my_map2 f (x :: xs) = f x :: my_map2 f xs  -- BOOM!


module xquant.Spinor.Gamma

import xquant.Core.Types
import public Data.Matrix.Algebraic
import public Control.Algebra.NumericInstances
import public Data.Complex

%default total

-- Begin with two primative Gamma matrices, Γ0 and Γ1, generating Spin(2)

|||  Γ0 = iσy
g0 : Matrix 2 2 (Complex Integer)
g0 = [[c0, c1], [m1, c0]]

|||  Γ1 = σx
g1 : Matrix 2 2 (Complex Integer)
g1 = [[c0, c1], [c1, c0]]

{- Construct gammas for even-dimensional spinor representations (D = 2k + 2)
   First tensor as follows:

      G^μ    = Γ^mu <&> diag(-1,1),  (where mu <- [0..D-2])  or equivalently,
      G^μ    = Γ^mu <&> (g1 <> g0)

   Then adding two new gammas:

      G^{D-1} = Id <&> Γ1    = Id ⊗ σx
      G^D     = Id <&> -iΓ0  = Id ⊗ σy  -}

|||  Gamma matrices for even dimensions D = 2k + 2, with size 2^(k+1)
gammaEven : (k : Nat) -> Vect (k*2 + 2) $ Matrix (power 2 (S k)) (power 2 (S k)) (Complex Integer)
gammaEven Z      = [g0, g1]
gammaEven (S k) ?= {Lemma_1} map (\g => g <&> (g1 <> g0)) (gammaEven k) ++ [Id <&> g1, mi <#> Id <&> g0]

{- Matrices defined in this way satisy the gamma matrix algebra:

     {Γμ,Γν} = 2 η{μν} Id   (upstairs indices)

   They also furnish Poincaré generators   Σ^{μν} = −i[Γ^μ,Γ^ν]
   satisfying, by definition:   i[Σμν,Σσρ] = ηνσΣμρ + ημρΣνσ − ηνρΣμσ − ημσΣνρ

   This holds in any dimensionality and in both Minkowski and Euclidean signatures.

   Now define the "fifth Gamma Matrix", denoted Γ  -}

||| The "fifth gamma matrix" given by
|||
||| Γ = i^{–k} (Γ^0 ... Γ^{D-1})
|||
||| forms an odd-dimensional (irriducible) spinor representation by adding to the appropriate (gammaEven k)
gamma : Vect (k*2+2) $ Matrix (power 2 $ S k) (power 2 $ S k) (Complex Integer) ->
        Matrix (power 2 $ S k) (power 2 $ S k) (Complex Integer)
gamma {k} gs = (pow' mi k) <#> (product' gs)

{- Γ has eigenvalues of ±1 and satisfies:

     Γ^2 = 1
     {Γ,Γ^μ} = 0
     [Γ,Σ^{μν}] = 0  -}

g3 : Matrix 2 2 (Complex Integer)
g3 = product' $ with List [g0,g1]

{-
||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_00 : (g0 >><< g0) = ((-2 :+ 0) <#> Id)
D2_anticommRelation_00 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_01 : g0 >><< g1 = [neutral, neutral]
D2_anticommRelation_01 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_10 : g1 >><< g0 = [neutral, neutral]
D2_anticommRelation_10 = Refl

||| Anticommutation relation, {Γμ,Γν} = 2 η{μν} Id, for D = 2
D2_anticommRelation_11 : g1 >><< g1 = (2 :+ 0) <#> Id
D2_anticommRelation_11 = Refl
-}

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

multTwoRightPlusTimesOne : (n : Nat) -> mult n 2 = n + (mult n 1)
multTwoRightPlusTimesOne = proof
  intros
  rewrite (multRightSuccPlus n (S Z))
  trivial

multTwoRightPlus : (n : Nat) -> n * 2 = plus n n
multTwoRightPlus = proof
  intros
  rewrite (sym $ multTwoRightPlusTimesOne n)
  rewrite (sym $ multOneRightNeutral n)
  trivial

plusPlusZero : (x,y : Nat) -> x + y = x + (y + 0)
plusPlusZero = proof
  intros
  rewrite (sym $ plusZeroRightNeutral y)
  trivial

Lemma_1 = proof
  intros
  rewrite (plusZeroRightNeutral (plus (mult k 2) 2))
  rewrite (sym $ plusSuccRightSucc (plus (mult k 2) 2) 0)
  rewrite (sym $ plusSuccRightSucc (plus (mult k 2) 2) 1)
  rewrite (sym $ plusZeroRightNeutral (power 2 k))
  rewrite (sym $ plusZeroRightNeutral (power 2 k + (power 2 k)))
  rewrite (multTwoRightPlus (plus (power 2 k) (power 2 k)))
  rewrite (sym $ plusPlusZero (power 2 k) (power 2 k))
  trivial


module Data.InSet

import Data.Bool
import Data.Bool.Xor

import public Data.InSet.Equality

import Decidable.Equality

%default total

---------------------
---------------------
---               ---
---  DEFINITIONS  ---
---               ---
---------------------
---------------------

infix 6 ==
infix 7 `isin`, `notin`
infixl 8 +, -, ^
infixl 9 *, #

-------------------
--- Type itself ---
-------------------

public export
InSet : Type -> Type
InSet a = a -> Bool

-- TODO To think, maybe equality relation should be shown in the `InSet` type as a parameter?
--      However, if this is only in the append operation, this gives an ability to union sets with different equalities.

------------------------------------
--- Intesional test of existence ---
------------------------------------

export
isin : a -> InSet a -> Bool
isin = flip apply

public export %inline
notin : a -> InSet a -> Bool
notin x y = not $ isin x y

----------------
--- Creation ---
----------------

--- Syntax for list-like literals ---

public export
Nil : InSet a
Nil _ = False

public export
(::) : Equality a => a -> InSet a -> InSet a
(::) added parent x = if x =?= added then True else x `isin` parent

--- Constants

public export %inline
Empty : InSet a
Empty = []

public export
Universe : InSet a
Universe _ = True

---------------------------
--- Basic set relations ---
---------------------------

public export
(==) : InSet a -> InSet a -> Type
sa == sb = (x : a) -> x `isin` sa = x `isin` sb

public export
(<=) : InSet a -> InSet a -> Type
sa <= sb = (x : a) -> x `isin` sa = True -> x `isin` sb = True

public export
NotEmpty : {a : Type} -> InSet a -> Type
NotEmpty s = (x ** x `isin` s = True)

----------------------------
--- Basic set operations ---
----------------------------

export
(+) : InSet a -> InSet a -> InSet a -- union
(+) sa sb x = x `isin` sa || x `isin` sb

export
(#) : InSet a -> InSet a -> InSet a -- intersection
(#) sa sb x = x `isin` sa && x `isin` sb

export
(-) : InSet a -> InSet a -> InSet a -- set difference
(-) sa sb x = x `isin` sa && x `notin` sb

export
(^) : InSet a -> InSet a -> InSet a -- symmetrical difference
(^) sa sb x = (x `isin` sa) `xor` (x `isin` sb)

export %inline
complement : InSet a -> InSet a
complement s x = x `notin` s

------------------------------------
--- Non-algebraic set operations ---
------------------------------------

export
(*) : InSet a -> InSet b -> InSet (a, b)
(*) sx sy (x, y) = x `isin` sx && y `isin` sy

--------------
--------------
---        ---
---  LAWS  ---
---        ---
--------------
--------------

------------------------
--- Laws of equality ---
------------------------

export
eq_reflexivity : (0 s : InSet a) -> s == s
eq_reflexivity _ _ = Refl

export
eq_symmerty : {0 sa, sb : InSet a} -> (0 _ : sa == sb) -> sb == sa
eq_symmerty f x = rewrite f x in Refl

export
eq_transitivity : {0 sa, sb, sc : InSet a} -> (0 _ : sa == sb) -> (0 _ : sb == sc) -> sa == sc
eq_transitivity f g x = rewrite f x in
                        rewrite g x in
                        Refl

-- Definition above can be written as
--   sa <= sb = (x : a) -> So (x `isin` sa) -> So (x `isin` sb)
-- but this leads to constant using `soToEq` and `eqToSo` in proofs.

--- Negative equality-related laws ---

trueNotFalse : Not (True = False)
trueNotFalse Refl impossible

export
non_empty_is_not_empty : NotEmpty s -> Not (s = Empty)
non_empty_is_not_empty (x ** prf_t) prf_f = trueNotFalse $ rewrite sym prf_t in rewrite prf_f in Refl

export
non_empty_not_eq_empty : NotEmpty s -> Not (s == Empty)
non_empty_not_eq_empty (x ** prf_t) prf_f = trueNotFalse $ rewrite sym prf_t in rewrite prf_f x in Refl

export
cant_in_and_not_in : (s : InSet a) -> (x : a) -> Not (x `isin` s = x `notin` s)
cant_in_and_not_in s x prf with (s x)
  cant_in_and_not_in _ _ Refl | True impossible

-------------------------------
--- Laws of subset relation ---
-------------------------------

--- Order laws of subset relation ---

export
subset_equal : {0 sa, sb : InSet a} -> (0 _ : sa == sb) -> sa <= sb
subset_equal f x prf = rewrite sym $ f x in
                       rewrite prf in
                       Refl

export
subset_reflexivity : (0 s : InSet a) -> s <= s
subset_reflexivity _ _ = id

export
subset_antisymmetry : {sa, sb : InSet a} -> sa <= sb -> sb <= sa -> sa == sb
subset_antisymmetry f g x with (decEq (sa x) True)
  subset_antisymmetry f _ x | Yes pa with (decEq (sb x) True)
    subset_antisymmetry _ _ _ | Yes pa | Yes pb = rewrite pa in
                                                  rewrite pb in
                                                  Refl
    subset_antisymmetry f _ x | Yes pa | No nb = absurd . nb $ f x pa
  subset_antisymmetry _ g x | No pa with (decEq (sb x) True)
    subset_antisymmetry _ _ _ | No na | No nb = rewrite notTrueIsFalse na in
                                                rewrite notTrueIsFalse nb in
                                                Refl
    subset_antisymmetry _ g x | No na | Yes pb = absurd . na $ g x pb

export
subset_transitivity : {0 sa, sb, sc : InSet a} -> (0 _ : sa <= sb) -> (0 _ : sb <= sc) -> sa <= sc
subset_transitivity f g x y = rewrite g x (f x y) in Refl

-- Subset relation's totality seems to be unprovable for intensional sets neither in
--   `Either (sa <= sb) (sb <= sa)`, nor in `Not $ sa <= sb => sb <= sa` variant.

--- Alternative subset representations with unions and intersections ---

export
subset_thru_union : {sa, sb : InSet a} -> (0 _ : sa <= sb) -> sa + sb == sb
subset_thru_union f x with (decEq (sa x) True)
  subset_thru_union f x | Yes pa = rewrite pa in
                                   rewrite f x pa in
                                   Refl
  subset_thru_union _ _ | No na = rewrite notTrueIsFalse na in Refl

export
union_thru_subset : {0 sa, sb : InSet a} -> (0 _ : sa + sb == sb) -> sa <= sb
union_thru_subset f x y = rewrite sym $ f x in
                          rewrite y in
                          Refl

export
subset_thru_intersection : {sa, sb : InSet a} -> (0 _ : sa <= sb) -> sa # sb == sa
subset_thru_intersection f x with (decEq (sa x) True)
  subset_thru_intersection f x | Yes pa = rewrite pa in
                                          rewrite f x pa in
                                          Refl
  subset_thru_intersection _ _ | No na = rewrite notTrueIsFalse na in Refl

export
intersection_thru_subset : {0 sa, sb : InSet a} -> (0 _ : sa # sb == sa) -> sa <= sb
intersection_thru_subset f x pa = rewrite sym pa in
                                  rewrite sym $ f x in
                                  rewrite pa in
                                  Refl

--- Subset with binary set operations ---

export
subset_for_unioned_right : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> sa <= sb + sc
subset_for_unioned_right sc f x prf = rewrite f x prf in Refl

and_true_left_true : (a, b : Bool) -> a && b = True -> a = True
and_true_left_true True _ _ = Refl

export
subset_for_intersected_left : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> (sa # sc) <= sb
subset_for_intersected_left sc f x prf = rewrite f x $ and_true_left_true (sa x) (sc x) prf in Refl

export
subset_for_diffed_left : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> (sa - sc) <= sb
subset_for_diffed_left sc f x prf = rewrite f x $ and_true_left_true (sa x) (x `notin` sc) prf in Refl

-- Particular cases for the properties from above, where `sb = sa`

export
subset_refl_unioned_right : (0 sa, sc : InSet a) -> sa <= sa + sc
subset_refl_unioned_right sa sc = subset_for_unioned_right sc $ subset_reflexivity sa

export
subset_refl_intersected_left : (0 sa, sc : InSet a) -> (sa # sc) <= sa
subset_refl_intersected_left sa sc = subset_for_intersected_left sc $ subset_reflexivity sa

export
subset_refl_diffed_left : (0 sa, sc : InSet a) -> (sa - sc) <= sa
subset_refl_diffed_left sa sc = subset_for_diffed_left sc $ subset_reflexivity sa

--- Subset with complement ---

export
subset_of_complements : {0 sa, sb : InSet a} -> (0 _ : sa <= sb) -> complement sb <= complement sa
subset_of_complements f x prf = rewrite sym $ subset_thru_intersection f x in
                                rewrite the (sb x = False) $ rewrite sym $ notInvolutive $ sb x in cong not prf in
                                rewrite andFalseFalse $ sa x in
                                Refl

export
subset_of_complements_back : {0 sa, sb : InSet a} -> (0 _ : complement sb <= complement sa) -> sa <= sb
subset_of_complements_back f x prf = rewrite sym $ subset_of_complements f x (rewrite notInvolutive $ sa x in prf) in
                                     rewrite notInvolutive $ sb x in
                                     Refl

--------------------------------------------------
--- Congruence of relations in specializations ---
--------------------------------------------------

--- Append ---

export
append_eq_cong_l : Equality a => (0 s : InSet a) -> {0 n, m : a} -> (0 _ : n = m) -> n::s == m::s
append_eq_cong_l _ prf _ = rewrite prf in Refl

export
append_eq_cong_r : Equality a => {0 sa, sb : InSet a} -> (n : a) -> (0 _ : sa == sb) -> n::sa == n::sb
append_eq_cong_r n f x with (x =?= n)
  append_eq_cong_r _ _ _ | True = Refl
  append_eq_cong_r _ f x | False = rewrite f x in Refl

--- Union ---

export
union_eq_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa == sb) -> sa + sc == sb + sc
union_eq_cong_l _ f x = rewrite f x in Refl

export
union_eq_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa == sb) -> sc + sa == sc + sb
union_eq_cong_r _ f x = rewrite f x in Refl

-- particular case for `append_eq_cong_l`
export
union_singleton_eq_cong_l : Equality a => (0 s : InSet a) -> {0 n, m : a} -> (0 _ : n = m) -> [n] + s == [m] + s
union_singleton_eq_cong_l _ prf x = rewrite append_eq_cong_l [] prf x in Refl

-- TODO to add for subset

--- Intersection ---

-- TODO to add for equality

-- TODO to add for subset

--- Difference ---

-- TODO to add for equality

-- TODO to add for subset

--- Symmetrical difference ---

-- TODO to add for equality

-- TODO to add for subset

--- Complement ---

-- TODO to add for equality

-- TODO to add for subset

--- Cartesian product ---

export
cart_eq_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa == sb) -> sc * sa == sc * sb
cart_eq_cong_l _ f (_, y) = rewrite f y in Refl

export
cart_eq_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa == sb) -> sa * sc == sb * sc
cart_eq_cong_r _ f (x, _) = rewrite f x in Refl

and_true_then_left_true : (a : Bool) -> {b : Bool} -> a && b = True -> a = True
and_true_then_left_true True {b=True} Refl = Refl

and_true_then_right_true : {a : Bool} -> (b : Bool) -> a && b = True -> b = True
and_true_then_right_true {a=True} True Refl = Refl

export
cart_subset_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa <= sb) -> sc * sa <= sc * sb
cart_subset_cong_l sc f (y, x) prf = rewrite f x $ and_true_then_right_true _ prf in
                                     rewrite and_true_then_left_true (sc y) prf in
                                     Refl

export
cart_subset_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa <= sb) -> sa * sc <= sb * sc
cart_subset_cong_r sc f (x, y) prf = rewrite f x $ and_true_then_left_true _ prf in
                                     rewrite and_true_then_right_true (sc y) prf in
                                     Refl

----------------------
--- Laws of `isin` ---
----------------------

export
not_in_empty : Equality a => (0 x : a) -> x `isin` [] = False
not_in_empty _ = Refl

export
x_in_x_etc : Equality a => (0 x : a) -> (0 s : InSet a) -> x `isin` (x::s) = True
x_in_x_etc x s = rewrite equ_reflexive x in Refl

export
x_in_same_etc : Equality a => (0 x, y : a) -> (0 s : InSet a) -> (0 _ : x =?= y = True) -> x `isin` (y::s) = True
x_in_same_etc _ _ _ prf = rewrite prf in Refl

export
not_x_not_in_x_etc : Equality a => (x, y : a) -> NeqPrf x y -> x `isin` [y] = False
not_x_not_in_x_etc x y neq = case @@(x =?= y) of
  (False ** prf) => rewrite prf in Refl
  (True ** prf) => absurd $ cant_eq_neq (eq_val_to_prf prf) neq

export
not_in_both : Equality a => (0 x, y : a) -> (0 ys : InSet a) -> (0 _ : x =?= y = False) -> (0 _ : x `isin` ys = False) -> x `isin` (y::ys) = False
not_in_both x y ys xy xys = rewrite xy in
                            rewrite xys in
                            Refl

export
is_in_tail : Equality a => (0 x, y : a) -> (0 ys : InSet a) -> (0 _ : x =?= y = False) -> (0 _ : x `isin` (y::ys) = True) -> x `isin` ys = True
is_in_tail _ _ _ xy xyys = rewrite sym xyys in
                           rewrite xy in
                           Refl

----------------------
--- Laws of append ---
----------------------

export
append_is_union : Equality a => (n : a) -> (0 s : InSet a) -> n::s == [n] + s
append_is_union n _ x with (x =?= n)
  append_is_union _ _ _ | True = Refl
  append_is_union _ _ _ | False = Refl

---------------------
--- Laws of union ---
---------------------

export
union_of_self : (0 s : InSet a) -> s + s == s
union_of_self s x = rewrite orSameNeutral $ s x in Refl

export
union_commutative : (0 sa, sb : InSet a) -> sa + sb == sb + sa
union_commutative sa sb x = rewrite orCommutative (sa x) (sb x) in Refl

export
union_associative : (0 sa, sb, sc : InSet a) -> sa + (sb + sc) == (sa + sb) + sc
union_associative sa sb sc x = rewrite orAssociative (sa x) (sb x) (sc x) in Refl

export
union_empty_neutral : (0 s : InSet a) -> s + [] == s
union_empty_neutral s x = rewrite orFalseNeutral $ s x in Refl

export
union_preserves_universe : (0 s : InSet a) -> s + Universe == Universe
union_preserves_universe s x = rewrite orTrueTrue $ s x in Refl

-- ... with intersection

export
union_distributes_over_intersection : (0 sa, sb, sc : InSet a) -> sa + (sb # sc) == (sa + sb) # (sa + sc)
union_distributes_over_intersection sa sb sc x = rewrite orDistribAndR (sa x) (sb x) (sc x) in Refl

-- ... with diff

export
union_with_diff : (0 sa, sb, sc : InSet a) -> sa + (sb - sc) == (sa + sb) - (sc - sa)
union_with_diff sa sb sc x = rewrite orDistribAndR (sa x) (sb x) (not $ sc x) in
                             rewrite notAndIsOr (sc x) (not $ sa x) in
                             rewrite notInvolutive $ sa x in
                             rewrite orCommutative (sa x) (not $ sc x) in
                             Refl

-- ... with symdiff

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
union_thru_symdiff_and_intersection : (sa, sb : InSet a) -> sa + sb == (sa ^ sb) ^ (sa # sb)
union_thru_symdiff_and_intersection sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

-- ... with complement

export
union_with_its_complement : (0 s : InSet a) -> s + complement s == Universe
union_with_its_complement s x = rewrite orNotTrue $ s x in Refl

----------------------------
--- Laws of intersection ---
----------------------------

export
intersection_of_self : (0 s : InSet a) -> s # s == s
intersection_of_self s x = rewrite andSameNeutral $ s x in Refl

export
intersection_commutative : (0 sa, sb : InSet a) -> sa # sb == sb # sa
intersection_commutative sa sb x = rewrite andCommutative (sa x) (sb x) in Refl

export
intersection_associative : (0 sa, sb, sc : InSet a) -> sa # (sb # sc) == (sa # sb) # sc
intersection_associative sa sb sc x = rewrite andAssociative (sa x) (sb x) (sc x) in Refl

export
intersection_universe_neutral : (0 s : InSet a) -> s # Universe == s
intersection_universe_neutral s x = rewrite andTrueNeutral $ s x in Refl

export
intersection_preserves_empty : (0 s : InSet a) -> s # [] == []
intersection_preserves_empty s x = rewrite andFalseFalse $ s x in Refl

-- ... with union

export
intersection_distributes_over_union : (0 sa, sb, sc : InSet a) -> sa # (sb + sc) == (sa # sb) + (sa # sc)
intersection_distributes_over_union sa sb sc x = rewrite andDistribOrR (sa x) (sb x) (sc x) in Refl

-- ... with set diff

export
intersection_diff_swap : (0 sa, sb, sc : InSet a) -> sa # (sb - sc) == sb # (sa - sc)
intersection_diff_swap sa sb sc x = rewrite andAssociative (sa x) (sb x) (not $ sc x) in
                                    rewrite andAssociative (sb x) (sa x) (not $ sc x) in
                                    rewrite andCommutative (sa x) (sb x) in
                                    Refl

export
intersection_diff_assoc : (0 sa, sb, sc : InSet a) -> sa # (sb - sc) == (sa # sb) - sc
intersection_diff_assoc sa sb sc x = rewrite sym $ andAssociative (sa x) (sb x) (not $ sc x) in Refl

-- ... with symmetrical diff

-- TODO To make this functon to have `(0 sa, sb, sc : InSet a)` in the signature.
export
intersection_distributes_over_symdiff : (sa, sb, sc : InSet a) -> sa # (sb ^ sc) == (sa # sb) ^ (sa # sc)
intersection_distributes_over_symdiff sa sb sc x = case decEq (sa x) True of
  Yes pa => rewrite pa in Refl
  No na => rewrite notTrueIsFalse na in Refl

-- ... with complement

export
intersection_with_complement : (0 sa, sb : InSet a) -> sa # complement sb == sa - sb
intersection_with_complement _ _ _ = Refl

export
intersection_with_its_complement : (0 s : InSet a) -> s # complement s == []
intersection_with_its_complement s x = rewrite andNotFalse $ s x in Refl

------------------------------
--- Laws of set difference ---
------------------------------

export
diff_of_intersection : (0 sa, sb, sc : InSet a) -> sc - (sa # sb) == (sc - sa) + (sc - sb)
diff_of_intersection sa sb sc x = rewrite notAndIsOr (sa x) (sb x) in
                                  rewrite andDistribOrR (sc x) (not $ sa x) (not $ sb x) in
                                  Refl

export
diff_of_union : (0 sa, sb, sc : InSet a) -> sc - (sa + sb) == (sc - sa) # (sc - sb)
diff_of_union sa sb sc x = rewrite notOrIsAnd (sa x) (sb x) in
                           rewrite andAssociative (sc x && not (sa x)) (sc x) (not $ sb x) in
                           rewrite sym $ andAssociative (sc x) (not $ sa x) (sc x) in
                           rewrite andCommutative (not $ sa x) (sc x) in
                           rewrite andAssociative (sc x) (sc x) (not $ sa x) in
                           rewrite andSameNeutral $ sc x in
                           rewrite andAssociative (sc x) (not $ sa x) (not $ sb x) in
                           Refl

export
diff_of_diff : (0 sa, sb, sc : InSet a) -> sc - (sb - sa) == (sc # sa) + (sc - sb)
diff_of_diff sa sb sc x = rewrite notAndIsOr (sb x) (not $ sa x) in
                          rewrite notInvolutive $ sa x in
                          rewrite orCommutative (not $ sb x) (sa x) in
                          rewrite andDistribOrR (sc x) (sa x) (not $ sb x) in
                          Refl

export
diff_of_self : (0 s : InSet a) -> s - s == []
diff_of_self s x = rewrite andNotFalse $ s x in Refl

export
diff_of_empty_left : (0 s : InSet a) -> [] - s == []
diff_of_empty_left _ _ = Refl

export
diff_of_empty_right : (0 s : InSet a) -> s - [] == s
diff_of_empty_right s x = rewrite andTrueNeutral $ s x in Refl

export
diff_of_universe : (0 s : InSet a) -> s - Universe == []
diff_of_universe s x = rewrite andFalseFalse $ s x in Refl

export
diff_of_complements : (0 sa, sb : InSet a) -> complement sa - complement sb == sb - sa
diff_of_complements sa sb x = rewrite andCommutative (sb x) (not $ sa x) in
                              rewrite notInvolutive $ sb x in
                              Refl

--------------------------------------
--- Laws of symmetrical difference ---
--------------------------------------

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
symdiff_as_union_of_diffs : (sa, sb : InSet a) -> sa ^ sb == (sa - sb) + (sb - sa)
symdiff_as_union_of_diffs sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
symdiff_as_diff_of_ui : (sa, sb : InSet a) -> sa ^ sb == (sa + sb) - (sa # sb)
symdiff_as_diff_of_ui sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

export
symdiff_commutative : (0 sa, sb : InSet a) -> sa ^ sb == sb ^ sa
symdiff_commutative sa sb x = rewrite xorCommutative (sa x) (sb x) in Refl

export
symdiff_associative : (0 sa, sb, sc : InSet a) -> sa ^ (sb ^ sc) == (sa ^ sb) ^ sc
symdiff_associative sa sb sc x = rewrite xorAssociative (sa x) (sb x) (sc x) in Refl

export
symdiff_with_empty : (0 s : InSet a) -> s ^ [] == s
symdiff_with_empty s x = rewrite xorCommutative (s x) False in
                         rewrite xorFalseNeutral $ s x in
                         Refl

export
symdiff_with_self : (0 s : InSet a) -> s ^ s == []
symdiff_with_self s x = rewrite xorSameFalse $ s x in Refl

-- TODO To make this functon to have `(0 sa, sb, sc : InSet a)` in the signature.
export
symdiff_twice_negates : (sa, sb, sc : InSet a) -> (sa ^ sb) ^ (sb ^ sc) == sa ^ sc
symdiff_twice_negates sa sb sc x = rewrite xorCommutative (sa x) (sb x) in
                                   case decEq (sb x) True of
                                     Yes pb => rewrite pb in
                                               rewrite xorTrueNot $ sa x in
                                               rewrite xorTrueNot $ sc x in
                                               rewrite notXorCancel (sa x) (sc x) in
                                               Refl
                                     No nb => rewrite notTrueIsFalse nb in
                                              rewrite xorFalseNeutral $ sa x in
                                              rewrite xorFalseNeutral $ sc x in
                                              Refl

export
symdiff_of_complements : (0 sa, sb : InSet a) -> sa ^ sb == complement sa ^ complement sb
symdiff_of_complements sa sb x = rewrite notXorCancel (sa x) (sb x) in Refl

--------------------------
--- Laws of complement ---
--------------------------

export
comp_of_union : (0 sa, sb : InSet a) -> complement (sa + sb) == complement sa # complement sb
comp_of_union sa sb x = rewrite notOrIsAnd (sa x) (sb x) in Refl

export
comp_of_intersection : (0 sa, sb : InSet a) -> complement (sa # sb) == complement sa + complement sb
comp_of_intersection sa sb x = rewrite notAndIsOr (sa x) (sb x) in Refl

export
comp_of_empty : complement [] == Universe
comp_of_empty _ = Refl

export
comp_of_universe : complement Universe == []
comp_of_universe _ = Refl

export
comp_involutive : (0 s : InSet a) -> complement (complement s) == s
comp_involutive s x = rewrite notInvolutive $ s x in Refl

export
comp_of_diff : (0 sa, sb : InSet a) -> complement (sa - sb) == complement sa + sb
comp_of_diff sa sb x = rewrite notAndIsOr (sa x) (not $ sb x) in
                       rewrite notInvolutive $ sb x in
                       Refl

---------------------------------
--- Laws of cartesian product ---
---------------------------------

--- Operations over cartesian products at both sides:

export
intersection_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) # (sb * sd) == (sa # sb) * (sc # sd)
intersection_of_carts sa sb sc sd (x, y) = rewrite sym $ andAssociative (sa x) (sc y) (sb x && sd y) in
                                           rewrite sym $ andAssociative (sa x) (sb x) (sc y && sd y) in
                                           rewrite andAssociative (sc y) (sb x) (sd y) in
                                           rewrite andAssociative (sb x) (sc y) (sd y) in
                                           rewrite andCommutative (sb x) (sc y) in
                                           Refl

export
diff_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) - (sb * sd) == sa * (sc - sd) + (sa - sb) * sc

export
union_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) + (sb * sd) == ((sa - sb) * sc) # ((sa # sb) * (sc + sd)) # ((sb - sa) * sd)

--- Distributivity:

export
cart_distributes_over_intersection : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb # sc) == (sa * sb) # (sa * sc)
cart_distributes_over_intersection sa sb sc (x, y) = rewrite sym $ andAssociative (sa x) (sb y) (sa x && sc y) in
                                                     rewrite andAssociative (sb y) (sa x) (sc y) in
                                                      rewrite andCommutative (sb y) (sa x) in
                                                     rewrite sym $ andAssociative (sa x) (sb y) (sc y) in
                                                     rewrite andAssociative (sa x) (sa x) (sb y && sc y) in
                                                      rewrite andSameNeutral (sa x) in
                                                     Refl

export
cart_distributes_over_union : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb + sc) == (sa * sb) + (sa * sc)

export
cart_distributes_over_diff : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb - sc) == (sa * sb) - (sa * sc)

export
complement_of_cart : (0 sa : InSet a) -> (0 sb : InSet b) -> complement (sa * sb) = (complement sa * complement sb) + (complement sa * sb) + (sa * complement sb)

--- Cartesian products with relations

export
subset_of_carts_drops_l : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : NotEmpty sa) -> (0 _ : NotEmpty sc) ->
                          (0 _ : (sa * sc) <= (sb * sd)) -> sa <= sb

export
subset_of_carts_drops_r : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : NotEmpty sa) -> (0 _ : NotEmpty sc) ->
                          (0 _ : (sa * sc) <= (sb * sd)) -> sc <= sd

export
cart_of_subsets : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : sa <= sb) -> (0 _ : sc <= sd) -> (sa * sc) <= (sb * sd)


import Data.Vect

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

{-
transposeHelper : (x : Vect n elem)
               -> (xTrans : Vect n (Vect k elem))
               -> Vect n (Vect (S k) 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 xTrans = transposeMat xs in
                             zipWith (::) x xTrans

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

addMatrix' : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix' mat1 mat2 = zipWith (zipWith (+)) mat1 mat2

(+) : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
(+) = addMatrix

-- Exercise 3
multVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a
multVecs xs ys = sum (zipWith (*) xs ys)

makeRow : Num a => (x : Vect n a)
                -> (ysTrans : Vect p (Vect n a))
                -> Vect p a
makeRow x [] = []
makeRow x (y :: xs) = multVecs x y :: makeRow x xs

multMatrixHelper : Num a => (xs : Vect m (Vect n a))
                         -> (ysTrans : Vect p (Vect n a))
                         -> Vect m (Vect p a)
multMatrixHelper [] ysTrans = []
multMatrixHelper (x :: xs) ysTrans
     = makeRow x ysTrans :: multMatrixHelper xs ysTrans

multMatrix : Num a => Vect m (Vect n a)
                   -> Vect n (Vect p a)
                   -> Vect m (Vect p a)
multMatrix xs ys = let ysTrans = transposeMat ys
                   in  multMatrixHelper xs ysTrans


import Data.Vect

-- Defining functions by pattern matching
invert : Bool -> Bool
invert True = False
invert False = True

describeList : List Int -> String
describeList [] = "Empty"
describeList (x :: xs) = "Non-empty, tail = " ++ show xs

-- Given just the type declaration below, can use Ctrl-Alt-A in Atom to add a
-- definition.
allLengths_list : List String -> List Nat
-- allLengths_list list = ?rhs -- put the cursor on list and do ctrl-alt-c in
-- Atom to expand the cases as below:
-- allLengths_list [] = ?rhs_1
-- allLengths_list (x :: xs) = ?rhs_2
allLengths_list [] = []
allLengths_list (x :: xs) = length x :: allLengths_list xs
-- Check if allLengths_list is total
-- :total allLengths_list -> Main.allLengths_list is Total

allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (word :: words) = 0 :: allLengths words

-- :doc List pulls up the documentation for List.
-- In Atom, ctrl-alt-D

-- Data types are defined in terms of their constructors, a bit like Java enum
-- members but often with parameters.

-- mutual lets you define functions that call each other, otherwise Idris
-- requires everything to be top-down.

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

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

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

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

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

insert : Ord elem => (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: ys) = if (x < y) then (x :: y :: ys) else (y :: insert x ys)

insertSort : (Ord elem) => Vect n elem -> Vect n elem
insertSort [] = []
insertSort (x :: xs) = insert x (insertSort xs)

my_length : List a -> Nat
my_length [] = Z
my_length (x :: xs) = S (my_length xs)

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

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

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

-- total makes sure it won't compile if it's not total, total meaning every
-- scenario is accounted for.

-- I struggled with this, something about two-dimensional arrays seems to cause
-- me problems. Transposing means taking the top row, transposing the rest
-- recursively, then prefixing each transposed row with the values from the top
-- row to form a new column.

-- Ctrl-Alt-T in Atom to find types, only works on the right hand side.
-- Ctrl-Alt-A to add missing cases
-- Ctrl-Alt-C to split out a case by destructuring a particular variable
-- Ctrl-Alt-S to do an expression search, if the type is specific enough it
-- can fill in a right hand side.

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

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

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

-- Exercise 1 - reimplement using zipWith

total transposeMat_zipWith : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat_zipWith [] = replicate _ []
transposeMat_zipWith (x :: xs) = zipWith (::) x (transposeMat_zipWith xs)

-- Exercise 2

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

-- Exercise 3

-- [1 2]     [ 7  8  9 10]   [1*7 + 2*11 = 29] -- sum(row 1 * column 1)
-- [3 4]  x  [11 12 13 14] =
-- [5 6]

-- Transposing:
-- [1 2]     [ 7 11]   [1*7 + 2*11, 1*8 + 2*12, 1*9 + 2*13, 1*10 + 2*14]
-- [3 4]  x  [ 8 12] = [3*7 + 4*11, 3*8 + 4*12, 3*9 + 4*13, 3*10 + 4*14]
-- [5 6]     [ 9 13]   [5*7 + 6*11, 5*8 + 6*12, 5*9 + 6*13, 5*10 + 6*14]
--           [10 14]

multMatrix : Num a => Vect n (Vect m a) -> Vect m (Vect p a) -> Vect n (Vect p a)
multMatrix xs ys = multHelper xs (transposeMat_zipWith ys)
  where
    sumOneRow : Num a => Vect m a -> Vect m a -> a
    sumOneRow xs ys = sum (zipWith (*) xs ys)

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

-- Implicit values: _ means infer the value.
-- Implicit parameters: {param: Type} means infer the parameter.

vect_length : Vect n elem -> Nat
vect_length {n} xs = n -- {n} brings the argument into scope

createEmpties_inferred : Vect n (Vect 0 a)
createEmpties_inferred {n = Z} = []
createEmpties_inferred {n = (S k)} = [] :: createEmpties


module NewEden.Natural

import Prelude.Either
import public Prelude.Uninhabited

import public NewEden.Algebra
import public NewEden.NaturalAxioms
import public NewEden.NaturalPropertiesHelpers -- compiler bug #144; can't use private in types

{- Natural

   Natural p is a natural number expressed in terms of operations on a given
   set of NaturalProperties p.

   Everything else in this module is expressing the axioms given in
   NaturalProperties in terms of operations on Natural p, so now
   we can use Natural p much the same as we would the 'normal' numeric types.
-}

data Natural : NaturalProperties t -> Type where
  MkNatural : (n:NaturalProperties t) -> (a:t) -> Natural n

value : {p:NaturalProperties t} -> Natural p -> t
value {p} (MkNatural p x) = x

properties : {p:NaturalProperties t} -> Natural p -> NaturalProperties t
properties (MkNatural p _) = p

(+) : {p:NaturalProperties t} -> Natural p -> Natural p -> Natural p
(+) {p} (MkNatural p x) (MkNatural p y) =
  MkNatural p $ privatePlus p x y

(*) : {p:NaturalProperties t} -> Natural p -> Natural p -> Natural p
(*) {p} (MkNatural p x) (MkNatural p y) =
  MkNatural p $ privateMultiply p x y

{- fromInteger

   This is the first place we see the real power of an axiomatic implementation.
   Here we are able to construct arbitrary natural numbers and put them in the
   compiler's head in *logarithmic* space (rather than linear space, like the Peano Nat).
-}

fromInteger : Integer -> Natural p
fromInteger rem =
  let z = MkNatural p (zero p) in
  let o = MkNatural p (one p) in
  case rem of
    0 => z
    1 => o
    _ =>
         case (assert_total $ prim__sremBigInt rem 2) of
           0 => (o + o) * (assert_total $ fromInteger (prim__sdivBigInt rem 2))
           1 => o + (assert_total $ fromInteger (prim__subBigInt rem 1))
           _ => o -- impossible

-- force resolution of 0 to Natural p, since occasionally 0 is
-- ambiguous (e.g., right below in zeroIsNotOne)
Z : (p:NaturalProperties t) -> Natural p
Z p = 0

zeroIsNotOne : (p:NaturalProperties t) -> (Z p = 1 -> Void)
zeroIsNotOne p =
  let prf = NewEden.NaturalPropertiesHelpers.privateZeroIsNotOne p in
  (\given => prf $ equalityMap value given)

plusCommutative : (p:NaturalProperties t) -> CommutativeFunction (Natural p) (+)
plusCommutative p =
  let (MkCommutativeFunction _ prf) = NewEden.NaturalPropertiesHelpers.privatePlusCommutative p in
  MkCommutativeFunction
    (+)
    (\(MkNatural p x),(MkNatural p y) => equalityMap (MkNatural p) $ prf x y)

plusAssociative : (p:NaturalProperties t) -> AssociativeFunction (Natural p) (+)
plusAssociative p =
  let (MkMonoid af _ _ _) = NewEden.NaturalPropertiesHelpers.privatePlusMonoid p in
  let (MkAssociativeFunction _ prf) = af in
  MkAssociativeFunction
    (+)
    (\(MkNatural p x),(MkNatural p y),(MkNatural p z) => equalityMap (MkNatural p) $ prf x y z)

plusMonoid : (p:NaturalProperties t) -> NewEden.Algebra.Monoid (Natural p) (+) 0
plusMonoid P =
  let (MkMonoid _ _ p1 p2) = NewEden.NaturalPropertiesHelpers.privatePlusMonoid P in
  MkMonoid
    (plusAssociative P)
    (Z P)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p1 x)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p2 x)

plusLacksInverses : (p:NaturalProperties t) -> StrictMonoid $ NewEden.Natural.plusMonoid p
plusLacksInverses P =
  let (MkStrictMonoid _ prf) = NewEden.NaturalPropertiesHelpers.privatePlusLacksInverses P in
  MkStrictMonoid
    (plusMonoid P)
    (\(MkNatural P x),(MkNatural P y),given =>
      let given' = equalityMap value $ given in
      equalityMap (MkNatural P) $ prf x y given'
    )

plusMonomorphic : (p:NaturalProperties t) -> ((n:Natural p) -> MonomorphicFunction $ (+) n)
plusMonomorphic p =
  let g = NewEden.NaturalPropertiesHelpers.privatePlusMonomorphic p in
  (\(MkNatural p x) =>
    let (MkMonomorphicFunction _ prf) = g x in
    MkMonomorphicFunction
      ((+) (MkNatural p x))
      (\(MkNatural p y),(MkNatural p z),given =>
        equalityMap (MkNatural p) $ prf y z (equalityMap value given)
      )
  )

multiplyCommutative : (p:NaturalProperties t) -> CommutativeFunction (Natural p) (*)
multiplyCommutative p =
  let (MkCommutativeFunction _ prf) = NewEden.NaturalPropertiesHelpers.privateMultiplyCommutative p in
  MkCommutativeFunction
    (*)
    (\(MkNatural p x),(MkNatural p y) => equalityMap (MkNatural p) $ prf x y)

multiplyAssociative : (p:NaturalProperties t) -> AssociativeFunction (Natural p) (*)
multiplyAssociative p =
  let (MkMonoid af _ _ _) = NewEden.NaturalPropertiesHelpers.privateMultiplyMonoid p in
  let (MkAssociativeFunction _ prf) = af in
  MkAssociativeFunction
    (*)
    (\(MkNatural p x),(MkNatural p y),(MkNatural p z) => equalityMap (MkNatural p) $ prf x y z)

multiplyMonoid : (p:NaturalProperties t) -> NewEden.Algebra.Monoid (Natural p) (*) 1
multiplyMonoid P =
  let (MkMonoid _ _ p1 p2) = NewEden.NaturalPropertiesHelpers.privateMultiplyMonoid P in
  MkMonoid
    (multiplyAssociative P)
    1
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p1 x)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p2 x)

multiplyLacksInverses : (p:NaturalProperties t) -> StrictMonoid $ NewEden.Natural.multiplyMonoid p
multiplyLacksInverses P =
  let (MkStrictMonoid _ prf) = NewEden.NaturalPropertiesHelpers.privateMultiplyLacksInverses P in
  MkStrictMonoid
    (multiplyMonoid P)
    (\(MkNatural P x),(MkNatural P y),given =>
      let given' = equalityMap value $ given in
      equalityMap (MkNatural P) $ prf x y given'
    )

multiplyMonomorphic : (p:NaturalProperties t) -> ((n:Natural p) -> MonomorphicFunction $ (*) n)
multiplyMonomorphic p =
  let g = NewEden.NaturalPropertiesHelpers.privateMultiplyMonomorphic p in
  (\(MkNatural p x) =>
    let (MkMonomorphicFunction _ prf) = g x in
    MkMonomorphicFunction
      ((*) (MkNatural p x))
      (\(MkNatural p y),(MkNatural p z),given =>
        equalityMap (MkNatural p) $ prf y z (equalityMap value given)
      )
  )

multiplyByZeroIsZero : (p:NaturalProperties t) -> ((a:(Natural p)) -> a * 0 = 0)
multiplyByZeroIsZero P =
  let prf = NewEden.NaturalPropertiesHelpers.privateMultiplyByZero P in
  (\(MkNatural P x) => equalityMap (MkNatural P) $ prf x)

multiplyDistributive : (p:NaturalProperties t) -> ((a:Natural p) -> (b:Natural p) -> (c:Natural p) -> a * (b + c) = (a * b) + (a * c))
multiplyDistributive p =
  let prf = NewEden.NaturalPropertiesHelpers.privateDistributiveProperty p in
  (\(MkNatural p x),(MkNatural p y),(MkNatural p z) =>
    equalityMap (MkNatural p) $ prf x y z
  )

naturalNoNumbersBetweenZeroAndOne : (p:NaturalProperties t) -> ((a:Natural p) -> (b:Natural p) -> (p1:(a = 0 -> Void)) -> (p2: a + b = 1) -> a = 1)
naturalNoNumbersBetweenZeroAndOne P =
  let lemmaSequence = NewEden.NaturalPropertiesHelpers.privateSequenceProperty P in
  (\(MkNatural P x),(MkNatural P y),given1,given2 =>
    let given1' = (\lemma => given1 $ equalityMap (MkNatural P) lemma) in
    let given2' = equalityMap value given2 in
    equalityMap (MkNatural P) $ lemmaSequence x y given1' given2'
  )

data LessThan : (a:Natural p) -> (b:Natural p) -> Type where
  MkLessThan : (a:Natural p) -> (b:Natural p) -> (c ** ((a + c = b), (c = 0 -> Void))) -> LessThan a b

data Trichotomy : (a:Type) -> (b:Type) -> (c:Type) -> Type where
  Left : {a:Type} -> {b:Type} -> {c:Type} -> (x:a) -> Trichotomy a b c
  Middle : {a:Type} -> {b:Type} -> {c:Type} -> (x:b) -> Trichotomy a b c
  Right : {a:Type} -> {b:Type} -> {c:Type} -> (x:c) -> Trichotomy a b c

compare : ((a:Natural p) -> (b:Natural p) -> Trichotomy (LessThan a b) (a = b) (LessThan b a))
compare (MkNatural p x) (MkNatural p y) =
  let prf = NewEden.NaturalPropertiesHelpers.privateCompare p in
  case prf x y of
    Left h => Middle $ equalityMap (MkNatural p) h
    Right r => case r of
      Left (c**(h,prf')) =>
        let lt = MkLessThan (MkNatural p x) (MkNatural p y) in
        Left $ lt ((MkNatural p c) ** ((equalityMap (MkNatural p) h),
                  (\prf'' => prf' $ equalityMap value prf'')))
      Right (c**(r,prf')) =>
        let lt = MkLessThan (MkNatural p y) (MkNatural p x) in
        Right $ lt ((MkNatural p c) ** ((equalityMap (MkNatural p) r),(\prf'' => prf' $ equalityMap value prf'')))

(-) : (a:Natural p) -> (b:Natural p) -> {auto prf:((LessThan a b) -> Void)} -> Natural p
(-) {prf} a b = case compare a b of
  Left x => absurd (prf x)
  Middle _ => 0
  Right (MkLessThan _ _ (c ** _)) => c


-- Example of a union type.
||| Represents shapes.
data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its lengths and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

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