---
title: Logic
subtitle: An Idris port of Coq.Init.Logic
title-meta: "Logic: An Idris port of Coq.Init.Logic"
author:
- |
  \affaddr{Eric Bailey}\
  \affaddr{https://github.com/yurrriq}\
  \email{eric@ericb.me}
author-meta: Eric Bailey
abstract: Here I present an Idris port of the [`Coq.Init.Logic`](https://coq.inria.fr/library/Coq.Init.Logic.html) module from the Coq standard library.
keywords:
- logic
- coq
- idris
pandoc-minted:
  language: idris
---

> ||| An Idris port of Coq.Init.Logic
> module Logic
>
> import Data.Bifunctor
>
> %access export

= Propositional connectives

== Unit

`()` is the always true proposition ($\top$).

```idris
%elim data Unit = MkUnit
```

== Void

`Void` is the always false proposition ($\bot$).

```idris
%elim data Void : Type where
```

== Negation

`Not a`, written `~a`, is the negation of `a`.

> syntax "~" [x] = (Not x)

```idris
Not : Type -> Type
Not a = a -> Void
```

== Conjunction

`And a b`, written `(a, b)`, is the conjunction of `a` and `b`.

`Conj p q` is a proof of `(a, b)` as soon as `p` is a proof of `a` and `q` a proof of `b`.

`proj1` and `proj2` are first and second projections of a conjunction.

> syntax "(" [a] "," [b] ")" = (And a b)
>
> ||| The conjunction of `a` and `b`.
> data And : Type -> Type -> Type where
>      Conj : a -> b -> (a, b)
>
> implementation Bifunctor And where
>     bimap f g (Conj a b) = Conj (f a) (g b)
>
> ||| First projection of a conjunction.
> proj1 : (a, b) -> a
> proj1 (Conj a _) = a
>
> ||| Second projection of a conjunction.
> proj2 : (a, b) -> b
> proj2 (Conj _ b) = b

== Disjunction

`Either a b` is the disjunction of `a` and `b`.

```idris
data Either : Type -> Type -> Type where
     Left   : a -> Either a b
     Right  : b -> Either a b
```

== Biconditional

[Proof Wiki](https://proofwiki.org/wiki/Definition:Biconditional)

 <!-- $\varphi \vdash \psi$\ -->
 <!-- $\underline{\psi \vdash \varphi}$\ -->
 <!-- $\varphi \iff \psi$ -->

`iff a b`, written `a <-> b`, expresses the equivalence of `a` and `b`.

> infixl 9 <->
>
> ||| The biconditional is a *binary connective* that can be voiced:
> ||| *p* **if and only if** *q*.
> public export
> (<->) : Type -> Type -> Type
> (<->) a b = (a -> b, b -> a)

=== Biconditional is Reflexive

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Reflexive)

$\vdash \varphi \iff \varphi$

> ||| The biconditional operator is reflexive.
> iffRefl : a <-> a
> iffRefl = Conj id id

=== Biconditional is Transitive

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Transitive)

 <!-- \[ -->
 <!--   \begin{prooftree} -->
 <!--     \Hypo{ \varphi \iff \psi } -->
 <!--     \Hypo{ \psi \iff \chi } -->
 <!--     \Infer2 { \vdash \varphi \iff \chi } -->
 <!--   \end{prooftree} -->
 <!-- \] -->

> ||| The biconditional operator is transitive.
> iffTrans : (a <-> b) -> (b <-> c) -> (a <-> c)
> iffTrans (Conj ab ba) (Conj bc cb) =
>     Conj (bc . ab) (ba . cb)

=== Biconditional is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Biconditional_is_Commutative)

$\varphi \iff \psi \dashv\vdash \psi \iff \varphi$

or

$\vdash (\varphi \iff \psi) \iff (\psi \iff \varphi)$

> ||| The biconditional operator is commutative.
> iffSym : (a <-> b) -> (b <-> a)
> iffSym (Conj ab ba) = Conj ba ab

=== andIffCompatLeft

$\psi \iff \chi \dashv\vdash (\varphi \land \psi) \iff (\varphi \land \chi)$

> andIffCompatLeft : (b <-> c) -> ((a, b) <-> (a, c))
> andIffCompatLeft = bimap second second

=== andIffCompatRight

$\psi \iff \chi \dashv\vdash (\psi \land \varphi) \iff (\chi \land \varphi)$

> andIffCompatRight : (b <-> c) -> ((b, a) <-> (c, a))
> andIffCompatRight = bimap first first

=== orIffCompatLeft

$\psi \iff \chi \vdash (\varphi \lor \psi) \iff (\varphi \lor \chi)$

> orIffCompatLeft : (b <-> c) ->
>                   (Either a b <-> Either a c)
> orIffCompatLeft = bimap second second

=== orIffCompatRight

$\psi \iff \chi \vdash (\psi \lor \varphi) \iff (\chi \lor \varphi)$

> orIffCompatRight : (b <-> c) ->
>                    (Either b a <-> Either c a)
> orIffCompatRight = bimap first first

=== negVoid

$\neg \varphi \dashv\vdash \varphi \iff \bot$

or

$\vdash \neg \varphi \iff (\varphi \iff \bot)$

> negVoid : (~a) <-> (a <-> Void)
> negVoid = Conj (flip Conj void) proj1

=== andCancelLeft

 <!-- $\psi \implies \varphi$\ -->
 <!-- $\underline{\chi \implies \varphi}$\ -->
 <!-- $((\varphi \land \psi) \iff (\varphi \land \chi)) \iff (\psi \iff \chi)$ -->

> andCancelLeft : (b -> a) ->
>                 (c -> a) ->
>                 (((a, b) <-> (a, c)) <-> (b <-> c))
> andCancelLeft ba ca = Conj (bimap f g) andIffCompatLeft
>   where
>     f h b = proj2 . h $ Conj (ba b) b
>     g h c = proj2 . h $ Conj (ca c) c

=== andCancelRight

> andCancelRight : (b -> a) ->
>                  (c -> a) ->
>                  (((b, a) <-> (c, a)) <-> (b <-> c))
> andCancelRight ba ca = Conj (bimap f g) andIffCompatRight
>   where
>     f h b = proj1 . h $ Conj b (ba b)
>     g h c = proj1 . h $ Conj c (ca c)

=== Conjunction is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Commutation/Conjunction)

==== Formulation 1
$\varphi \land \psi \dashv\vdash \psi \land \varphi$

==== Formulation 2
$\vdash (\varphi \land \psi) \iff (\psi \land \varphi)$

==== Source

> ||| Conjunction is commutative.
> andComm : (a, b) <-> (b, a)
> andComm = Conj swap swap
>   where
>     swap : (p, q) -> (q, p)
>     swap (Conj p q) = Conj q p

=== Conjunction is Associative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Association/Conjunction)

==== Formulation 1
$(\varphi \land \psi) \land \chi \dashv\vdash \varphi \land (\psi \land \chi)$

==== Formulation 2
$\vdash ((\varphi \land \psi) \land \chi) \iff (\varphi \land (\psi \land \chi))$

==== Source

> ||| Conjunction is associative.
> andAssoc : ((a, b), c) <-> (a, (b, c))
> andAssoc = Conj f g
>   where
>     f abc@(Conj (Conj a b) c) = Conj a (first proj2 abc)
>     g abc@(Conj a (Conj b c)) = Conj (second proj1 abc) c

=== orCancelLeft

$(\psi \implies \neg \varphi) \implies (\chi \implies \neg \varphi) \implies (((\varphi \lor \psi) \iff (\varphi \lor \chi)) \iff (\psi \iff \chi))$

> orCancelLeft : (b -> ~a) ->
>                (c -> ~a) ->
>                ((Either a b <-> Either a c) <-> (b <-> c))
> orCancelLeft bNotA cNotA = Conj (bimap f g) orIffCompatLeft
>   where
>     f ef b = go (bNotA b) (ef (Right b))
>     g eg c = go (cNotA c) (eg (Right c))
>     go : (~a) -> Either a b -> b
>     go lf = either (void . lf) id

=== orCancelRight

 <!-- $\psi \vdash \neg \varphi$\ -->
 <!-- $\underline{\chi \vdash \neg \varphi}$\ -->
 <!-- $((\psi \lor \varphi) \iff (\chi \lor \varphi)) \iff (\psi \iff \chi)$ -->

> orCancelRight : (b -> ~a) ->
>                 (c -> ~a) ->
>                 ((Either b a <-> Either c a) <-> (b <-> c))
> orCancelRight bNotA cNotA = Conj (bimap f g) orIffCompatRight
>   where
>     f ef b = go (bNotA b) (ef (Left b))
>     g eg c = go (cNotA c) (eg (Left c))
>     go : (~p) -> Either q p -> q
>     go rf = either id (void . rf)

=== Disjunction is Commutative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Commutation/Disjunction)

$(\varphi \lor \psi) \iff (\psi \lor \varphi)$

> ||| Disjunction is commutative.
> orComm : Either a b <-> Either b a
> orComm = Conj mirror mirror

=== Disjunction is Associative

[Proof Wiki](https://proofwiki.org/wiki/Rule_of_Association/Disjunction)

$(\varphi \lor \psi) \lor \chi \vdash \varphi \lor (\psi \lor \chi)$

> ||| Disjunction is associative on the left.
> orAssocLeft : Either (Either a b) c -> Either a (Either b c)
> orAssocLeft = either (second Left) (pure . pure)

$\varphi \lor (\psi \lor \chi) \vdash (\varphi \lor \psi) \lor \chi$

> ||| Disjunction is associative on the right.
> orAssocRight : Either a (Either b c) -> Either (Either a b) c
> orAssocRight = either (Left . Left) (first Right)

==== Formulation 1
$(\varphi \lor \psi) \lor \chi \dashv\vdash \varphi \lor (\psi \lor \chi)$

==== Formulation 2
$\vdash ((\varphi \lor \psi) \lor \chi) \iff (\varphi \lor (\psi \lor \chi))$

==== Source

> ||| Disjunction is associative.
> orAssoc : Either (Either a b) c <-> Either a (Either b c)
> orAssoc = Conj orAssocLeft orAssocRight

=== iffAnd

$\varphi \iff \psi \vdash (\varphi \implies \psi) \land (\psi \implies \varphi)$

> iffAnd : (a <-> b) -> (a -> b, b -> a)
> iffAnd = id

=== iffAndTo

$\varphi \iff \psi \dashv\vdash (\varphi \implies \psi) \land (\psi \implies \varphi)$

or

$\vdash (\varphi \iff \psi) \iff ((\varphi \implies \psi) \land (\psi \implies \varphi))$

> iffToAnd : (a <-> b) <-> (a -> b, b -> a)
> iffToAnd = Conj id id


import Data.Vect

-- Page 160

-- Exercise 1
Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)

-- Exercise 2
data Format = Number Format
            | Str Format
            | Lit String Format
            | Ch Format
            | Dbl Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType (Ch fmt) = (c : Char) -> PrintfType fmt
PrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Ch fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Ch (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

-- Exercise 3
TupleVect : Nat -> Type -> Type
TupleVect Z e = ()
TupleVect (S k) e = (e, TupleVect k e)

-- test : TupleVect 4 Nat
-- test = (1,2,3,4,())

-- Page 180
-- See file `week7_1_p_180.idr`

-- Page 193

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

-- Exercise 1

Eq Shape where
  (==) (Triangle a b) (Triangle a' b') = (a == a' && b == b')
  (==) (Rectangle a b) (Rectangle a' b') = (a == a' && b == b')
  (==) (Circle r) (Circle r') = (r == r')
  (==) _ _ = False

-- Exercise 2

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

Ord Shape where
  compare s1 s2 = compare (area s1) (area s2)

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

-- Page 199

-- Exercise 1
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)

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

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

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

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

-- show (the (Expr _) (6 + 3 * 12))
-- show (the (Expr _) (6 * 3 + 12))

-- Exercise 2
(Eq num, Integral num, Neg num) => Eq (Expr num) where
    (==) x y = eval x == eval y

-- Exercise 3
(Integral num, Neg num) => Cast (Expr num) num where
  cast x = eval (x)

-- Page 206

-- Exercise 1
Functor Expr where
  map f (Val x) = Val (f x)
  map f (Add x y) = Add (map f x) (map f y)
  map f (Sub x y) = Sub (map f x) (map f y)
  map f (Mul x y) = Mul (map f x) (map f y)
  map f (Div x y) = Div (map f x) (map f y)

-- Exercise 2
-- See file `week7_1_p_206_ex_2.idr`


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

import Data.Vect

-- check that all functions are total
%default total

--
-- section 8.1
--

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

same_cons : {xs : List a} -> {ys : List a} ->
            xs = ys -> x :: xs = x :: ys
same_cons Refl = Refl

same_lists : {xs : List a} -> {ys : List a} ->
             x = y -> xs = ys -> x :: xs = y :: ys
same_lists Refl Refl = Refl

data ThreeEq : a -> b -> c -> Type where
  Same3 : ThreeEq n n n

-- for all three natural numbers,
-- if the three numbers are equal then their three successors are equal
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS z z z Same3 = Same3

-- > allSameS 2 3 2 Same3
-- (input):1:1-20:When checking an application of function Main.allSameS:
--         Type mismatch between
--                 ThreeEq n n n (Type of Same3)
--         and
--                 ThreeEq 2 3 2 (Expected type)
--
--         Specifically:
--                 Type mismatch between
--                         0
--                 and
--                         1
-- > allSameS 2 2 2 Same3
-- Same3 : ThreeEq 3 3 3

--
-- section 8.2
--

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m = rewrite sym (plusZeroRightNeutral m) in Refl
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in
                         rewrite plusSuccRightSucc m k in Refl

reverseProof_nil : Vect n1 a -> Vect (plus n1 0) a
reverseProof_nil {n1} xs = rewrite plusZeroRightNeutral n1 in xs

reverseProof_xs : Vect (S (plus n1 len)) a -> Vect (plus n1 (S len)) a
reverseProof_xs {n1} {len} xs = rewrite sym (plusSuccRightSucc n1 len) in xs

myReverse : Vect n a -> Vect n a
myReverse xs = reverse [] xs
  where
    reverse : Vect n a -> Vect m a -> Vect (n+m) a
    reverse acc [] = reverseProof_nil acc
    reverse acc (x :: xs) = reverseProof_xs (reverse (x :: acc) xs)

--
-- section 8.3
--

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

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

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


module Control.Algebra

infixl 6 <->
infixl 7 <.>

||| Sets equipped with a single binary operation that is associative, along with
||| a neutral element for that binary operation and inverses for all elements.
||| Must satisfy the following laws:
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
class Monoid a => Group a where
  inverse : a -> a

(<->) : Group a => a -> a -> a
(<->) left right = left <+> (inverse right)

||| Sets equipped with a single binary operation that is associative and
||| commutative, along with a neutral element for that binary operation and
||| inverses for all elements. Must satisfy the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
class Group a => AbelianGroup a where { }

||| Sets equipped with two binary operations, one associative and commutative
||| supplied with a neutral element, and the other associative, with
||| distributivity laws relating the two operations.  Must satisfy the following
||| laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
class AbelianGroup a => Ring a where
  (<.>) : a -> a -> a

||| Sets equipped with two binary operations, one associative and commutative
||| supplied with a neutral element, and the other associative supplied with a
||| neutral element, with distributivity laws relating the two operations.  Must
||| satisfy the following laws:
|||
||| +  Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Neutral for `<.>`:
|||     forall a,     a <.> unity     == a
|||     forall a,     unity <.> a     == a
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
class Ring a => RingWithUnity a where
  unity : a

||| Sets equipped with two binary operations – both associative, commutative and
||| possessing a neutral element – and distributivity laws relating the two
||| operations. All elements except the additive identity must have a
||| multiplicative inverse. Must satisfy the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Commutativity of `<+>`:
|||     forall a b,   a <+> b         == b <+> a
||| + Neutral for `<+>`:
|||     forall a,     a <+> neutral   == a
|||     forall a,     neutral <+> a   == a
||| + Inverse for `<+>`:
|||     forall a,     a <+> inverse a == neutral
|||     forall a,     inverse a <+> a == neutral
||| + Associativity of `<.>`:
|||     forall a b c, a <.> (b <.> c) == (a <.> b) <.> c
||| + Unity for `<.>`:
|||     forall a,     a <.> unity     == a
|||     forall a,     unity <.> a     == a
||| + InverseM of `<.>`, except for neutral
|||     forall a /= neutral,  a <.> inverseM a == unity
|||     forall a /= neutral,  inverseM a <.> a == unity
||| + Distributivity of `<.>` and `<+>`:
|||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)
|||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)
class RingWithUnity a => Field a where
  inverseM : (x : a) -> Not (x = Algebra.neutral) -> a

sum' : (Foldable t, Monoid a) => t a -> a
sum' = concat

product' : (Foldable t, RingWithUnity a) => t a -> a
product' = foldr (<.>) unity

pow' : RingWithUnity a => a -> Nat -> a
pow' _ Z     = unity
pow' x (S n) = x <.> pow' x n

-- XXX todo:
--   Structures where "abs" make sense.
--   Euclidean domains, etc.
--   Where to put fromInteger and fromRational?


module Equis.Regression.LeastSquares

import Solver
import Matrix.Numeric
import Data.Matrix.Numeric

%access private

||| Calculates a length-n vector of powers of some number, smallest power first.
|||
||| @ord the length of the vector to calculate
||| @x the number
powers : Num a => (ord : Nat) -> (x : a) -> Vect (S ord) a
powers ord x = reverse (powers' ord x) where
  ||| Calculates a length-n vector of powers of some number, largest power first.
  |||
  ||| @ord the length of the vector to calculate
  ||| @x the number
  powers' : (ord : Nat) -> (x : a) -> Vect (S ord) a
  powers' Z _ = 1
  powers' (S Z) x = [x, 1]
  powers' (S k) x = let y@(n :: _) = powers' k x in (n * x) :: y

||| Performs least-squares polynomial fitting on the given independent and dependent values, returning the resulting
||| coefficients.
|||
||| @ord the order of the polynomial
||| @ind the values of the independent variable
||| @dep the values of the dependent variable
export
leastSquares : Neg a => Fractional a => (ord : Nat) -> (ind : Vect (S n) a) -> (dep : Vect (S n) a) -> Vect (S ord) a
leastSquares ord ind dep = leastSquares' (map (powers ord) ind) dep where
  ||| Performs least-squares polynomial fitting on the given independent and dependent values, returning the resulting
  ||| coefficients.
  |||
  ||| @ind the values of the independent variable
  ||| @dep the values of the dependent variable
  leastSquares' : (ind : Matrix (S n) (S m) a) -> (dep : Vect (S n) a) -> Vect (S m) a
  leastSquares' ind dep = ((inverseGram ind) <> (transpose ind)) </> dep

||| Performs least-squares polynomial fitting on the given independent and dependent values, returning the resulting
||| function.
|||
||| @ord the order of the polynomial
||| @ind the values of the independent variable
||| @dep the values of the dependent variable
export
leastSquaresFn : (ord : Nat) -> (ind : Vect (S n) Double) -> (dep : Vect (S n) Double) -> (Double -> Double)
leastSquaresFn ord ind dep = (\i => sum (zipWith (*) (powers ord i) (leastSquares ord ind dep)))


||| A binary relation is a function of type (ty -> ty -> Type).
|||
||| A prominent example of a binary relation is LTE over Nat.
|||
||| This module defines some interfaces for describing properties of
||| binary relations. It also proves somes relations among relations.

module Control.Relation

%default total

||| A relation on ty is a type indexed by two ty values
public export
Rel : Type -> Type
Rel ty = ty -> ty -> Type

||| A relation is reflexive if x ~ x for every x.
public export
interface Reflexive ty rel where
  constructor MkReflexive
  reflexive : {x : ty} -> rel x x

||| A relation is transitive if x ~ z when x ~ y and y ~ z.
public export
interface Transitive ty rel where
  constructor MkTransitive
  transitive : {x, y, z : ty} -> rel x y -> rel y z -> rel x z

||| A relation is symmetric if y ~ x when x ~ y.
public export
interface Symmetric ty rel where
  constructor MkSymmetric
  symmetric : {x, y : ty} -> rel x y -> rel y x

||| A relation is antisymmetric if no two distinct elements bear the relation to each other.
public export
interface Antisymmetric ty rel where
  constructor MkAntisymmetric
  antisymmetric : {x, y : ty} -> rel x y -> rel y x -> x = y

||| A relation is dense if when x ~ y there is z such that x ~ z and z ~ y.
public export
interface Dense ty rel where
  constructor MkDense
  dense : {x, y : ty} -> rel x y -> (z : ty ** (rel x z, rel z y))

||| A relation is serial if for all x there is a y such that x ~ y.
public export
interface Serial ty rel where
  constructor MkSerial
  serial : {x : ty} -> (y : ty ** rel x y)

||| A relation is euclidean if y ~ z when x ~ y and x ~ z.
public export
interface Euclidean ty rel where
  constructor MkEuclidean
  euclidean : {x, y, z : ty} -> rel x y -> rel x z -> rel y z

||| A tolerance relation is reflexive and symmetric.
public export
interface (Reflexive ty rel, Symmetric ty rel) => Tolerance ty rel where

||| A partial equivalence is transitive and symmetric.
public export
interface (Transitive ty rel, Symmetric ty rel) => PartialEquivalence ty rel where

||| An equivalence relation is transitive, symmetric, and reflexive.
public export
interface (Reflexive ty rel, Transitive ty rel, Symmetric ty rel) => Equivalence ty rel where

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

||| Every reflexive relation is dense.
public export
Reflexive ty rel => Dense ty rel where
  dense {x} xy = (x ** (reflexive {x}, xy))

||| Every reflexive relation is serial.
public export
Reflexive ty rel => Serial ty rel where
  serial {x} = (x ** reflexive {x})

||| A transitive symmetric serial relation is reflexive.
public export
(Transitive ty rel, Symmetric ty rel, Serial ty rel) => Reflexive ty rel where
  reflexive {x} =
    let (y ** xy) = serial {x} in
      transitive {x} xy $ symmetric {x} xy

||| A reflexive euclidean relation is symmetric.
public export
[RES] (Reflexive ty rel, Euclidean ty rel) => Symmetric ty rel where
  symmetric {x} xy =
    euclidean {x} xy $ reflexive {x}

||| A reflexive euclidean relation is transitive.
public export
[RET] (Reflexive ty rel, Euclidean ty rel) =>
      Transitive ty rel using RES where
  transitive {rel} xy yz =
    symmetric {rel} $ euclidean {rel} yz $ symmetric {rel} xy

||| A transitive symmetrics relation is euclidean.
public export
[TSE] (Transitive ty rel, Symmetric ty rel) => Euclidean ty rel where
  euclidean {rel} xy xz =
    transitive {rel} (symmetric {rel} xy) xz

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

public export
Reflexive ty Equal where
  reflexive = Refl

public export
Symmetric ty Equal where
  symmetric xy = sym xy

public export
Transitive ty Equal where
  transitive xy yz = trans xy yz

public export
Euclidean ty Equal where
  euclidean = euclidean {rel = Equal} @{TSE}

public export
Tolerance ty Equal where

public export
PartialEquivalence ty Equal where

public export
Equivalence ty Equal where


||| Implementing `Decidable.Order.Strict` for `Data.Nat.LT`
module Data.Nat.Order.Strict

import Decidable.Order
import Decidable.Order.Strict
import Decidable.Equality
import Data.Nat
import Data.Nat.Order

export
irreflexiveLTE : (a : Nat) -> Not (a `LT` a)
irreflexiveLTE 0     z_lt_z impossible
irreflexiveLTE (S a) (LTESucc a_lt_a) = irreflexiveLTE a a_lt_a

export
StrictPreorder Nat LT where
  irreflexive = irreflexiveLTE
  transitive a b c a_lt_b b_lt_c = transitive {po = LTE} (S a) b c
                                             a_lt_b
                                             (transitive {po = LTE} b (S b) c
                                                (lteSuccRight (reflexive b))
                                                b_lt_c)

public export
decLT : (a, b : Nat) -> DecOrdering {lt = LT} a b
decLT 0       0   = DecEQ Refl
decLT 0     (S b) = DecLT (LTESucc LTEZero)
decLT (S a)  0    = DecGT (LTESucc LTEZero)
decLT (S a) (S b) = case decLT a b of
  DecLT a_lt_b => DecLT (LTESucc a_lt_b)
  DecEQ Refl   => DecEQ Refl
  DecGT b_lt_a => DecGT (LTESucc b_lt_a)

public export
StrictOrdered Nat LT where
  order = decLT


-- vim: set ft=idris sw=2 ts=2:
--
-- perfect_number.idr
-- Calculate 'perfect' numbers in the Idris programming language
--

module PerfectNumber

-- predicate to check whether given number is perfect
export
is_perfect : (Integral a, Ord a) => a -> Bool
is_perfect n = if n > 0 then loop n 1 0 else False
where
  loop : a -> a -> a -> Bool
  loop n i sum = if n == i then (sum == n) else
    if (n `mod` i) == 0 then loop n (i + 1) (sum + i) else loop n (i + 1) sum

-- generate 'perfect' numbers until given limit
export
perfect_numbers : Nat -> List Nat
perfect_numbers n = filter (\x => is_perfect x) $ natRange n


module Rings

import Monoid
import Group

%access public export

||| Distributive Law
total
IsDistributive : (typ : Type) -> ((+) : typ -> typ -> typ)
                  -> ((*) : typ -> typ -> typ) -> Type
IsDistributive typ (+) (*) = (a,b,c : typ) -> ( (a*(b + c) = (a*b) + (a*c)), ((b + c)*a = (b*a) + (b*c)) )

total
IsRing : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsRing ring (+) (*) = (IsAbelianGrp ring (+), (IsMonoid ring (*), IsDistributive ring (+) (*)))

total
IsCommRing : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsCommRing ring (+) (*) = (IsRing ring (+) (*) , Commutative ring (+))

||| Gives the additive identity of the ring
RingAdditive_id : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) ->
                  (IsRing ring (+) (*)) -> (IdentityExists ring (+))
RingAdditive_id ring (+) (*) ((pfGrp,pfAb), pfElse) = Group_id ring (+) pfGrp

||| Non Zero elements in a ring
Ring_NonZero_Elements : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) ->
                        (IsRing ring (+) (*)) -> Type
Ring_NonZero_Elements ring (+) (*) pfRing = (a : ring ** ((a = e) -> Void)) where
                                             e = fst (RingAdditive_id ring (+) (*) pfRing)
||| Type of rings with identity
total
IsRing_with_identity : (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsRing_with_identity ring (+) (*) = (pfRing : IsRing ring (+) (*) **
                                    ( iden : (Ring_NonZero_Elements ring (+) (*) pfRing) **
                                      (a : ring) -> ((a*(fst iden) = a) , ((fst iden)*a = a))))

||| Useful rings - i.e commutative rings with identity
total
IsUsefulRing :  (ring : Type) -> ((+) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring) -> Type
IsUsefulRing ring (+) (*) = (IsRing_with_identity ring (+) (*), IsCommRing ring (+) (*))


module NatHelpers
import Data.Fin
%default total

export
natToProvedFin : (n : Nat) -> (bound : Nat) -> {auto prf : LT n bound} -> Fin bound
natToProvedFin Z (S right) {prf=LTESucc x} = FZ
natToProvedFin (S k) (S right) {prf=LTESucc x} = FS $ natToProvedFin k right

export
lteRightPlusZero : LTE hp (hp + (fromInteger 0))
lteRightPlusZero {hp = Z} = LTEZero
lteRightPlusZero {hp = (S k)} = LTESucc lteRightPlusZero

export
lteRightSucc : LTE k j -> LTE k (S j)
lteRightSucc LTEZero = LTEZero
lteRightSucc (LTESucc x) = LTESucc (lteRightSucc x)

export
lteRightPlus : LTE k j -> LTE k (j + l)
lteRightPlus LTEZero = LTEZero
lteRightPlus (LTESucc x) = LTESucc (lteRightPlus x)

export
lteRightPlusLeft : LTE n (n + k) -> LTE n ((n + j) + k)
lteRightPlusLeft LTEZero = LTEZero
lteRightPlusLeft (LTESucc x) = LTESucc (lteRightPlusLeft x)

export
lteRightPlusNat : (n : Nat) -> LTE n (n + k)
lteRightPlusNat Z = LTEZero
lteRightPlusNat (S k) = LTESucc (lteRightPlusNat k)

export
lteEq : (n : Nat) -> LTE n n
lteEq Z = LTEZero
lteEq (S k) = LTESucc (lteEq k)

public export
data NatNeg = Pos Nat | Neg Nat

export
NatToPos : Nat -> NatNeg
NatToPos = Pos

export
subtract : Nat -> Nat -> NatNeg
subtract k Z = Pos k
subtract Z (S j) = Neg (S j)
subtract (S k) (S j) = subtract k j


module FinUtils
import Data.Fin

%access public export

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

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)
--Nat to Fin (NOT modular values; if it overflows, the result is 0)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat a Z = assert_unreachable
tofinNat Z (S k) = FZ
tofinNat (S j) (S k) = case (lte (S j) (S k)) of
                             False => FS (tofinNat j k)
                             True => FZ

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

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

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


||| Properties of Ackermann functions
module Data.Nat.Ack

%default total

-- Primitive recursive functions are functions that can be calculated
-- by programs that don't use unbounded loops. Almost all common
-- mathematical functions are primitive recursive.

-- Uncomputable functions are functions that can't be calculated by
-- any programs at all. One example is the Busy Beaver function:
--   BB(k) = the maximum number of steps that can be executed by a
--           halting Turing machine with k states.
-- The values of the Busy Beaver function are unimaginably large for
-- any but the smallest inputs.

-- The Ackermann function is the most well-known example of a total
-- computable function that is not primitive recursive, i.e. a general
-- recursive function. It grows strictly faster than any primitive
-- recursive function, but also strictly slower than a function like
-- the Busy Beaver.

-- There are many variations of the Ackermann function. Here is one
-- common definition
-- (see https://sites.google.com/site/pointlesslargenumberstuff/home/2/ackermann)
-- that uses nested recursion:

ackRec : Nat -> Nat -> Nat
-- Base rule
ackRec Z m = S m
-- Prime rule
ackRec (S k) Z = ackRec k 1
-- Catastrophic rule
ackRec (S k) (S j) = ackRec k $ ackRec (S k) j

-- The so-called "base rule" and "prime rule" work together to ensure
-- termination. Happily, the Idris totality checker has no issues.

-- An unusual "repeating" defintion of the function is given in the
-- book The Little Typer:

ackRep : Nat -> Nat -> Nat
ackRep Z = (+) 1
ackRep (S k) = repeat (ackRep k)
  where
    repeat : (Nat -> Nat) -> Nat -> Nat
    repeat f Z = f 1
    repeat f (S k) = f (repeat f k)

-- These two definitions don't look like they define the same
-- function, but they do:

ackRepRec : (n, m : Nat) -> ackRep n m = ackRec n m
ackRepRec Z _ = Refl
ackRepRec (S k) Z = ackRepRec k 1
ackRepRec (S k) (S j) =
  rewrite sym $ ackRepRec (S k) j in
    ackRepRec k $ ackRep (S k) j


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor -}
module Main

import Data.Vect

reverseProof : Vect (k + 1) e -> Vect (S k) e
reverseProof {k} result = rewrite plusCommutative 1 k in result

myReverse : Vect n e -> Vect n e
myReverse [] = []
myReverse {n = S k} (x :: xs) = reverseProof (myReverse xs ++ [x])

appNilProof : Vect m e -> Vect (plus m 0) e
appNilProof {m} result = rewrite plusZeroRightNeutral m in result

appConsProof : Vect (S (m + k)) e -> Vect (plus m (S k)) e
appConsProof {m} {k} result =
  rewrite (sym (plusSuccRightSucc m k))
  in result

app : Vect n e -> Vect m e -> Vect (m + n) e
app [] ys = appNilProof ys
app (x :: xs) ys = appConsProof (x :: app xs ys)

myPlusCommutes : (n : Nat) -> (m : Nat) -> n + m = m + n
myPlusCommutes Z m     = sym (plusZeroRightNeutral m)
myPlusCommutes (S k) m = rewrite myPlusCommutes k m in plusSuccRightSucc m k

reverseProofNil : Vect n a -> Vect (plus n 0) a
reverseProofNil {n} xs = rewrite plusZeroRightNeutral n in xs

reverseProofCons : Vect ((S n) + l) a -> Vect (plus n (S l)) a
reverseProofCons {n} {l} res =
  rewrite sym (plusSuccRightSucc n l) in
  res

myReverse2 : Vect n a -> Vect n a
myReverse2 xs = reverse' [] xs
  where
    reverse' : Vect n a -> Vect m a -> Vect (n + m) a
    reverse' acc [] = reverseProofNil acc
    reverse' acc (x :: xs) = reverseProofCons (reverse' (x :: acc) xs)

data Dec' : (prop : Type) -> Type where
  Yes' : (prf : prop)            -> Dec' prop
  No'  : (contra : prop -> Void) -> Dec' prop

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

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

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

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

isYes : Dec (a = b) -> Bool
isYes (Yes prf) = True
isYes (No contra) = False

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

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

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

decEqVect : (DecEq a) => (xs : Vect n a) -> (ys : Vect n a) -> Dec (xs = ys)
decEqVect [] [] = Yes Refl
decEqVect (x :: xs) (y :: ys) = case decEq x y of
  (No contra) => No $ headEqual contra
  (Yes Refl) => case decEqVect xs ys of
    (Yes Refl) => Yes Refl
    (No contra) => No $ tailEqual contra

main : IO ()
main = do
  printLn $ myReverse [1,2,3,4]
  printLn $ app [1,2,3] [4,5,6,7]
  printLn $ myReverse2 [1,2,3,4,5]
  printLn $ isYes $ checkEqNat 100 99
  printLn $ Main.exactLength 2 [1,2,3]
  printLn $ isYes $ decEqVect [1,2,3] [1,2,3]


module Vect

%default total

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

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

-- finite sets

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

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

natToFin : Nat -> (n : Nat) -> Maybe (Fin n)
natToFin Z (S _) = Just FZ
natToFin (S k) (S j) =
  case natToFin k j of
       Nothing => Nothing
       Just k' => Just (FS k')
natToFin _ _ = Nothing

vs : Vect 5 String
vs = ["hello", "world", "nice", "to", "meet"]

elementAt : { n : _ } -> Nat -> Vect n a -> Maybe a
elementAt idx vec = case natToFin idx n of
                         Nothing => Nothing
                         Just idx' => Just $ index idx' vec


||| GCD and LCM. This is partial algorhytm with assert_total notation.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Integral.Gcd

%default total

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

export gcd : (Eq a, Num a, Abs a, Integral a) => a -> a -> a
gcd x y = go (abs x) (abs y)
  where go : a -> a -> a
        go x' y' = if y' == 0 then x' else assert_total $ go y' (x' `mod` y')

export lcm : (Eq a, Num a, Abs a, Integral a) => a -> a -> a
lcm x y = if x == 0 then 0
          else if y == 0 then 0
          else abs $ (x `div` (gcd x y)) * y

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


module Algebra.Solver.Semiring.Util

import Algebra.Semiring
import public Syntax.PreorderReasoning

%default total

export
0 p213 : Semiring a => {k,m,n : a} -> k + (m + n) === m + (k + n)
p213 = Calc $
  |~ k + (m + n)
  ~~ (k + m) + n   ... plusAssociative
  ~~ (m + k) + n   ... cong (+n) plusCommutative
  ~~ m + (k + n)   ..< plusAssociative

export
0 p1324 :  Semiring a
        => {k,l,m,n : a}
        -> (k + l) + (m + n) === (k + m) + (l + n)
p1324 = Calc $
  |~ (k + l) + (m + n)
  ~~ ((k + l) + m) + n ... plusAssociative
  ~~ (k + (l + m)) + n ..< cong (+n) plusAssociative
  ~~ (k + (m + l)) + n ... cong (\x => (k + x) + n) plusCommutative
  ~~ ((k + m) + l) + n ... cong (+n) plusAssociative
  ~~ (k + m) + (l + n) ..< plusAssociative

export
0 m1324 :  Semiring a
        => {k,l,m,n : a}
        -> (k * l) * (m * n) === (k * m) * (l * n)
m1324 = Calc $
  |~ (k * l) * (m * n)
  ~~ ((k * l) * m) * n ... multAssociative
  ~~ (k * (l * m)) * n ..< cong (*n) multAssociative
  ~~ (k * (m * l)) * n ... cong (\x => (k * x) * n) multCommutative
  ~~ ((k * m) * l) * n ... cong (*n) multAssociative
  ~~ (k * m) * (l * n) ..< multAssociative


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

import Data.Vect

-- check that all functions are total
%default total

createEmptyVector : Num t =>
                    Vect n (Vect 0 t)
createEmptyVector {n} = replicate n []
-- or:
-- createEmptyVector = replicate _ []

transposeHelper : Num t =>
                  Vect n t ->
                  Vect n (Vect k t) ->
                  Vect n (Vect (S k) t)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMatrix : Num t =>
                  Vect m (Vect n t) ->
                  Vect n (Vect m t)
transposeMatrix [] = createEmptyVector
transposeMatrix (x :: xs) = let xsTrans = transposeMatrix xs in
                            transposeHelper x xsTrans

transposeMatrixWithZip : Num t =>
                         Vect m (Vect n t) ->
                         Vect n (Vect m t)
transposeMatrixWithZip [] = createEmptyVector
transposeMatrixWithZip (x :: xs) = let xsTrans = transposeMatrixWithZip xs in
                                   zipWith (::) x xsTrans

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

multVector : Num t =>
             Vect n t ->
             Vect n t ->
             t
multVector xs ys = sum $ zipWith (*) xs ys
-- or:
-- multVector xs ys = foldl (+) 0 $ zipWith (*) xs ys
-- or:
-- multVector [] [] = 0
-- multVector (x :: xs) (y :: ys) = (x * y) + multVector xs ys

addMatrix : Num t =>
           Vect m (Vect n t) ->
           Vect m (Vect n t) ->
           Vect m (Vect n t)
addMatrix = zipWith (addVector)
-- or:
-- addMatrix [] [] = []
-- addMatrix (x :: xs) (y :: ys) = addVector x y :: addMatrix xs ys

multMatrixHelper2 : Num t =>
                    Vect n t ->
                    Vect p (Vect n t) ->
                    Vect p t
multMatrixHelper2 x ys = map (multVector x) ys
-- or:
-- multMatrixHelper2 _ [] = []
-- multMatrixHelper2 x (y :: ys) = multVector x y :: multMatrixHelper2 x ys

multMatrixHelper : Num t =>
                   Vect m (Vect n t) ->
                   Vect p (Vect n t) ->
                   Vect m (Vect p t)
multMatrixHelper xs ys = map (flip multMatrixHelper2 $ ys) xs
-- or:
-- multMatrixHelper xs ys = map (\x => multMatrixHelper2 x ys) xs
-- or:
-- multMatrixHelper [] _ = []
-- multMatrixHelper (x :: xs) ys = multMatrixHelper2 x ys :: multMatrixHelper xs ys

multMatrix : Num t =>
            Vect m (Vect n t) ->
            Vect n (Vect p t) ->
            Vect m (Vect p t)
multMatrix xs ys = multMatrixHelper xs $ transposeMatrixWithZip ys
-- or:
-- multMatrix xs ys = let ysTrans = transposeMatrixWithZip ys in
--                    multMatrixHelper xs ysTrans

v1 : Vect 3 (Vect 2 Nat)
v1 = [[1,2],[3,4],[5,6]]

v2 : Vect 2 (Vect 4 Nat)
v2 = [[7,8,9,10],[11,12,13,14]]


module Field

import Group
import Monoid
import Ring

%access public export

-- For field, proof that multiplicative inverse exists when only non zero elements are considered
total
InvExistsNonZero : (fld : Type) -> ((+) : fld -> fld -> fld) -> ((*) : fld -> fld -> fld) -> (IsGroup fld (+)) -> Type
InvExistsNonZero fld (+) (*) pfgrp = (a : fld) -> (pfid : (IdentityExists fld (*)) ** ((a = fst(fst(snd(pfgrp)))) -> Void) -> (a_inv : fld ** ((a*a_inv) = fst(pfid) , (a_inv*a) = fst(pfid))))

-- multiplication has associativity, identity, but inverse only for non-zero elements
total
IsModGrp : (fld : Type) -> ((+) : fld -> fld -> fld) -> ((*) : fld -> fld -> fld) -> (pfgrp : IsGroup fld (+)) -> Type
IsModGrp fld (+) (*) pfgrp = (Associative fld (*), (IdentityExists fld (*), InvExistsNonZero fld (+) (*) pfgrp))

-- modified abelian property added to the above proof
IsModAbelGrp : (fld : Type) -> ((+) : fld -> fld -> fld) -> ((*) : fld -> fld -> fld) -> (pfgrp : IsGroup fld (+)) -> Type
IsModAbelGrp fld (+) (*) pfgrp = (IsModGrp fld (+) (*) pfgrp, Commutative fld (*))

-- similar to Arka's file on monoids
total
IsField : (fld : Type) -> ((+) : fld -> fld -> fld) -> ((*) : fld -> fld -> fld) -> Type
IsField fld (+) (*) = (pfgrp: IsAbelianGrp fld (+) ** ((IsModAbelGrp fld (+) (*) (fst pfgrp)), IsDistributive fld (+) (*)))


module xquant.Math.Set

import public Data.Vect

%default total

||| A vector of unique elements
data Set : Vect n a -> Type where
  Nil  : Set []
  (::) : Not (Elem x xs) -> Set xs -> Set (x :: xs)

||| Elements of a type
data HasElements : (t : Type) -> (v : Vect n t) -> Type where
  MkHas : {v : Vect n t} ->
          Set v ->
          ((x : t) -> Elem x v) ->
          HasElements t v

data Cardinality : (t : Type) -> Nat -> Type where
  Cardinal : {v : Vect n t} -> HasElements t v -> Cardinality t n

noElem : Elem x [] -> Void
noElem Here impossible

---- Example: Bool ----

notElemTF : Elem True [False] -> Void
notElemTF Here impossible
notElemTF (There x) = noElem x

setFalse : Set [False]
setFalse = noElem :: []

set1 : (x : a) -> Set [a]
set1 x = noElem :: []

setTrueFalse : Set [True, False]
setTrueFalse = notElemTF :: setFalse

boolHas : HasElements Bool [True,False]
boolHas = MkHas setTrueFalse (\b => case b of
                                         True  => Here
                                         False => There Here)

boolHasTwo : Cardinality Bool 2
boolHasTwo = Cardinal boolHas


module Common.Lte

import Data.Fin

%access export

%default total

fromEqLte : (l = r) -> LTE l r
fromEqLte prf = rewrite prf in lteRefl

lteAddBoth : LTE n m -> LTE (c + n) (c + m)
lteAddBoth {c = Z} lte = lte
lteAddBoth {c = (S k)} lte =
  let ind = lteAddBoth lte
  in (LTESucc ind)

lteSum : LTE l1 r1 -> LTE l2 r2 -> LTE (l1 + l2) (r1 + r2)
lteSum LTEZero lte2 {r1} {r2} =
  rewrite plusCommutative r1 r2 in
  lte2 `lteTransitive` lteAddRight r2
lteSum (LTESucc lte1') lte2 = LTESucc (lteSum lte1' lte2)

lteMultConst : LTE n m -> LTE (c * n) (c * m)
lteMultConst {c = Z} lte = LTEZero
lteMultConst {c = (S k)} {m} {n} lte =
  let ind = lteMultConst {c=k} lte
  in lteSum lte ind

elemStrictlySmallerThanBound : (n : Fin m) -> LT (finToNat n) m
elemStrictlySmallerThanBound FZ = LTESucc LTEZero
elemStrictlySmallerThanBound (FS x) =
  let ind = elemStrictlySmallerThanBound x
  in LTESucc ind

lteZeqZ : LTE a Z -> a = Z
lteZeqZ LTEZero = Refl

tightBound : LTE a b -> LTE b a -> a = b
tightBound LTEZero LTEZero = Refl
tightBound (LTESucc x) (LTESucc y) = eqSucc _ _ (tightBound x y)

splitLte : LTE a b -> Either (a = b) (LT a b)
splitLte {a = Z} {b = Z} LTEZero = Left Refl
splitLte {a = Z} {b = (S k)} LTEZero = Right (LTESucc LTEZero)
splitLte {a = (S _)} {b = Z} LTEZero impossible
splitLte {a = (S _)} {b = Z} (LTESucc _) impossible
splitLte {a = (S k)} {b = (S j)} (LTESucc lte') =
  case splitLte lte' of
    (Left eq) => Left (eqSucc _ _ eq)
    (Right lt) => Right (LTESucc lt)


module Data.ZZ

import Decidable.Equality

%default total
%access public

||| An integer is either a positive `Nat` or the negated successor of a `Nat`.
|||
||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen
||| to be positive.
|||
data ZZ = Pos Nat | NegS Nat

||| Take the absolute value of a `ZZ`
absZ : ZZ -> Nat
absZ (Pos n) = n
absZ (NegS n) = S n

instance Show ZZ where
  show (Pos n) = show n
  show (NegS n) = "-" ++ show (S n)

negNat : Nat -> ZZ
negNat Z = Pos Z
negNat (S n) = NegS n

||| Construct a `ZZ` as the difference of two `Nat`s
minusNatZ : Nat -> Nat -> ZZ
minusNatZ n Z = Pos n
minusNatZ Z (S m) = NegS m
minusNatZ (S n) (S m) = minusNatZ n m

||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`.
plusZ : ZZ -> ZZ -> ZZ
plusZ (Pos n) (Pos m) = Pos (n + m)
plusZ (NegS n) (NegS m) = NegS (S (n + m))
plusZ (Pos n) (NegS m) = minusNatZ n (S m)
plusZ (NegS n) (Pos m) = minusNatZ m (S n)

instance Eq ZZ where
  (Pos n) == (Pos m) = n == m
  (NegS n) == (NegS m) = n == m
  _ == _ = False

instance Ord ZZ where
  compare (Pos n) (Pos m) = compare n m
  compare (NegS n) (NegS m) = compare m n
  compare (Pos _) (NegS _) = GT
  compare (NegS _) (Pos _) = LT

||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`.
multZ : ZZ -> ZZ -> ZZ
multZ (Pos n) (Pos m) = Pos $ n * m
multZ (NegS n) (NegS m) = Pos $ (S n) * (S m)
multZ (NegS n) (Pos m) = negNat $ (S n) * m
multZ (Pos n) (NegS m) = negNat $ n * (S m)

||| Convert an `Integer` to an inductive representation.
fromInt : Integer -> ZZ
fromInt n = if n < 0
            then NegS $ fromInteger {a=Nat} ((-n) - 1)
            else Pos $ fromInteger {a=Nat} n

instance Cast Nat ZZ where
  cast n = Pos n

instance Num ZZ where
  (+) = plusZ
  (*) = multZ
  fromInteger = fromInt

mutual
  instance Neg ZZ where
    negate (Pos Z)     = Pos Z
    negate (Pos (S n)) = NegS n
    negate (NegS n)    = Pos (S n)

    (-) = subZ
    abs = cast . absZ

  ||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.
  subZ : ZZ -> ZZ -> ZZ
  subZ n m = plusZ n (negate m)

instance Cast ZZ Integer where
  cast (Pos n) = cast n
  cast (NegS n) = (-1) * (cast n + 1)

instance Cast Integer ZZ where
  cast = fromInteger

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n + m = x -> (Pos n) + (Pos m) = Pos x
natPlusZPlus n m x h = cong h

natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat)
             -> n * m = x -> (Pos n) * (Pos m) = Pos x
natMultZMult n m x h = cong h

doubleNegElim : (z : ZZ) -> negate (negate z) = z
doubleNegElim (Pos Z) = Refl
doubleNegElim (Pos (S n)) = Refl
doubleNegElim (NegS Z) = Refl
doubleNegElim (NegS (S n)) = Refl

-- Injectivity
posInjective : Pos n = Pos m -> n = m
posInjective Refl = Refl

negSInjective : NegS n = NegS m -> n = m
negSInjective Refl = Refl

posNotNeg : Pos n = NegS m -> Void
posNotNeg Refl impossible

-- Decidable equality
instance DecEq ZZ where
  decEq (Pos n) (NegS m) = No posNotNeg
  decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg
  decEq (Pos n) (Pos m) with (decEq n m)
    | Yes p = Yes $ cong p
    | No p = No $ \h => p $ posInjective h
  decEq (NegS n) (NegS m) with (decEq n m)
    | Yes p = Yes $ cong p
    | No p = No $ \h => p $ negSInjective h

-- Plus
plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right
plusZeroLeftNeutralZ (Pos n) = Refl
plusZeroLeftNeutralZ (NegS n) = Refl

plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left
plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n
plusZeroRightNeutralZ (NegS n) = Refl

plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left)
plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m
plusCommutativeZ (Pos n) (NegS m) = Refl
plusCommutativeZ (NegS n) (Pos m) = Refl
plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m


module Booleans

infixl 4 /\, \/

data MyBool : Type where
     True : MyBool
     False : MyBool

-- Alternate way of creating the MyBool datatype
-- data MyBool = True | False

negb : Bool -> Bool
negb False = True
negb True = False

public export
andb : (a : Bool) -> (b : Bool) -> Bool
andb False b = False
andb True b = b

orb : (a : Bool) -> (b : Bool) -> Bool
orb False b = b
orb True b = True

-- orb truth table as proofs
to1 : (orb True True) = True
to1 = Refl
to2 : (orb True False) = True
to2 = Refl
to3 : (orb False False) = False
to3 = Refl
to4 : (orb False True) = True
to4 = Refl

(/\) : Bool -> Bool -> Bool
(/\) = andb

(\/) : Bool -> Bool -> Bool
(\/) = orb

to5 : False \/ False \/ True = True
to5 = Refl

-- Exercise 11.1
idAppTwiceF : (f : Bool -> Bool) -> (idp : (x : Bool) -> f x = x) -> f (f False) = False
idAppTwiceF f idp = rewrite idp False in rewrite idp False in Refl

idAppTwiceT : (f : Bool -> Bool) -> (idp : (x : Bool) -> f x = x) -> f (f True) = True
idAppTwiceT f idp = rewrite idp True in rewrite idp True in Refl

idAppTwice : (f : Bool -> Bool) -> ((x : Bool) -> f x = x) -> (b : Bool) -> f (f b) = b
idAppTwice f idp False = idAppTwiceF f idp
idAppTwice f idp True = idAppTwiceT f idp

-- Exercise 11.1 - 2
negAppTwiceF : (f : Bool -> Bool) -> (g : (x : Bool) -> f x = negb x) -> f (f False) = False
negAppTwiceF f g = rewrite g False in rewrite g True in Refl

negAppTwiceT : (f : Bool -> Bool) -> (g : (x : Bool) -> f x = negb x) -> f (f True) = True
negAppTwiceT f g = rewrite g True in rewrite g False in Refl

negAppTwice : (f : Bool -> Bool) -> ((x : Bool) -> f x = negb x) -> (b : Bool) -> f (f b) = b
negAppTwice f g False = negAppTwiceF f g
negAppTwice f g True = negAppTwiceT f g


module Algebra.Solver.Semiring.Prod

import Algebra.Solver.Semiring.Expr
import public Algebra.Solver.Prod
import Algebra.Solver.Semiring.Util

%default total

||| Evaluate products of variables each raised to
||| given exponent.
|||
||| Every arithmetic expression in a commutative ring
||| can be represented as a sum of products of the variables
||| each raised by an exponent and multiplied by a constant
||| factor. For instance, expression `x + x * (y + z + z)`
||| gets normalized to `x + x * y + 2 * x * z`.
public export
eprod : Semiring a => {as : List a} -> Prod a as -> a
eprod {as = []}      []        = 1
eprod {as = x :: xs} (e :: es) = pow x e * eprod es

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

||| Proof that `one` evaluates to 1.
export
0 pone : Semiring a => (as : List a) -> eprod (one {as}) === 1
pone []        = Refl
pone (x :: xs) = Calc $
  |~ 1 * eprod (one {as = xs})
  ~~ 1 * 1                     ... cong (1 * ) (pone xs)
  ~~ 1                         ... multOneRightNeutral

||| Proof that `fromVar x` evaluates to `x`.
export
0 pvar :  Semiring a
       => (as : List a)
       -> (e  : Elem x as)
       -> eprod (fromVar {as} e) === x
pvar (x :: vs) Here      = Calc $
  |~ (x * 1) * eprod (one {as = vs})
  ~~ (x * 1) * 1                     ... cong ((x*1) *) (pone vs)
  ~~ x * 1                           ... multOneRightNeutral
  ~~ x                               ... multOneRightNeutral

pvar (v :: vs) (There y) = Calc $
  |~ 1 * eprod (fromVar {as = vs} y)
  ~~ 1 * x                           ... cong (1*) (pvar vs y)
  ~~ x                               ... multOneLeftNeutral

pvar [] Here impossible
pvar [] (There y) impossible

||| Proof that evaluation of a multiplication of products
||| is the same as multiplying the results of evaluating each
||| of them.
export
0 pmult :  Semiring a
        => (p,q : Prod a as)
        -> eprod (mult p q) === eprod p * eprod q
pmult []        []        = sym multOneLeftNeutral
pmult {as = h :: t} (x :: xs) (y :: ys) = Calc $
  |~ pow h (x + y) * eprod (mult xs ys)
  ~~ (pow h x * pow h y) * eprod (mult xs ys)
     ... cong (* eprod (mult xs ys)) (ppow x y h)
  ~~ (pow h x * pow h y) * (eprod xs * eprod ys)
     ... cong ((pow h x * pow h y) *) (pmult xs ys)
  ~~ (pow h x * eprod xs) * (pow h y * eprod ys)
     ... Util.m1324


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

{-describeListEnd : List Int -> String
describeListEnd [] = "Empty"
describeListEnd (xs ++ [x]) = "Non-empty, initial portion" ++ show xs-}

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

describeHelper : (input : List Int) -> (form : ListLast input) -> String
describeHelper [] Empty = "Empty"
describeHelper (xs ++ [x]) (NonEmpty xs x)
  = "Non-empty, initial portion = " ++ show xs

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

{-describeListEnd : List Int -> String
describeListEnd xs = describeHelper xs (listLast xs)-}

describeListEnd : List Int -> String
describeListEnd input with (listLast input)
  describeListEnd [] | Empty = "Empty"
  describeListEnd (xs ++ [x]) | (NonEmpty xs x)
    = "Non-empty, initial portion =" ++ show xs

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


module Equis.Matrix.Algebraic

import Data.Matrix.Algebraic

%access private

||| Retrieves the scalar value from an order-1 square matrix.
|||
||| @x the matrix
export
scalar : (x : Matrix (S Z) (S Z) a) -> a
scalar x = head (head x)

||| Zips two matrices together pairwise.
|||
||| @x the first matrix
||| @y the second matrix
export
zipMatrix : (x : Matrix n m a) -> (y : Matrix n m b) -> Matrix n m (a, b)
zipMatrix [] [] = []
zipMatrix (x :: xs) (y :: ys) = (zip x y) :: (zipMatrix xs ys)

||| Maps a function over a matrix.
|||
||| @f the function
||| @x the matrix
export
mapMatrix : (f : a -> b) -> (x : Matrix n m a) -> Matrix n m b
mapMatrix f x = map (map f) x

||| Generates a matrix of the specified order containing zero-based coordinates along one dimension.
|||
||| @n the first matrix dimension
||| @m the second matrix dimension
coord : (n : Nat) -> (m : Nat) -> Matrix n m (Fin m)
coord Z (S k) = []
coord (S k) m = (fins m) :: (coord k m)

||| Generates a matrix of the specified order containing zero-based coordinates along both dimensions.
|||
||| @n the first matrix dimension
||| @m the second matrix dimension
export
coords : (n : Nat) -> (m : Nat) -> Matrix n m (Fin n, Fin m)
coords n m = zipMatrix (transpose (coord m n)) (coord n m)


module RecRule

import Data.Fin

% access public export

recNat : (x : Type) -> x -> (Nat -> x -> x) -> (Nat -> x)
recNat x base step Z = base
recNat x base step (S k) = step k (recNat x base step k)

fctl : Nat -> Nat
fctl = recNat Nat (S Z) step where
  step = \n: Nat => \y : Nat => (S n) * y

recListNat : (x: Type) -> x -> (Nat -> List Nat -> x -> x) -> (List Nat -> x)
recListNat x base step [] = base
recListNat x base step (y :: xs) = step y xs previous where
  previous = recListNat x base step xs

lsum : List Nat -> Nat
lsum = recListNat Nat base step where
  base = Z
  step = \h : Nat => \t : List Nat => \accum : Nat => h + accum

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

recFin : (x: Type) ->
  (Nat -> x) ->
  ((n: Nat) -> Fin n -> x -> x) ->
  ((n: Nat) -> Fin n -> x)
recFin x base _ (S k) FZ = base k
recFin x base step (S k) (FS y) = step k y previous where
  previous = recFin x base step k y


module Chapter4

import Data.Vect as V

data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double
%name Shape shape, shape1, shape2

-- Both of these are the same
-- This second syntax is more flexible for defining dependent types
-- data Shape : Type where
--      Triangle : Double -> Double -> Shape
--      Rectangle : Double -> Double -> Shape
--      Circle : Double -> Shape

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

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

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

test_picture : Picture
test_picture = Combine (Translate 5 5 rectangle)
               (Combine (Translate 35 5 circle)
               (Translate 15 25 triangle))

picture_area : Picture -> Double
picture_area (Primitive x) = area x
picture_area (Combine x y) = picture_area x + picture_area y
picture_area (Rotate _ y) = picture_area y
picture_area (Translate _ _ z) = picture_area z

data Biggest = NoTriangle
             | Size Double

biggest : Biggest -> Biggest -> Biggest
biggest NoTriangle y = y
biggest x NoTriangle = x
biggest (Size x) (Size y) = if x > y then Size x else Size y

biggest_triangle : Picture -> Biggest
biggest_triangle (Primitive (Rectangle x y)) = NoTriangle
biggest_triangle (Primitive (Circle x)) = NoTriangle
biggest_triangle (Primitive pic) = Size (area pic)
biggest_triangle (Combine pic pic1) = biggest (biggest_triangle pic) (biggest_triangle pic1)
biggest_triangle (Rotate x pic) = biggest_triangle pic
biggest_triangle (Translate x y pic) = biggest_triangle pic

data Expr = ENum Int
          | EAdd Expr Expr
          | ESub Expr Expr
          | EMul Expr Expr
%name Expr expr, expr1, expr2

evalExpr : Expr -> Int
evalExpr (ENum x)          = x
evalExpr (EAdd expr expr1) = evalExpr expr + evalExpr expr1
evalExpr (ESub expr expr1) = evalExpr expr - evalExpr expr1
evalExpr (EMul expr expr1) = evalExpr expr * evalExpr expr1

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing Nothing = Nothing
maxMaybe Nothing y = y
maxMaybe x Nothing = x
maxMaybe xval@(Just x) yval@(Just y) = if x > y then xval else yval

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

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

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

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

sumInputs : Integer -> String -> Maybe (String, Integer)
sumInputs sum istr = let i = cast istr in
                         if i < 0 then Nothing
                         else let newSum = sum + i in
                                  Just ("Subtotal: " ++ show newSum ++ "\n", newSum)

main : IO ()
main = replWith 0 "Enter a value: " sumInputs


module OfficialCrashCourse.FTypes

import OfficialCrashCourse.DTypes

-- Function Types

isHero : NatNum -> Bool
isHero Hero = True
isHero _ = False

isSucc : NatNum -> Bool
isSucc (Succ _) = True
isSucc _ = False

equalNum : NatNum -> NatNum -> Bool
equalNum Hero Hero = True
equalNum Hero (Succ x) = False
equalNum (Succ x) Hero = False
equalNum (Succ x) (Succ y) = equalNum x y

toNumeric : NatNum -> Integer
toNumeric Hero = 0
toNumeric (Succ x) = 1 + toNumeric x

fromNumeric : Integer -> NatNum
fromNumeric x =  case x <= 0 of
                    True => Hero
                    False => Succ (fromNumeric (x - 1))

pred: NatNum -> Maybe NatNum
pred (Succ Hero) = Just Hero
pred Hero = Nothing
pred (Succ x) = Just x

min : NatNum -> NatNum -> NatNum
min Hero y = Hero
min (Succ x) Hero = Hero
min (Succ x) (Succ y) = Succ (min x y)

max: NatNum -> NatNum -> NatNum
max x y = let small = min x y in if equalNum small x then y else x

max' : NatNum -> NatNum -> NatNum
max' Hero y = y
max' (Succ x) Hero = Succ x
max' (Succ x) (Succ y) = Succ (max' x y)

addition : NatNum -> NatNum -> NatNum
addition Hero y = y  -- adding a Nat to Zero yields the same Nat
addition (Succ x) y = Succ (addition x y)
-- adding a Successor of a Nat to another Nat
-- is the same as Successor of addition of those same Nats

nthFibonacci : NatNum -> NatNum
nthFibonacci Hero = Hero
nthFibonacci (Succ Hero) = Succ Hero
nthFibonacci (Succ (Succ x)) = let succFib = nthFibonacci (Succ x);
                                    xFib = nthFibonacci x
                                in addition succFib xFib

multiplication : NatNum -> NatNum -> NatNum
multiplication Hero y = Hero
multiplication (Succ x) y = addition y (multiplication x y)

exponentiation : NatNum -> NatNum -> NatNum
exponentiation _ Hero = Succ Hero
exponentiation x (Succ Hero) = x
exponentiation x (Succ y) = multiplication x (exponentiation x y)

nthFactorial : NatNum -> NatNum
nthFactorial Hero = Succ Hero
nthFactorial (Succ Hero) = Succ Hero
nthFactorial (Succ x) = multiplication (Succ x) (nthFactorial x)

--inequalities
--ordering
--n-tiered pascal's triangle

-- where clause for local definitions
reversal : List a -> List a
reversal xs = revAcc [] xs where
    revAcc: List a -> List a -> List a
    revAcc acc [] = acc
    revAcc acc (x :: xs) = revAcc (x :: acc) xs

-- type constraint for equality check guarantee
zipEq : Eq a => List a -> List a -> Bool
zipEq [] [] = True
zipEq [] (x :: xs) = False
zipEq (x :: xs) [] = False
zipEq (x :: xs) (y :: ys) = if x == y then zipEq xs ys else False

-- more flexible version of zipEq
zipWith : Ord a => (a -> a -> Bool) -> List a -> List a -> Bool
zipWith f [] [] = True
zipWith f [] xs = False
zipWith f xs [] = False
zipWith f (x :: xs) (y :: ys) = if f x y then zipWith f xs ys else False

equal: Eq a => a -> a -> Bool
equal x y = x == y

isNonEmpTea : List a -> Bool
isNonEmpTea [] = False
isNonEmpTea _ = True

-- List String = [], List Num = []
headElem: List a -> Maybe a  -- such that a is the first element of the list
headElem [] = Nothing
headElem (x :: xs) = Just x

listLen : List a -> Integer
listLen [] = 0
listLen (x :: xs) = 1 + listLen xs

lastElem: List a -> Maybe a
lastElem [] = Nothing
lastElem (x :: xs) = if (listLen xs > 0) then lastElem xs else Just x
-- to optimize, use if xs == [] then ...
-- adjusting the value to some number other than 0 e.g. to get the elem at nth place needs some thought to be put into it
-- think of the extra checks you might be missing regarding the list index and being within the bounds

isPalindrome : Ord a => List a -> Bool
isPalindrome [] = True
isPalindrome xs = zipWith equal xs (reversal xs) -- or zipEq xs (reversal xs)

gt: Ord a => a -> a -> Bool
gt x y = x > y

-- Given two lists, find out whether every element of
-- first list is greater than the corresponding element of the second list
isItemwiseGreater : Ord a => List a -> List a -> Bool
isItemwiseGreater [] [] = True
isItemwiseGreater xs ys = zipWith gt xs ys


module ElemCount

import Data.Vect
import Sortings

%default total

count : Eq a => a -> Vect n a -> Fin (S n)
count _ Nil = 0
count x (y :: xs) = (if x == y then FS else weaken) $ count x xs

data ElemCount : Fin (S n) -> a -> Vect n a -> Type where
  NoElem   :                                    ElemCount FZ         x []
  IncHere  : ElemCount c x xs                -> ElemCount (FS c)     x (x :: xs)
  IncThere : ElemCount c x xs -> Not (x = y) -> ElemCount (weaken c) x (y :: xs)

  -- A variant with non-structural equality
  --IncThere : Eq a => {x, y : a} -> ElemCount c x xs -> Not (So (x == y)) -> ElemCount (weaken c) x (y :: xs)

-- TODO To define permutation through `ElemCount` (probably, the structural one)
-- TODO   and prove equivalence with the structurally defined permutation property.

(+) : Fin (S n) -> Fin (S m) -> Fin (S $ n + m)
(+) {m}     x FZ     = weakenN m x
(+) {n} {m} x (FS y) = rewrite plusSuccRightSucc n m in FS (x + y)

ecConcPresSum : ElemCount ca x as -> ElemCount cb x bs -> ElemCount (ca + cb) x (as ++ bs)
ecConcPresSum = ?ecConcPresSum_impl

||| Proof that permutationproperty preserves elements (i.e. preserves elements count)
permPresElems : Permutation xs ys -> ElemCount n e xs -> ElemCount n e ys
permPresElems EmptyPerm ec = ec
permPresElems {xs=a::as} (InsertPerm ip) (IncHere iec) = ?perm_here
permPresElems (InsertPerm ip) (IncThere iec xy) = ?perm_there


module Control.Permutation.Types

import Data.List
import Data.Vect
import Data.Group

%default total

%access public export

||| This is something like `Vector k a`, except we restrict ourselves to only 1,...,n for `Permutation n`.
data Permutation : Nat -> Type where
  Nil : Permutation Z
  (::) : Fin (S n) -> Permutation n -> Permutation (S n)

implementation Eq (Permutation n) where
  (==) Nil Nil = True
  (==) (x :: xs) (y :: ys) = x == y && xs == ys

private
id : Permutation n
id {n=Z} = []
id {n=S _} = FZ :: id

debug : Permutation n -> String
debug Nil = "Nil"
debug (p::ps) = show (finToNat p) ++ " :: " ++ (debug ps)

||| This is essentially a group action. Given a permutation, we apply it to a vector.
sigma : Permutation n -> Vect n a -> Vect n a
sigma _ [] = []
sigma (p::ps) (x::xs) = insert (sigma ps xs) p
  where
    insert : Vect n a -> Fin (S n) -> Vect (S n) a
    insert l FZ = x::l
    insert [] _ = [x]
    insert (e::es) (FS k) = e :: insert es k

toVector : Permutation n -> Vect n (Fin n)
toVector {n} p = sigma p (sequential n)
  where
    sequential : (n : Nat) -> Vect n (Fin n)
    sequential Z = []
    sequential (S k) = FZ :: map FS (sequential k)

private
indices : Permutation n -> Vect n (Fin n)
indices [] = Nil
indices (p :: ps) = p :: map (thin p) (indices ps)
  where
    thin : Fin (S n) -> Fin n -> Fin (S n)
    thin FZ i = FS i
    thin _ FZ = FZ
    thin (FS i) (FS j) = FS (thin i j)

private
delete : Fin (S n) -> Permutation (S n) -> Permutation n
delete FZ (j :: p) = p
delete {n=Z} (FS _)  _ = Nil
delete {n=S _} (FS i) (j :: p) = (either lifter id $ strengthen j) :: delete i p
  where
    lifter (FS k) = k
    lifter FZ = FZ

private
compose : Permutation n -> Permutation n -> Permutation n
compose Nil p = p
compose (i :: p) p' = index i (indices p') :: compose p (delete i p')

export
invert : Permutation n -> Permutation n
invert Nil = Nil
invert p@(i :: is) = index (i' p) (indices p) :: delete (i' p) p
  where
    i' p = index i (indices p)

implementation Show (Fin n) where
  show FZ = "0"
  show (FS k) = show $ (finToNat k) + 1

implementation Semigroup (Permutation n) where
  (<+>) = compose

implementation Monoid (Permutation n) where
  neutral = id

implementation Group (Permutation n) where
  inverse = invert


module Shape

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

private
rectangle_area : Double -> Double -> Double
rectangle_area x y = x * y

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

-- 10.3 Ex # 2
public export
data ShapeView : (s : Shape) -> Type where
     VTri : ShapeView (Triangle base height)
     VRect : ShapeView (Rectangle width height)
     VCirc : ShapeView (Circle r)

shapeView : (s : Shape) -> ShapeView s
shapeView (Triangle x y) = VTri
shapeView (Rectangle x y) = VRect
shapeView (Circle x) = VCirc

narea : Shape -> Double
narea x with (shapeView x)
  narea (Triangle base height) | VTri = 0.5 * base * height
  narea (Rectangle width height) | VRect = width * height
  narea (Circle r) | VCirc = pi * r * r


import Data.Fin

data Vect : Nat -> Type -> Type where
     Nil  : Vect Z a
     (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

||| Indexes into given Vect and guarentees that the given index is in bounds at compile time
index : (i : Fin n) -> Vect n elem -> elem
index FZ (x :: xs) = x
index (FS i) (x :: xs) = index i xs

||| Index into given Vect and returns Nothing if index is out of bounds
tryIndex : {n: _} -> Integer -> Vect n a -> Maybe a
-- if integer can be converted to Fin of size n then apply index function
tryIndex i xs = map (\idx => index idx xs) $ integerToFin i n

||| Appends two Vects with the same element types together
append : Vect n elem -> Vect m elem -> Vect (n + m) elem
append [] ys = ys
append (x :: xs) ys = x :: append xs ys

||| Zips up two elements of equal size
zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] _ = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys

||| Takes first i values from given Vect
vectTake : (i : Fin (S n)) -> Vect n elem -> Vect (finToNat i) elem
vectTake FZ xs = []
vectTake (FS x) (y :: xs) = y :: vectTake x xs

||| Sums entries at index i for Vects of identical lengths
||| Returns Nothing if index is out of bounds
sumEntries : Num a => {n : _} -> (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries pos xs ys = map (\idx => index idx xs + index idx ys) $ integerToFin pos n

||| Sums entries at index i for Vects of identical lengths
||| Returns Nothing if index is out of bounds
sumEntries' : Num a => {n : _} -> (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries' pos xs ys = let f = tryIndex pos in [| f xs + f ys |]


module MenoSlave

%default total

-- This proof is based on the dialog between Socrates and one of Meno's slaves
-- Source: Plato, Meno, 84c

{- Diagammatic view of the square

  J-H-G
  |/ \|
  D C E
  |\ /|
  A-B-F

-}

{- Axioms

A square is a regular quadrilateral with four equal sides and angles with properties
The angles of a square add up to 360 degrees

A triangle is a polygon with three edges and vertices
The angles of a triangle add up to 180 degrees
An isosceles triangle is a triangle with two sides (and therefore two angles) of equal length

-}

-- Construct a square

data Square   : Double -> Type where
     MkSquare : Double -> Square a

testSquareReflexivity : Square 4 = Square (2 + 2)
testSquareReflexivity = Refl

testSquareReflexivity' : Square 3 = Square (3 + 1) -> Void
testSquareReflexivity' Refl impossible

-- Square functions

length : Square a -> Double
length (MkSquare x) = x

testLength : length (MkSquare 4) = 4.0
testLength = Refl

circumference : Square a -> Double
circumference (MkSquare x) = x * 4

testCircumference : circumference (MkSquare 4) = 16.0
testCircumference = Refl

area : Square a -> Double
area (MkSquare x) = x * x

testArea : area (MkSquare 5) = 25.0
testArea = Refl

-- Construct a square from four smaller squares

makeSquare : Square a -> Square b -> Square c -> Square d -> Square e
makeSquare w x y z = MkSquare (area w + area x + area y + area z)

testMakeSquare : makeSquare (MkSquare 1) (MkSquare 2) (MkSquare 3) (MkSquare 4) = (MkSquare 30)
testMakeSquare = Refl

-- Construct four equal squares

-- SOCRATES: Tell me, boy, is not this our square of four feet? (ABCD.) You understand?
-- BOY: Yes.
abcd : Square 4
abcd = MkSquare 4

-- SOCRATES: Now we can add another equal to it like this? (BCEF.)
-- BOY: Yes.
bcef : Square 4
bcef = MkSquare 4

-- SOCRATES: And a third here, equal to each of the others? (CEGH.)
-- BOY: Yes.
cegh : Square 4
cegh = MkSquare 4

-- SOCRATES: And then we can fill in this one in the comer? (DCHJ.)
-- BOY: Yes.
dchj : Square 4
dchj = MkSquare 4

-- SOCRATES: Then here we have four equal squares?
-- BOY: Yes.
fourEqualSquares : MenoSlave.abcd = MenoSlave.bcef -> MenoSlave.bcef = MenoSlave.cegh -> MenoSlave.cegh = MenoSlave.dchj
fourEqualSquares Refl Refl = Refl

afgj : Square a
afgj = makeSquare abcd bcef cegh dchj

-- 4 * 4 = 16, and 16 * 4 = 64
testSizeAFGJ : MenoSlave.afgj = (MkSquare 64)
testSizeAFGJ = Refl

-- Diagonal bisection of a square
-- To bisect a square diagonally in equal parts, we need to split one of it's angles into two equal pieces:
bisect90deg : 90.0 / 2 = 45
bisect90deg = Refl

-- This will split the square into two triangles
-- Since we know two of the angles, we can infer the length of the third angle:
partial triangleAngles : 90 + 45 + c = 180
triangleAngles {c = 45} = Refl

-- Since the unknown angle is equal to the split angle, we know that it has formed an isosceles triangle where the
-- non-diagonal sides are equal, which means that a diagonal split along a square creates two equal pieces

-- Construct a triangle
data Triangle   : Double -> Double -> Type where
     MkTriangle : Double -> Double -> Triangle a b

areaTriangle : Triangle a b -> Double
areaTriangle (MkTriangle x y) = x * y / 2

-- SOCRATES: Now does this line going from corner to corner cut each of these squares in half? (BEHD.)
-- BOY: Yes.

-- Cuts ABCD across DB, BCEF across BE, CEGH across EH, DCHJ across HD

lenABCD : Double
lenABCD = length abcd

acbdHalved : areaTriangle (MkTriangle MenoSlave.lenABCD MenoSlave.lenABCD) +
             areaTriangle (MkTriangle MenoSlave.lenABCD MenoSlave.lenABCD) = area MenoSlave.abcd
acbdHalved = Refl

-- Same type of proof holds for all other squares due being cut along their diagonals and having the same size

-- SOCRATES: And how many such halves are there in this figure? (BEHD.)
-- BOY: Four.
-- SOCRATES: And how many in this one? (ABCD.)
-- BOY: Two.
-- SOCRATES: And what is the relation of four to two?
-- BOY: Double.
-- SOCRATES: How big is this figure then?
-- BOY: Eight feet.
-- SOCRATES: On what base?
-- BOY: This one.
-- SOCRATES: The line which goes from corner to corner of the square of four feet?
-- BOY: Yes.
-- SOCRATES: The technical name for it is 'diagonal'; so if we use that name, it is your personal opinion that the
--           square on the diagonal of the original square is double its area.
-- BOY: That is so, Socrates.


module Subst

-- This module constructs an expressively typed substitution
-- function 'subst' for substituting variables in the simply-typed
-- lambda calculus.
--
-- The key point is that the expressive type signature of the
-- function 'subst' can be read as the following theorem:
--
--    "Given a context 'ctx' and a variable with
--     de Bruijn index 'i'. Given further the terms
--       ts : Term sctx s, and
--       tt : Term (insertAt i s ctx) t.
--     Then 'subst ts i tt' has type 't' in context '(ctx++sctx)'."
--
-- Note that 'subst ts i tt' is typically written as "tt[ts/(TVar i)]".
--
-- Note that the theorem that is expressed by the type signature
-- of 'subst' is usually referred to as
--
--    *** the substitution lemma ***
--
-- and casually summarized as
--
--    *** substitution preserves type ***.
--

import FinCmp
import Term

%default total

-------------------------------------------------------------
-- Begin: WEAKENING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS

-- Abbreviate the name of the function 'weakenN'
-- from 'Data.Fin' (for better readability):
wkN : (n : Nat) -> Fin m -> Fin (m + n)
wkN = Data.Fin.weakenN

-- Note that we only require weakening of a context 'ctx'
-- by appending another context on the right only.
weakeningPreservesType : {ctx : Context m} -> {ctx' : Context n} ->
                         {i : Fin m} ->
                         (index i ctx = t) ->
                         (index (wkN n i) (ctx ++ ctx') = t)
weakeningPreservesType {ctx = (_::_)}   {i = FZ}      eq = eq
weakeningPreservesType {ctx = (_:: xs)} {i = (FS i')} eq =
  weakeningPreservesType {i = i'} eq

weakenContext : {m : Nat} -> (ctx : Context m) ->
                {n : Nat} -> (ctx' : Context n) ->
                Term ctx t ->
                Term (ctx ++ ctx') t
weakenContext ctx {n = n} ctx' (TVar i {prf = p}) =
  TVar (wkN n i) {prf = weakeningPreservesType p}
--
weakenContext ctx ctx' (TAbs {s} e)    = TAbs (weakenContext (s::ctx) ctx' e)
weakenContext ctx ctx' (TApp e1 e2)    = TApp (weakenContext ctx ctx' e1)
                                              (weakenContext ctx ctx' e2)
weakenContext ctx ctx' (TFix e)        = TFix (weakenContext ctx ctx' e)
weakenContext _   _    TZero           = TZero
weakenContext ctx ctx' (TSucc e)       = TSucc (weakenContext ctx ctx' e)
weakenContext ctx ctx' (TPred e)       = TPred (weakenContext ctx ctx' e)
weakenContext ctx ctx' (TIfz e1 e2 e3) = TIfz (weakenContext ctx ctx' e1)
                                              (weakenContext ctx ctx' e2)
                                              (weakenContext ctx ctx' e3)

-- End: WEAKENING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS
-----------------------------------------------------------

-----------------------------------------------------------------
-- Begin: TECHNICAL LEMMATA ABOUT INDEXING INTO MODIFIED CONTEXTS

-- Function 'lookupInserted' yields a proof of the following:
--
--     "Let ctx' = insertAt i s ctx, and let i = j.
--      If (index j ctx' = t), then t = s."
--
lookupInserted : {ctx : Context n} -> {s : Ty} -> {t : Ty} ->
                 {i : Fin (S n)} -> {j : Fin (S n)} ->
                 i = j ->
                 index j (insertAt i s ctx) = t ->
                 t = s
lookupInserted                {i = FZ}      {j = FZ}      _  prf = sym prf
lookupInserted {ctx} {s} {t}  {i = FZ}      {j = (FS j')} eq prf =
  sym $ replace {P = \k => index k (insertAt FZ s ctx) = t} (sym eq) prf
--
lookupInserted {ctx} {s} {t}  {i = (FS i')} {j = FZ}      eq prf =
  sym $ replace {P = \k => index FZ (insertAt k s ctx) = t} eq prf
--
lookupInserted {ctx = (_::_)} {i = (FS i')} {j = (FS j')} eq  prf =
  lookupInserted (FSinjective eq) prf

-- Function 'shiftDown' yields a proof of the following:
--
--     "Let ctx' = insertAt i s ctx, and let i < (j+1).
--      If (index (j+1) ctx' = t), then (index j ctx = t)."
--
shiftDown : {ctx : Context n} -> {s : Ty} ->
            {i : Fin (S n)} -> {j : Fin n} ->
            i :<: (FS j) ->
            index (FS j) (insertAt i s ctx) = t ->
            index j ctx = t
--
shiftDown {i = FZ}     {j = _}      _  prf = prf
shiftDown {i = (FS _)} {j = FZ}     lt prf =
  absurd $ finNotLtZ $ finLtPred lt
--
shiftDown {ctx = (_::xs)} {s} {i = (FS i')} {j = (FS j')} lt prf =
  shiftDown {ctx = xs} {s} {i = i'} {j = j'} (finLtPred lt) prf

-- Function 'indexZeroLemma' yields a proof of the following:
--
--     "Let ctx a non-empty context, and let ctx' = insertAt t (i+1) ctx.
--      Then, (index 0 ctx') = (index 0 ctx)."
--
indexZeroLemma : {ctx : Context (S n)} ->
                 (i : Fin (S n)) ->
                 index FZ (insertAt (FS i) t ctx) = index FZ ctx
--
indexZeroLemma {ctx = (_::_)} _ = Refl

-- Function 'pushLemma' yields a proof of the following:
--
--    "Let ctx be a context, and let (index i ctx = t).
--     Then, index (i+1) (s::ctx) = t."
--
pushLemma : (s : Ty) ->
            index i ctx = t ->
            index (FS i) (s::ctx) = t
pushLemma _ eq = eq

-- Function 'tightenBound' yields a proof of the following:
--
--     "Let ctx be a context, and let ctx' = insertAt i s ctx.
--      If (j < i) and (index j ctx' = t), then index j ctx = t."
--
-- The function 'tightenBound' returns a dependent pair.
--
-- The first component of the pair is 'j_', which represents
-- the same value as the function argument 'j' (as natural
-- numbers); but note that the bound on the ordinal 'j_' has
-- been tightened (by using the assumption "j < i"):
--   "j_ : Fin n"  while  "j : Fin (S n)".
--
-- The second component of the dependent pair is a proof of
--   "index j_ ctx = t".
--
tightenBound :  {n : Nat} -> {ctx : Context n} ->
                (j : Fin (S n)) -> {i : Fin (S n)} ->
                j :<: i ->
                index j (insertAt i s ctx) = t ->
                (j_ : Fin n ** (index j_ ctx = t))
--
tightenBound                 _       {i = FZ}      lt _  =
  absurd $ finNotLtZ lt
--
tightenBound {n = (S n')}    FZ      {i = (FS i')} _  eq =
  let izl = indexZeroLemma i'
      eq_ = trans (sym izl) eq
  in (FZ ** eq_)
--
tightenBound {ctx = (x::xs)} (FS j') {i = (FS i')} lt eq =
  let (j_ ** eq_) = tightenBound {ctx = xs} j' (finLtPred lt) eq
  in (FS j_ ** pushLemma x eq_)

-- When adding variables in 'ctx' in the middle of
-- a context 'ctx1++ctx2', de Bruijn indices must
-- be adjusted accordingly:
shift : {ctx1 : Context n1} -> {ctx2 : Context n2} -> {i : Fin (n1+n2)} ->
        (ctx : Context n) -> index i (ctx1++ctx2) = t ->
        (i' : Fin (n1+(n+n2)) ** index i' (ctx1++(ctx++ctx2)) = t)
shift {ctx1 = []}         {i}         []       eq = (i ** eq)
--
shift {ctx1 = []}         {i}         (c::ctx) eq =
  let (i' ** eq') = shift {ctx1=[]} ctx eq
  in (FS i' ** eq')
shift {ctx1 = (_::ctx1')} {i = FZ}    ctx      eq = (FZ ** eq)
--
shift {ctx1 = (_::ctx1')} {i = FS i'} ctx      eq =
  let (i' ** eq') = shift {ctx1=ctx1'} ctx eq
  in (FS i' ** eq')

shiftTerm : (ctx : Context n) -> Term (ctx1++ctx2) t ->
            Term (ctx1++(ctx++ctx2)) t
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TVar i {prf}) =
  let (i' ** prf') = shift {ctx1=ctx1} {ctx2=ctx2} ctx prf
  in TVar i' {prf=prf'}
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} {t = t1 :->: t2} ctx (TAbs e) =
  let e' = shiftTerm {ctx1=(t1::ctx1)} {ctx2=ctx2} ctx e
  in TAbs e'
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TApp e1 e2) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
  in TApp e1' e2'
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TFix e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TFix e'
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx TZero = TZero
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TSucc e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TSucc e'
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TPred e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TPred e'
--
shiftTerm {n = n} {ctx1 = ctx1} {ctx2 = ctx2} ctx (TIfz e1 e2 e3) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
      e3' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e3
  in TIfz e1' e2' e3'

-- End: TECHNICAL LEMMATA ABOUT INDEXING INTO MODIFIED CONTEXTS
---------------------------------------------------------------

-----------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var' : Term sctx s ->      -- Term of type 's' is subtituted in.
             (i : Fin (S n)) ->  -- The i-th variable (Var i) is substituted for.
             (j : Fin (S n)) ->  -- Substitution takes place inside the term (Var j).
             index j (insertAt i s ctx) = t ->
             Term (ctx++sctx) t
subst_var' {sctx} {ctx} {s} {t} ts i j prf = case finCmpDec i j of
--
-- An actual substitution occurs only if "i = j".
--
-- For "i /= j" no substitution occurs, but the proof 'prf'
-- in the returned expression 'TVar _ {prf}' has to be
-- adjusted to account for the fact that the context has
-- been shortened from (insertAt s i ctx) to 'ctx'.
  CmpEq eq => let eq' = lookupInserted eq prf
                  ts' = shiftTerm {ctx1 = []} {ctx2 = sctx} ctx ts
              in rewrite eq' in ts'
  CmpLt lt => case j of
    FZ    => absurd $ finNotLtZ lt
    FS j' => let t' = TVar j' {ctx = ctx} {prf = shiftDown lt prf}
             in weakenContext ctx sctx t'
  CmpGt gt => case i of
    FZ    => absurd $ finNotLtZ gt
    FS i' => let (j_ ** prf_) = tightenBound j gt prf
                 t' = TVar j_ {ctx = ctx} {prf = prf_}
             in weakenContext ctx sctx t'

export subst : Term sctx s ->                -- Term of type 's' is substituted in.
               (i : Fin (S n)) ->            -- The i-th varibale (Var i) is substituted for.
               Term (insertAt i s ctx) t ->  -- Substitution takes place inside this
                                             -- term of type 't'
               Term (ctx++sctx) t            -- The resulting term is again of type 't'.
--
-- The hard part is substitution in expressions that
-- are variables, i.e. substitution in 'Var j'.
subst ts i (TVar j {prf}) = subst_var' ts i j prf
--
-- Substitution in expressions that are not variables
-- is handled by recursing over (and substituting in)
-- subexpressions:
--
subst {ctx} {t = t1:->:t2} ts i (TAbs e) =
  TAbs $ subst {ctx=t1::ctx} ts (FS i) e
--
subst ts i (TApp e1 e2)    = TApp (subst ts i e1) (subst ts i e2)
subst ts i (TFix e)        = TFix (subst ts i e)
subst _  _ TZero           = TZero
subst ts i (TSucc e)       = TSucc (subst ts i e)
subst ts i (TPred e)       = TPred (subst ts i e)
subst ts i (TIfz e1 e2 e3) = TIfz (subst ts i e1) (subst ts i e2) (subst ts i e3)

-- End: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------------

------------------------------
-- Begin: STRUCTURAL RELATIONS
--
-- Terms always exist in a specific context. As a consequence, terms with different
-- contexts cannot be equal. In fact, they cannot even be compared because the contexts
-- are part of the (Idris) type of a term and therefore comparing terms that exist in
-- different contexts means attempting to compare Idris expressions at different Idris types.
--
-- The following defines relations (data types suffixed with 'R') that hold between
-- structurally equal terms, even if the terms are typed in different contexts.
-- The main result this leads to is captured by the function 'ctxREq' which shows
-- that two terms that are structurally equal and typed in the same context are
-- in fact equal.

-- Finite numbers can be structurally equal even
-- if subject to different bounds 'm' and 'n':
data FinR : {m : Nat} -> {n : Nat} ->
            Fin m -> Fin n -> Type where
  FRZ : FinR (FZ {k=m}) (FZ {k=n})
  FRS : FinR i j -> FinR (FS i) (FS j)

-- The relation 'FinR' holds, for example, bewteen
-- a bounded number 'i' and a weakened version of 'i'
-- where the bound has been weakend with '0':
weakenZeroFinR : (i : Fin m) -> FinR {m=(m+0)} {n=m} (weakenN 0 i) i
weakenZeroFinR FZ      = FRZ
weakenZeroFinR (FS i') = FRS $ weakenZeroFinR i'

-- If 'FinR' holds between finite numbers that are subject
-- to the same bound 'n', then the numbers are equal:
finREq : (i : Fin n) -> (j : Fin n) -> FinR i j -> i = j
finREq FZ      FZ      FRZ      = Refl
finREq (FS i') (FS j') (FRS fr) = cong $ finREq i' j' fr

-- The relation 'TermCtxR' holds for terms that
-- are structurally equal even if typed in different
-- contexts 'ctx1' and 'ctx2':
data TermCtxR : {ctx1 : Context m} -> {ctx2: Context n} ->
                Term ctx1 t -> Term ctx2 t -> Type where
  TCRVar  : {prf1 : index i ctx1 = t} -> {prf2 : index j ctx2 = t} ->
            FinR i j ->
            TermCtxR {ctx1=ctx1} {ctx2=ctx2}
                     (TVar {ctx=ctx1} i {prf=prf1})
                     (TVar {ctx=ctx2} j {prf=prf2})
  --
  TCRAbs  : TermCtxR {ctx1=(t::ctx1')} {ctx2=(t::ctx2')} e e' ->
            TermCtxR {ctx1=ctx1'} {ctx2=ctx2'} (TAbs e) (TAbs e')
  --
  TCRApp  : TermCtxR e1 e1' -> TermCtxR e2 e2' ->
            TermCtxR (TApp e1 e2) (TApp e1' e2')
  --
  TCRFix  : TermCtxR e e' -> TermCtxR (TFix e) (TFix e')
  --
  TCRZero : TermCtxR TZero TZero
  --
  TCRSucc : TermCtxR e e' ->
            TermCtxR (TSucc e) (TSucc e')
  --
  TCRPred : TermCtxR e e' -> TermCtxR (TPred e) (TPred e')
  --
  TCRIfz  : TermCtxR e1 e1' -> TermCtxR e2 e2' -> TermCtxR e3 e3' ->
            TermCtxR (TIfz e1 e2 e3) (TIfz e1' e2' e3')

-- Structural equality of terms 'e1' and 'e2' in the
-- same context 'ctx' implies equality 'e1 = e2:
ctxREq : (e1 : Term ctx t) -> (e2 : Term ctx t) -> TermCtxR e1 e2 -> e1 = e2
--
ctxREq {ctx} {t} (TVar i {prf=prf1}) (TVar j {prf=prf2}) (TCRVar fr) =
  case finREq i j fr of
       Refl => case prf1 of
                    Refl => case prf2 of
                                 Refl => Refl
               -- By matching on the equality proofs 'prf1' and 'prf2' one
               -- effectively ends up using "uniqueness of identity proofs":
               -- Both proofs are matched to the same constructor 'Refl',
               -- and this causes Idris to refine the two arguments of 'ctxREq'
               -- to identical (Idris) expressions, i.e. 'TVar i {prf=Refl}'.
--
ctxREq (TAbs e) (TAbs e') (TCRAbs r) = cong $ ctxREq e e' r
--
ctxREq (TApp e1 e2) (TApp e1' e2') (TCRApp r1 r2) =
  let eq1 = ctxREq e1 e1' r1
      eq2 = ctxREq e2 e2' r2
  in rewrite eq1 in rewrite eq2 in Refl
--
ctxREq (TFix e) (TFix e') (TCRFix r) = cong $ ctxREq e e' r
--
ctxREq TZero TZero TCRZero = Refl
--
ctxREq (TSucc e) (TSucc e') (TCRSucc r) = cong $ ctxREq e e' r
--
ctxREq (TPred e) (TPred e') (TCRPred r) = cong $ ctxREq e e' r
--
ctxREq (TIfz e1 e2 e3) (TIfz e1' e2' e3') (TCRIfz r1 r2 r3) =
  let eq1 = ctxREq e1 e1' r1
      eq2 = ctxREq e2 e2' r2
      eq3 = ctxREq e3 e3' r3
  in rewrite eq1 in rewrite eq2 in rewrite eq3 in Refl

-- Weakening the context 'ctx' of a term 'e' with the empty context '[]'
-- retains the term's structure, i.e. the relation 'TermCtxR' holds
-- between the original term and the weakend one:
weakenEmptyCtxR : (e : Term ctx t) ->
                  TermCtxR {ctx1=(ctx++[])} {ctx2=ctx} (weakenContext ctx [] e) e
--
weakenEmptyCtxR {ctx} (TVar i {prf}) = TCRVar {ctx1=(ctx++[])} {ctx2=ctx} {prf2=prf}
                                              (weakenZeroFinR i)
--
weakenEmptyCtxR (TAbs e)        = TCRAbs (weakenEmptyCtxR e)
weakenEmptyCtxR (TApp e1 e2)    = TCRApp (weakenEmptyCtxR e1) (weakenEmptyCtxR e2)
weakenEmptyCtxR (TFix e)        = TCRFix (weakenEmptyCtxR e)
weakenEmptyCtxR TZero           = TCRZero
weakenEmptyCtxR (TSucc e)       = TCRSucc (weakenEmptyCtxR e)
weakenEmptyCtxR (TPred e)       = TCRPred (weakenEmptyCtxR e)
weakenEmptyCtxR (TIfz e1 e2 e3) = TCRIfz (weakenEmptyCtxR e1)
                                         (weakenEmptyCtxR e2)
                                         (weakenEmptyCtxR e3)

-- Finally, the previous developments of structural equality can be
-- used to show that a term 'e' remains unchanged when its context
-- is weakend with the empty context '[]':
weakenEmptyWithEmpty : (e : Term [] t) -> weakenContext [] [] e = e
weakenEmptyWithEmpty e = let wCtxR = weakenEmptyCtxR e
                         in ctxREq (weakenContext [] [] e) e wCtxR

-- Define 'omega' to be the diverging term that
-- is the fix-point of the identity function:
public export omega : Term [] TyNat
omega = TFix (TAbs $ TVar FZ)

-- To show (later) that 'omega' diverges, one needs the result that
-- substituting 'omega' into a single variable 'TVar FZ' reproduces
-- the term 'omega' itself:
export substOmega : subst {ctx=[]} {s=TyNat} {t=TyNat} Subst.omega FZ (TVar FZ) = Subst.omega
-- Note that while 'substOmega' is a special case of the more general
-- result 'substInVar' (see above), the general result is in fact not
-- needed. This is because the Idris type checker can evaluate
-- 'weakenContext _ _ omega' (resulting from 'subst'), but it cannot
-- evaluate 'weakenContext _ _ e' for a variable 'e' because 'weakenContext'
-- is defined by recursion on the structure of 'e'.
substOmega = Refl

-- End: STRUCTURAL RELATIONS
----------------------------


module Data.Time.Calendar.MonthDay

import Data.Vect
import Data.Fin
import public Data.Time.Calendar.Types

%default total

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

export monthLengths : Bool -> Vect 12 DayOfMonth
monthLengths isleap = [
  31, (if isleap then 29 else 28), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ]

 -- | The length of a given month in the Gregorian or Julian calendars.
 -- First arg is leap year flag.
export monthLength : Bool -> MonthOfYear -> DayOfMonth
monthLength isLeap month = index (restrict 11 $ cast $ month - 1) $ monthLengths isLeap

||| Convert month and day in the Gregorian or Julian calendars to day of year.
||| First arg is leap year flag.
export monthAndDayToDayOfYear : Bool -> MonthOfYear -> DayOfMonth -> DayOfYear
monthAndDayToDayOfYear isLeap month day =
  let m' = if month < 1 then 1 else if month > 12 then 12 else month
      ml = monthLength isLeap m'
      d' = if day < 1 then 1 else if day > ml then ml else day
      k = if m' <= 2 then 0 else if isLeap then -1 else -2
   in ((367 * m' - 362) `div` 12) + cast k + d'

||| Convert month and day in the Gregorian or Julian calendars to day of year.
-- First arg is leap year flag.
export monthAndDayToDayOfYearValid : Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfYear
monthAndDayToDayOfYearValid isLeap month day =
  if month < 1 || month > 12
    then Nothing
    else
      let ml = monthLength isLeap month
          k = if month < 2 then 0 else if isLeap then -1 else -2
       in if day < 1 || day > ml
             then Nothing
             else Just $ ((367 * month - 362) `div` 12) + cast k + day

findMonthDay : Int -> Vect _ DayOfMonth -> Int -> (Int, Int)
findMonthDay m (n::ns) yd =
  if yd > n then findMonthDay (m + 1) ns (yd - n)
            else (m, yd)
findMonthDay m [] yd = (m, yd)

||| Convert day of year in the Gregorian or Julian calendars to month and day.
||| First arg is leap year flag.
export dayOfYearToMonthAndDay : Bool -> DayOfYear -> (MonthOfYear, DayOfMonth)
dayOfYearToMonthAndDay isLeap yd =
 let yl = the Int $ if isLeap then 366 else 365
  in findMonthDay 1
                  (monthLengths isLeap)
                  (if yd < 1 then 1 else if yd > yl then yl else yd)

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


module permutation

import Data.Vect
import Data.Fin

%access public export

||| Vectors of Natural numbers
total
NatVect : Nat -> Type
NatVect n = Vect n Nat

||| The type Fin n -> Fin n
total
F_Fin : Nat -> Type
F_Fin n = (Fin n) -> (Fin n)

||| Identity function
total
Idt : (t : Type) -> t -> t
Idt s a = a

||| The type of permutation/bijection of {1,...,n}.
||| Notice that for finite sets one sided inverse is enough.
||| Also I have a strong feeling that using univalence the last part of the definition is
||| equivalent to saying that (g . f) and Idt are equivalent
total
Perm : Nat -> Type
Perm n = ( f : F_Fin n ** ( g : F_Fin n ** ((a : (Fin n)) -> ((g (f a)) = a))))

||| Second definition of perm. I have strong feeling that using univalence this is equivalent
||| to the first definition.
total
Perm2 : Nat -> Type
Perm2 n = ( f : F_Fin n ** ( g : F_Fin n ** ((g . f) = (Idt (Fin n)))))

||| Nat to Fin
total
NatToFin : (k : Nat) -> (n : Nat) -> (pf : LTE (S k) n) -> (Fin n)
NatToFin k Z pf impossible
NatToFin Z (S n) pf = FZ
NatToFin (S k) (S n) (LTESucc pf) = FS (NatToFin k n pf)

||| applying a function on Finite sets on a vector
total
applyFun : (n : Nat)  -> (k : Nat) -> (v : NatVect n) ->
           (f : F_Fin n) -> (pf : (LTE k n))
            -> (NatVect k)

applyFun n Z v f pf = []
applyFun n (S k) v f pf = reverse((Vect.index (f (NatToFin k n pf)) v) :: reverse((applyFun n k v f (prop k n pf)))) where
    prop : (a : Nat) -> (b : Nat) -> (LTE (S a) b) -> (LTE a b)
    prop Z b pf2 = LTEZero
    prop (S a) (S b) (LTESucc pf2) = LTESucc (prop a b pf2)