= Induction : Proof by Induction

> module Induction

First, we import all of our definitions from the previous chapter.

> import Basics

Next, we import the following \idr{Prelude} modules, since we'll be dealing with
natural numbers.

> import Prelude.Interfaces
> import Prelude.Nat

For \idr{import Basics} to work, you first need to use `idris` to compile
`Basics.lidr` into `Basics.ibc`. This is like making a .class file from a .java
file, or a .o file from a .c file. There are at least two ways to do it:

  - In your editor with an Idris plugin, e.g. [Emacs][idris-mode]:

    Open `Basics.lidr`. Evaluate \idr{idris-load-file}.

    There exists similar support for [Vim][idris-vim], [Sublime
    Text][idris-sublime] and [Visual Studio Code][idris-vscode] as well.

    [idris-mode]: https://github.com/idris-hackers/idris-mode
    [idris-vim]: https://github.com/idris-hackers/idris-vim
    [idris-sublime]: https://github.com/idris-hackers/idris-sublime
    [idris-vscode]: https://github.com/zjhmale/vscode-idris

  - From the command line:

    Run \mintinline[]{sh}{idris --check --total --noprelude src/Basics.lidr}.

    Refer to the Idris man page (or \mintinline[]{sh}{idris --help} for
    descriptions of the flags.

> %access public export

> %default total

== Proof by Induction

We proved in the last chapter that \idr{0} is a neutral element for \idr{+} on
the left using an easy argument based on simplification. The fact that it is
also a neutral element on the _right_...

```coq
Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.
```

... cannot be proved in the same simple way in Coq, but as we saw in `Basics`,
Idris's \idr{Refl} just works.

To prove interesting facts about numbers, lists, and other inductively defined
sets, we usually need a more powerful reasoning principle: _induction_.

Recall (from high school, a discrete math course, etc.) the principle of
induction over natural numbers: If \idr{p n} is some proposition involving a
natural number \idr{n} and we want to show that \idr{p} holds for _all_ numbers
\idr{n}, we can reason like this:

  - show that \idr{p Z} holds;
  - show that, for any \idr{k}, if \idr{p k} holds, then so does \idr{p (S k)};
  - conclude that \idr{p n} holds for all \idr{n}.

In Idris, the steps are the same and can often be written as function clauses by
case splitting. Here's how this works for the theorem at hand.

> plus_n_Z : (n : Nat) -> n = n + 0
> plus_n_Z  Z    = Refl
> plus_n_Z (S k) =
>   let inductiveHypothesis = plus_n_Z k in
>     rewrite inductiveHypothesis in Refl

In the first clause, \idr{n} is replaced by \idr{Z} and the goal becomes \idr{0
= 0}, which follows by \idr{Refl}exivity. In the second, \idr{n} is replaced by
\idr{S k} and the goal becomes \idr{S k = S (plus k 0)}. Then we define the
inductive hypothesis, \idr{k = k + 0}, which can be written as \idr{plus_n_Z k},
and the goal follows from it.

> minus_diag : (n : Nat) -> minus n n = 0
> minus_diag  Z    = Refl
> minus_diag (S k) = minus_diag k

==== Exercise: 2 stars, recommended (basic_induction)

Prove the following using induction. You might need previously proven results.

> mult_0_r : (n : Nat) -> n * 0 = 0
> mult_0_r n = ?mult_0_r_rhs

> plus_n_Sm : (n, m : Nat) -> S (n + m) = n + (S m)
> plus_n_Sm n m = ?plus_n_Sm_rhs

> plus_comm : (n, m : Nat) -> n + m = m + n
> plus_comm n m = ?plus_comm_rhs

> plus_assoc : (n, m, p : Nat) -> n + (m + p) = (n + m) + p
> plus_assoc n m p = ?plus_assoc_rhs

$\square$

==== Exercise: 2 stars (double_plus)

Consider the following function, which doubles its argument:

> double : (n : Nat) -> Nat
> double  Z    = Z
> double (S k) = S (S (double k))

Use induction to prove this simple fact about \idr{double}:

> double_plus : (n : Nat) -> double n = n + n
> double_plus n = ?double_plus_rhs

$\square$

==== Exercise: 2 stars, optional (evenb_S)

One inconvenient aspect of our definition of \idr{evenb n} is that it may need
to perform a recursive call on \idr{n - 2}. This makes proofs about \idr{evenb
n} harder when done by induction on \idr{n}, since we may need an induction
hypothesis about \idr{n - 2}. The following lemma gives a better
characterization of \idr{evenb (S n)}:

> evenb_S : (n : Nat) -> evenb (S n) = not (evenb n)
> evenb_S n = ?evenb_S_rhs

$\square$

== Proofs Within Proofs

\ \todo[inline]{Edit the section}

In Coq, as in informal mathematics, large proofs are often broken into a
sequence of theorems, with later proofs referring to earlier theorems. But
sometimes a proof will require some miscellaneous fact that is too trivial and
of too little general interest to bother giving it its own top-level name. In
such cases, it is convenient to be able to simply state and prove the needed
"sub-theorem" right at the point where it is used. The `assert` tactic allows us
to do this. For example, our earlier proof of the \idr{mult_0_plus} theorem
referred to a previous theorem named \idr{plus_Z_n}. We could instead use
`assert` to state and prove \idr{plus_Z_n} in-line:

> mult_0_plus' : (n, m : Nat) -> (0 + n) * m = n * m
> mult_0_plus' n m = Refl

The `assert` tactic introduces two sub-goals. The first is the assertion itself;
by prefixing it with `H:` we name the assertion `H`. (We can also name the
assertion with `as` just as we did above with `destruct` and `induction`, i.e.,
`assert (0 + n = n) as H`.) Note that we surround the proof of this assertion
with curly braces `{ ... }`, both for readability and so that, when using Coq
interactively, we can see more easily when we have finished this sub-proof. The
second goal is the same as the one at the point where we invoke `assert` except
that, in the context, we now have the assumption `H` that `0 + n = n`. That is,
`assert` generates one subgoal where we must prove the asserted fact and a
second subgoal where we can use the asserted fact to make progress on whatever
we were trying to prove in the first place.

The `assert` tactic is handy in many sorts of situations. For example, suppose
we want to prove that `(n + m) + (p + q) = (m + n) + (p + q)`. The only
difference between the two sides of the `=` is that the arguments `m` and `n` to
the first inner `+` are swapped, so it seems we should be able to use the
commutativity of addition (`plus_comm`) to rewrite one into the other. However,
the `rewrite` tactic is a little stupid about _where_ it applies the rewrite.
There are three uses of `+` here, and it turns out that doing `rewrite ->
plus_comm` will affect only the _outer_ one...

```idris
plus_rearrange_firsttry : (n, m, p, q : Nat) ->
                          (n + m) + (p + q) = (m + n) + (p + q)
plus_rearrange_firsttry n m p q = rewrite plus_comm in Refl
```
```
When checking right hand side of plus_rearrange_firsttry with expected type
        n + m + (p + q) = m + n + (p + q)

_ does not have an equality type ((n1 : Nat) ->
(n1 : Nat) -> plus n1 m1 = plus m1 n1)
```

To get \idr{plus_comm} to apply at the point where we want it to, we can
introduce a local lemma using the \idr{where} keyword stating that \idr{n + m =
m + n} (for the particular \idr{m} and \idr{n} that we are talking about here),
prove this lemma using \idr{plus_comm}, and then use it to do the desired
rewrite.

> plus_rearrange : (n, m, p, q : Nat) ->
>                  (n + m) + (p + q) = (m + n) + (p + q)
> plus_rearrange n m p q = rewrite plus_rearrange_lemma n m in Refl
>   where
>   plus_rearrange_lemma : (n, m : Nat) -> n + m = m + n
>   plus_rearrange_lemma = plus_comm

== More Exercises

==== Exercise: 3 stars, recommended (mult_comm)

Use \idr{rewrite} to help prove this theorem. You shouldn't need to use
induction on \idr{plus_swap}.

> plus_swap : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
> plus_swap n m p = ?plus_swap_rhs

Now prove commutativity of multiplication. (You will probably need to define and
prove a separate subsidiary theorem to be used in the proof of this one. You may
find that \idr{plus_swap} comes in handy.)

> mult_comm : (m, n : Nat) -> m * n = n * m
> mult_comm m n = ?mult_comm_rhs

$\square$

==== Exercise: 3 stars, optional (more_exercises)

\ \todo[inline]{Edit}

Take a piece of paper. For each of the following theorems, first _think_ about
whether (a) it can be proved using only simplification and rewriting, (b) it
also requires case analysis (`destruct`), or (c) it also requires induction.
Write down your prediction. Then fill in the proof. (There is no need to turn in
your piece of paper; this is just to encourage you to reflect before you hack!)

> lte_refl : (n : Nat) -> True = lte n n
> lte_refl n = ?lte_refl_rhs

> zero_nbeq_S : (n : Nat) -> 0 == (S n) = False
> zero_nbeq_S n = ?zero_nbeq_S_rhs

> andb_false_r : (b : Bool) -> b && False = False
> andb_false_r b = ?andb_false_r_rhs

> plus_ble_compat_l : (n, m, p : Nat) ->
>                     lte n m = True -> lte (p + n) (p + m) = True
> plus_ble_compat_l n m p prf = ?plus_ble_compat_l_rhs

> S_nbeq_0 : (n : Nat) -> (S n) == 0 = False
> S_nbeq_0 n = ?S_nbeq_0_rhs

> mult_1_l : (n : Nat) -> 1 * n = n
> mult_1_l n = ?mult_1_l_rhs

> all3_spec : (b, c : Bool) ->
>             (b && c) || ((not b) || (not c)) = True
> all3_spec b c = ?all3_spec_rhs

> mult_plus_distr_r : (n, m, p : Nat) -> (n + m) * p = (n * p) + (m * p)
> mult_plus_distr_r n m p = ?mult_plus_distr_r_rhs

> mult_assoc : (n, m, p : Nat) -> n * (m * p) = (n * m) * p
> mult_assoc n m p = ?mult_assoc_rhs

$\square$

==== Exercise: 2 stars, optional (beq_nat_refl)

\ \todo[inline]{Edit}

Prove the following theorem. (Putting the \idr{True} on the left-hand side of
the equality may look odd, but this is how the theorem is stated in the Coq
standard library, so we follow suit. Rewriting works equally well in either
direction, so we will have no problem using the theorem no matter which way we
state it.)

> beq_nat_refl : (n : Nat) -> True = n == n
> beq_nat_refl n = ?beq_nat_refl_rhs

$\square$

==== Exercise: 2 stars, optional (plus_swap')

\ \todo[inline]{Edit}

The `replace` tactic allows you to specify a particular subterm to rewrite and
what you want it rewritten to: `replace (t) with (u)` replaces (all copies of)
expression `t` in the goal by expression `u`, and generates `t = u` as an
additional subgoal. This is often useful when a plain \idr{rewrite} acts on the
wrong part of the goal.

Use the `replace` tactic to do a proof of \idr{plus_swap'}, just like
\idr{plus_swap} but without needing `assert (n + m = m + n)`.

> plus_swap' : (n, m, p : Nat) -> n + (m + p) = m + (n + p)
> plus_swap' n m p = ?plus_swap__rhs

$\square$

==== Exercise: 3 stars, recommended (binary_commute)

Recall the \idr{incr} and \idr{bin_to_nat} functions that you wrote for the
\idr{binary} exercise in the `Basics` chapter. Prove that the following diagram
commutes:

           bin --------- incr -------> bin
            |                           |
        bin_to_nat                  bin_to_nat
            |                           |
            v                           v
           nat ---------- S ---------> nat

That is, incrementing a binary number and then converting it to a (unary)
natural number yields the same result as first converting it to a natural number
and then incrementing. Name your theorem \idr{bin_to_nat_pres_incr} ("pres" for
"preserves").

Before you start working on this exercise, please copy the definitions from your
solution to the \idr{binary} exercise here so that this file can be graded on
its own. If you find yourself wanting to change your original definitions to
make the property easier to prove, feel free to do so!

$\square$

==== Exercise: 5 stars, advanced (binary_inverse)

This exercise is a continuation of the previous exercise about binary numbers.
You will need your definitions and theorems from there to complete this one.

(a) First, write a function to convert natural numbers to binary numbers. Then
    prove that starting with any natural number, converting to binary, then
    converting back yields the same natural number you started with.

(b) You might naturally think that we should also prove the opposite direction:
    that starting with a binary number, converting to a natural, and then back
    to binary yields the same number we started with. However, this is not true!
    Explain what the problem is.

(c) Define a "direct" normalization function -- i.e., a function \idr{normalize}
    from binary numbers to binary numbers such that, for any binary number b,
    converting to a natural and then back to binary yields \idr{(normalize b)}.
    Prove it. (Warning: This part is tricky!)

Again, feel free to change your earlier definitions if this helps here.

$\square$


import TypedContainers.LawfulOrd

%default total

LawfulOrd Nat where
  compare Z Z = EQ
  compare Z (S _) = LT
  compare (S _) Z = GT
  compare (S x) (S y) = TypedContainers.LawfulOrd.compare x y

  reflexivity Z = Refl
  reflexivity (S x) = reflexivity x

  reversion1 Z Z p impossible
  reversion1 (S _) Z p impossible
  reversion1 Z (S _) p = Refl
  reversion1 (S x) (S y) p =
    let rec = reversion1 x y in
    rec p

  reversion2 Z Z p impossible
  reversion2 (S _) Z p = Refl
  reversion2 Z (S _) p impossible
  reversion2 (S x) (S y) p =
    let rec = reversion2 x y in
    rec p

  reversion3 Z Z p = Refl
  reversion3 (S _) Z p impossible
  reversion3 Z (S _) p impossible
  reversion3 (S x) (S y) p =
    let rec = reversion3 x y in
    rec p

  transitivity Z     Z     Z     p0 p1 impossible
  transitivity Z     Z     (S z) p0 p1 impossible
  transitivity Z     (S y) Z     p0 p1 impossible
  transitivity Z     (S y) (S z) p0 p1 = Refl
  transitivity (S x) Z     Z     p0 p1 impossible
  transitivity (S x) Z     (S z) p0 p1 impossible
  transitivity (S x) (S y) Z     p0 p1 impossible
  transitivity (S x) (S y) (S z) p0 p1 =
    let rec = transitivity x y z p0 p1 in
    rec

  equality1 Z     Z     z     p = Refl
  equality1 Z     (S y) Z     p impossible
  equality1 Z     (S y) (S z) p impossible
  equality1 (S x) Z     Z     p impossible
  equality1 (S x) Z     (S z) p impossible
  equality1 (S x) (S y) Z     p = Refl
  equality1 (S x) (S y) (S z) p =
    let rec = equality1 x y z p in
    rec

  equality2 Z     Z     z     p = Refl
  equality2 Z     (S y) Z     p impossible
  equality2 Z     (S y) (S z) p impossible
  equality2 (S x) Z     Z     p impossible
  equality2 (S x) Z     (S z) p impossible
  equality2 (S x) (S y) Z     p = Refl
  equality2 (S x) (S y) (S z) p =
    let rec = equality2 x y z p in
    rec

LawfullerOrd Nat where
  realEquality Z Z p = Refl
  realEquality Z (S _) p impossible
  realEquality (S _) Z p impossible
  realEquality (S x) (S y) p =
    let rec = realEquality x y p in
    cong S rec


-- Classical logic, PHOAS approach, initial encoding

module Pi.C

%default total

-- Types

data Indiv : Type where
  TODO : Indiv

Ty : Type

Pred : Type
Pred = Indiv -> Ty

infixl 2 :&&
infixl 1 :||
infixr 0 :=>
data Ty : Type where
  UNIT   :             Ty
  (:=>)  : Ty -> Ty -> Ty
  (:&&)  : Ty -> Ty -> Ty
  (:||)  : Ty -> Ty -> Ty
  FALSE  :             Ty
  FORALL : Pred     -> Ty
  EXISTS : Pred     -> Ty

infixr 0 :<=>
(:<=>) : Ty -> Ty -> Ty
(:<=>) a b = (a :=> b) :&& (b :=> a)

NOT : Ty -> Ty
NOT a = a :=> FALSE

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

data El : Type where
  mkTrue  : Ty    -> El
  mkIndiv : Indiv -> El

Cx : Type
Cx = El -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc (mkTrue a)

isIndiv : Indiv -> Cx -> Type
isIndiv x tc = tc (mkIndiv x)

-- Terms

infixl 2 :$$
infixl 1 :$

data Tm : Cx -> Ty -> Type where
  var    : isTrue a tc                           -> Tm tc a
  lam'   : (isTrue a tc -> Tm tc b)              -> Tm tc (a :=> b)
  (:$)   : Tm tc (a :=> b)  -> Tm tc a           -> Tm tc b
  pair   : Tm tc a          -> Tm tc b           -> Tm tc (a :&& b)
  fst    : Tm tc (a :&& b)                       -> Tm tc a
  snd    : Tm tc (a :&& b)                       -> Tm tc b
  left   : Tm tc a                               -> Tm tc (a :|| b)
  right  : Tm tc b                               -> Tm tc (a :|| b)
  case'  : Tm tc (a :|| b)  -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c
  pi'    : ({x : Indiv} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p)
  (:$$)  : Tm tc (FORALL p) -> isIndiv x tc      -> Tm tc (p x)
  sig    : isIndiv x tc     -> Tm tc (p x)       -> Tm tc (EXISTS p)
  split' : Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a
  abort' : (isTrue (NOT a) tc -> Tm tc FALSE)    -> Tm tc a

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

case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

split'' : Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a
split'' x f = split' x $ \y => f (var y)

abort'' : (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a
abort'' f = abort' $ \na => f (var na)

syntax "lam"   {a}  ":=>" [b]           = lam'' (\a => b)
syntax "["     [a]  ","   [b] "]"       = pair a b
syntax "case"  [ab] "of"  {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)
syntax "pi"    {x}  ":=>" [y]           = pi' (\x => y)
syntax "["     [x]  ",,"  [y] "]"       = sig x y
syntax "split" [x]  as    {y} ":=>" [z] = split'' x (\y => z)
syntax "abort" {a}  ":=>" [b]           = abort'' (\a => b)

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

-- Example theorems

t214 : Thm (NOT (FORALL (\x => NOT (p x))) :=> EXISTS p)
t214 =
  lam f :=>
    abort g :=>
      f :$ (pi x :=>
            lam p :=> g :$ [ x ,, p ])


module Eq

import Data.List

%default total

occurrences : Eq ty => ty -> List ty -> Nat
occurrences _ [] = 0
occurrences v (x :: xs) = case v == x of
                               False => occurrences v xs
                               True => 1 + occurrences v xs

data Matter = Solid | Liquid | Gas

{-
  interface Eq ty where
    (==) :: ty -> ty -> Bool
    (/=) :: ty -> ty -> Bool

    (==) x y = not (x /= y)
    (/=) x y = not (x == y)

-}

Eq Matter where
  (==) Solid Solid = True
  (==) Liquid Liquid = True
  (==) Gas Gas = True
  (==) _ _ = False

data Tree elem = Empty | Node (Tree elem) elem (Tree elem)

Eq ty => Eq (Tree ty) where
  (==) Empty Empty = True
  (==) (Node l v r) (Node l' v' r') = l == l' && v == v' && r == r'
  (==) _ _  = False

partial
fromList : List ty -> Tree ty
fromList [] = Empty
fromList [x] = Node Empty x Empty
fromList (x :: xs) = Node (fromList left) x (fromList right)
         where
           len : Nat
           len = integerToNat $ (natToInteger (length xs)) `div` 2

           left : List ty
           left = take len xs

           right : List ty
           right = drop len xs


module Bisim

%default total

corecord Stream' : Type -> Type where
  hd : Stream' a -> a
  tl : Stream' a -> Stream' a
  constructor (::) (hd tl)

ssucc : Stream' Nat -> Stream' Nat
ssucc s = (S (hd s)) :: (ssucc (tl s))

zeros : Stream' Nat
zeros = 0 :: zeros

ones : Stream' Nat
ones = 1 :: ones

twos : Stream' Nat
twos = 2 :: twos

codata BisimStream : Stream' a -> Stream' a -> Type where
  MkBisimStream : (phd : (hd s) = (hd s')) -> (ptl : BisimStream (tl s) (tl s')) -> BisimStream s s'

corecord BisimStream' : (a : Type) -> Stream' a -> Stream' a -> Type where
  phd : BisimStream' a s s' -> (hd s) = (hd s')
  ptl : BisimStream' a s s' -> BisimStream' a (tl s) (tl s')
  constructor MkBisimStream'

bisimsucconestwos : BisimStream' Nat (ssucc ones) twos
bisimsucconestwos = MkBisimStream' Refl bisimsucconestwos

bisim_eq : BisimStream' a s s' -> s = s'
bisim_eq = believe_me

-- repeat : Vect (S n) a -> Stream' a
-- repeat xs = repeat' xs xs
--   where
--   repeat' : Vect (S n) a -> Vect (S m) a -> Stream' a
--   repeat' xs (x :: []) = x :: (repeat' xs xs)
--   repeat' xs (x :: (y :: ys)) = x :: (repeat' xs (y :: ys))

-- zeroone : Vect 2 Nat
-- zeroone = [0, 1]

-- onetwo : Vect 2 Nat
-- onetwo = [1, 2]

-- bisim_succ_repeat_zeroone__repeat_onetwo : BisimStream' Nat (ssucc (repeat zeroone)) (repeat onetwo)
-- bisim_succ_repeat_zeroone__repeat_onetwo = MkBisimStream' Refl help
--   where
--   help : BisimStream' Nat (tl (ssucc (repeat (zeroone)))) (tl (repeat onetwo))
--   help = MkBisimStream' Refl bisim_succ_repeat_zeroone__repeat_onetwo

-- bisim_succ_repeat_zeroone__repeat_onetwo' : BisimStream (ssucc (repeat zeroone)) (repeat onetwo)
-- bisim_succ_repeat_zeroone__repeat_onetwo' = MkBisimStream Refl (MkBisimStream Refl bisim_succ_repeat_zeroone__repeat_onetwo')


import Data.Vect

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

qualify : (name : String) -> (adjective : String) -> String
qualify name adjective = name ++ " is " ++ adjective

repeat : (n : Nat) -> a -> Vect n a
repeat Z x = []
repeat (S k) x = x :: repeat k x

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

insertCol' : (x : Vect n elem) -> (xs : Matrix n len elem) -> Matrix n (S len) elem
insertCol' = zipWith (::)

-- The tutorial shows that just putting an underscore instead
-- of n does the job in this case
-- (An there would be no need for the {n} there)
transpose' : Matrix m n elem -> Matrix n m elem
transpose' {n} [] = repeat n []
transpose' (x :: xs) = insertCol x $ transpose' xs

addMatrix : Num e => Matrix m n e -> Matrix m n e -> Matrix m n e
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = [| x + y |] :: addMatrix xs ys

productSum : Num e => Vect n e -> Vect n e -> e
productSum xs ys = sum [| xs * ys |]

distributeOver : (a -> a -> c)
               -> a -> Vect m a -> Vect m c
distributeOver f x xs = map (f x) xs

multMatrixHelper : Num e => Matrix m n e
                         -> Matrix o n e
                         -> Matrix m o e
multMatrixHelper [] [] = []
multMatrixHelper [] (x :: xs) = []
multMatrixHelper (x :: xs) ys =
  -- let distributed = distributeOver productSum x ys
  let distributed = map (productSum x) ys
  in distributed :: multMatrixHelper xs ys

multMatrix : Num e => Matrix m n e
                   -> Matrix n o e
                   -> Matrix m o e
multMatrix x y = multMatrixHelper x (transpose' y)


module Rationals

import NonZeroInt

-- contrib
import Control.Algebra

%access export
%default total

private
record FreeRational where
  constructor MkFreeRational
  num : Int
  den : NonZeroInt

Rational : Type
Rational = FreeRational

rational : Int -> NonZeroInt -> Rational
rational = MkFreeRational

intAsRational : Int -> Rational
intAsRational n = rational n (MkNonZeroInt 1 oneNotZero)
  where
    distinguish : Int -> Type
    distinguish 0 = Void
    distinguish _ = ()
    oneNotZero = \oneEqualsZero => replace {P=distinguish} oneEqualsZero ()

postulate
rationalQuotient :
     (num1, num2 : Int)
  -> (den1, den2 : NonZeroInt)
  -> (num1 * (num den2) = num2 * (num den1))
  -> rational num1 den1 = rational num2 den2

fold :
     (map : Int -> NonZeroInt -> a)
  -> ( (num1, num2 : Int)
    -> (den1, den2 : NonZeroInt)
    -> (num1 * (num den2) = num2 * (num den1))
    -> map num1 den1 = map num2 den2)
  -> Rational
  -> a
fold map mapCoherence (MkFreeRational num den) = map num den

-- operations on rationals

rationalEq : Rational -> Rational -> Bool
rationalEq (MkFreeRational num1 den1) (MkFreeRational num2 den2) = num1 * (num den2) == num2 * (num den1)

implementation Eq Rational where
  (==) = rationalEq

rationalCompare : Rational -> Rational -> Ordering
rationalCompare (MkFreeRational num1 den1) (MkFreeRational num2 den2) = compare (num1 * (num den2)) (num2 * (num den1))

implementation Ord Rational where
  compare = rationalCompare

rationalAddition : Rational -> Rational -> Rational
rationalAddition (MkFreeRational num1 den1) (MkFreeRational num2 den2) = MkFreeRational
  (num1 * (num den2) + num2 * (num den1)) (productOfNonZeroIsNonZero den1 den2)

[additiveRationalSemigroup] Semigroup Rational where
  (<+>) = rationalAddition

-- the additive monoid is actually unlawful
-- because, in Rational, 0/m + 0/n = 0/(m * n)
-- so the identity laws do not hold
[additiveRationalMonoid] Monoid Rational using additiveRationalSemigroup where
  neutral = intAsRational 0

rationalOpposite : Rational -> Rational
rationalOpposite (MkFreeRational num1 den1) = MkFreeRational (-num1) den1

[additiveRationalGroup] Group Rational using additiveRationalMonoid where
  inverse = rationalOpposite

[additiveRationalAbelianGroup] AbelianGroup Rational using additiveRationalGroup where

rationalMultiplication : Rational -> Rational -> Rational
rationalMultiplication (MkFreeRational num1 den1) (MkFreeRational num2 den2) =
  MkFreeRational (num1 * num2) (productOfNonZeroIsNonZero den1 den2)

[multiplicativeRationalSemigroup] Semigroup Rational where
  (<+>) = rationalMultiplication

[multiplicativeRationalMonoid] Monoid Rational using multiplicativeRationalSemigroup where
  neutral = intAsRational 1

[rationalRing] Ring Rational using additiveRationalAbelianGroup where
  (<.>) = rationalMultiplication

[rationalRingWithUnity] RingWithUnity Rational using rationalRing where
  unity = intAsRational 1

IsNonZero : Rational -> Type
IsNonZero (MkFreeRational 0 den) = Void
IsNonZero a                      = Not (num a = 0)

rationalReciprocal : (a : Rational) -> {auto isNonZero : IsNonZero a} -> Rational
rationalReciprocal (MkFreeRational num1 den1) {isNonZero} = MkFreeRational (num den1) den
  where
    den = MkNonZeroInt num1 (\num1IsZero => replace {P=\n => IsNonZero (MkFreeRational n den1)} num1IsZero isNonZero)

-- the fact that the additive monoid in unlawful forbids us to define a field instance
-- because we have more that one zero


module DatesProblem

import Data.Vect

%default total

{-
  Helpers
-}

||| Generic Type for Non-inclusive Range of Integers
data Range : Integer -> Integer -> Type where
  MkRange : (min : Integer) -> (max : Integer) -> Range min max

||| Proof that an integer is in range
inRange : Range min max -> Integer -> Type
inRange (MkRange min max) x = Dec (x > min = x < max)

{-
  Date Specific
-}

data Year : Type where
  MkYear : (year : Integer) -> Year

%name Year y,y1,y2,y3

isLeap : Year -> Bool
isLeap (MkYear year) = (modNatNZ (toNat year) 4 SIsNotZ) == 0

data Month : Type where
  January   : Month
  February  : Month
  March     : Month
  April     : Month
  May       : Month
  June      : Month
  July      : Month
  August    : Month
  September : Month
  October   : Month
  November  : Month
  December  : Month

%name Month m,m1,m2,m3

monthOrder : Month -> Nat
monthOrder January   = 1
monthOrder February  = 2
monthOrder March     = 3
monthOrder April     = 4
monthOrder May       = 5
monthOrder June      = 6
monthOrder July      = 7
monthOrder August    = 8
monthOrder September = 9
monthOrder October   = 10
monthOrder November  = 11
monthOrder December  = 12

monthDays : Year -> Month -> Integer
monthDays _    January   = 30
monthDays year February  = if isLeap year then 29 else 28
monthDays _    March     = 30
monthDays _    April     = 31
monthDays _    May       = 30
monthDays _    June      = 31
monthDays _    July      = 30
monthDays _    August    = 31
monthDays _    September = 30
monthDays _    October   = 31
monthDays _    November  = 30
monthDays _    December  = 31

previousMonth : Month -> Month
previousMonth January   = December
previousMonth February  = January
previousMonth March     = February
previousMonth April     = March
previousMonth May       = April
previousMonth June      = May
previousMonth July      = June
previousMonth August    = July
previousMonth September = August
previousMonth October   = September
previousMonth November  = October
previousMonth December  = November

data Day : Type where
  MkDay : (day : Nat) -> Day

%name Day d,d1,d2,d3

inDayRange : Nat -> Day -> Type
inDayRange n (MkDay day) =
  let
    n' = toIntegerNat n
    range = (MkRange 1 (n'+1))
    day' = (toIntegerNat day)
  in
    inRange range day'

validDate : Year -> Month -> Day -> Type
validDate year month = inDayRange (toNat $ monthDays year month)

data Date : Type where
  MkDate : (day : Day) ->
           (month : Month) ->
           (year : Year) ->
           { auto p : (validDate year month day) } -> Date

%name Date d,d1,d2,d3

Eq Year where
  (==) (MkYear y) (MkYear y') = y == y'

Eq Month where
  (==) x y  = monthOrder x == monthOrder y

Eq Day where
  (==) (MkDay y) (MkDay y') = y == y'

Eq Date where
  (==) (MkDate d m y) (MkDate d' m' y') = d == d' && m == m' && y == y'

Ord Year where
  compare (MkYear y) (MkYear y') = compare y y'

Ord Month where
  compare x y = compare (monthOrder x) (monthOrder y)

Ord Day where
  compare (MkDay d) (MkDay d') = compare d d'

Ord Date where
  compare (MkDate d m y) (MkDate d' m' y') =
    case compare y y' of
         EQ => case compare m m' of
                    EQ => compare y y'
                    result => result
         result => result

beginIsBeforeEnd : Date -> Date -> Type
beginIsBeforeEnd begin end = case compare begin end of
                                  LT => Dec (begin = begin)
                                  _ => Not (begin = end)

daysToMonth : Year -> Month -> Integer
daysToMonth year month = count (previousMonth month) (monthOrder $ previousMonth month)
  where
    count : Month -> Nat -> Integer
    count m Z = 0
    count m (S k) = (monthDays year m) + count (previousMonth m) k

daysInDate : Date -> Integer
daysInDate (MkDate (MkDay days) month year@(MkYear y)) =
  let
    yearDays = (y - 1) * 365
    monthDays = daysToMonth year month
  in
    yearDays + monthDays + (toIntegerNat days)

distanceBetweenDates : (begin : Date) ->
                       (end : Date) ->
                       { auto prf : (beginIsBeforeEnd begin end) } -> Integer
distanceBetweenDates a b = daysInDate b - daysInDate a

data DateRange : Type where
  MkDateRange : (begin : Date) ->
                (end : Date) ->
                { auto prf : (beginIsBeforeEnd begin end) } ->
                DateRange

%name DateRange dr,dr1,dr2,dr3

distanceInRange : DateRange -> Integer
distanceInRange (MkDateRange begin end) = distanceBetweenDates begin end

{-
  Sample Dates
-}

date_one : Date
date_one = MkDate (MkDay 28) September (MkYear 1991)

date_two : Date
date_two = MkDate (MkDay 29) February (MkYear 2008)

date_three : Date
date_three = MkDate (MkDay 30) September (MkYear 1992)

{-
  Ranges Logic
-}


module Main

%default total

data PowerSource = Petrol | Pedal

{-
4.2 Defining dependent data types
---------------------------------

A dependent data type is a *type* computed from a value.

E.g., : Vect : type of Vect depends on its length.

core idea : because there is no syntactic distinction between types and expressions,
            types can be computed from any expression.

Families of types
-----------------

Vehicle : defines two (i.e., "family") types in one declaration : Vehicle Pedal and Vehicle Petrol.
Defining multiple related types at the same time.
Power source is an index of the Vehicle family.
The index tells you exactly which Vehicle type you mean.
-}
data Vehicle : PowerSource -> Type where
  Bicycle :                 Vehicle Pedal
  Car     : (fuel : Nat) -> Vehicle Petrol
  Bus     : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle _ -> Nat
wheels Bicycle    = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

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


-- Example of a recursive type.
data MyNat = Z | S MyNat

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

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

data Picture = ||| Uses the Shape type defined as the primitive.
               Primitive Shape
             | ||| Builds a picture by combining two smaller pictures.
               Combine Picture Picture
             | ||| Builds a picture by rotating another picture through an angle.
               Rotate Double Picture
             | ||| Builds a picture by moving to another location.
               Translate Double Double Picture

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

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

%name Shape shape, shape1, shape2
%name Picture pic, pic1, pic2

pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic1 pic2) = pictureArea pic1 + pictureArea pic2
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic

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

biggestTriangle : Picture -> Maybe Double
biggestTriangle (Primitive tri@(Triangle x y)) = Just $ area tri
biggestTriangle (Primitive _) = Nothing
biggestTriangle (Combine pic1 pic2) = maybeMax (biggestTriangle pic1) (biggestTriangle pic2)
biggestTriangle (Rotate x pic) = biggestTriangle pic
biggestTriangle (Translate x y pic) = biggestTriangle pic


module Data.ZZ.ZZModulo

import Control.Algebra
import Classes.Verified

import Data.ZZ
import Control.Algebra.NumericInstances

import Data.Fin.FinOrdering
import Data.Fin.Structural

import Control.Algebra.ZZDivisors
import Data.ZZ.ModuloVerification

{-
Table of contents

* Modulo for naturals
* Lemmas for applying (modNatFnIsRemainder)
* Derived modulo for ZZ
-}

{-
Modulo for naturals
-}

||| A manually verifiably total modulo for naturals:
||| It recurses precisely when
||| 	( Not (x `LT` m) ) & ( m, x > 0 ).
||| Not (x `LT` m) -> Either (x = m) (m `LT` x),
||| in former case ((x `minus` m) `modNat` m) is defined,
||| & latter case cannot hold indefinitely since
||| m > 0
||| ==>
||| the iterates of (`minus` m) are decreasing.
%reflection
modNatT : Nat -> Nat -> Nat
modNatT Z _ = Z
modNatT x Z = x
modNatT (S predx) (S predm) with (decLT (S predx) (S predm))
	| No notlt = ((S predx) `minus` (S predm)) `modNatT` (S predm)
	| Yes prlt = S predx

{-
Lemmas for applying (modNatFnIsRemainder)
-}

total
modNatTIdModZero : (x : Nat) -> x `modNatT` Z = x
modNatTIdModZero Z = Refl
modNatTIdModZero (S predx) = Refl

-- The LT implies subtracting m is reversible
total
modNatTCharizLT :
	(x, m : Nat)
	-> (x `LT` m)
	-> x `modNatT` m = x
modNatTCharizLT Z _ _ = Refl
modNatTCharizLT x Z ltpr = void $ succNotLTEzero ltpr
modNatTCharizLT (S predx) (S predm) ltpr with (decLT (S predx) (S predm))
	| No notlt = void $ notlt ltpr
	| Yes prlt = Refl

total
modNatTCharizEq : (m : Nat) -> m `modNatT` m = Z
modNatTCharizEq Z = Refl
modNatTCharizEq (S predm) with (decLT (S predm) (S predm))
	| No notlt = rewrite sym $ minusZeroN predm in Refl
	| Yes prlt = void $ notLTSelf prlt

total
modNatTCharizGTE :
	(x, m : Nat)
	-> (m `plus` x) `modNatT` m = x `modNatT` m
modNatTCharizGTE Z m
	= trans (rewrite plusZeroRightNeutral m in Refl)
	$ modNatTCharizEq m
modNatTCharizGTE x Z = Refl
modNatTCharizGTE (S predx) (S predm) with (decLT (S predm `plus` S predx) (S predm))
	| No notlt = rewrite natPlusInvertibleL (S predx) predm in Refl
	| Yes prlt = void $ notLTSelf $ lteUnsumLeftSummandLeft {y=S predx} prlt

total
modNatTIsRemainder :
	(x, m : Nat)
	-> (d : Nat ** (d `mult` m) `plus` (x `modNatT` m) = x)
modNatTIsRemainder =
	modNatFnIsRemainder
		modNatT
		modNatTIdModZero
		modNatTCharizLT
		modNatTCharizGTE

{-
-- Totally superfluous
modNatTCharizSucc :
	(x, m : Nat)
	-> S x `modNatT` m = (S $ x `modNatT` m) `modNatT` m
modNatTCharizSucc Z _ = ?modNatTCharizSucc_rhs_1
modNatTCharizSucc (S predx) m = ?modNatTCharizSucc_rhs_2
-}

{-
Derived modulo for ZZ
-}

total
modZT : ZZ -> ZZ -> ZZ
modZT = modZGenFn modNatT modNatTIsRemainder

quotientPartModZT :
	(x, m : ZZ)
	-> (x <-> (x `modZT` m)) `quotientOverZZ` m
quotientPartModZT = modZGenQuot modNatT modNatTIsRemainder


module Data.Vect.Quantifiers

import Data.Vect

||| A proof that some element of a vector satisfies some property
|||
||| @ p the property to be satsified
public export
data Any : (0 p : a -> Type) -> Vect n a -> Type where
  ||| A proof that the satisfying element is the first one in the `Vect`
  Here  : {0 xs : Vect n a} -> p x -> Any p (x :: xs)
  ||| A proof that the satsifying element is in the tail of the `Vect`
  There : {0 xs : Vect n a} -> Any p xs -> Any p (x :: xs)

export
implementation Uninhabited (Any p Nil) where
  uninhabited (Here _) impossible
  uninhabited (There _) impossible

||| Eliminator for `Any`
public export
anyElim : {0 xs : Vect n a} -> {0 p : a -> Type} -> (Any p xs -> b) -> (p x -> b) -> Any p (x :: xs) -> b
anyElim _ f (Here p) = f p
anyElim f _ (There p) = f p

||| Given a decision procedure for a property, determine if an element of a
||| vector satisfies it.
|||
||| @ p the property to be satisfied
||| @ dec the decision procedure
||| @ xs the vector to examine
export
any : (dec : (x : a) -> Dec (p x)) -> (xs : Vect n a) -> Dec (Any p xs)
any _ Nil = No uninhabited
any p (x::xs) with (p x)
  any p (x::xs) | Yes prf = Yes (Here prf)
  any p (x::xs) | No prf =
    case any p xs of
      Yes prf' => Yes (There prf')
      No prf' => No (anyElim prf' prf)

||| A proof that all elements of a vector satisfy a property. It is a list of
||| proofs, corresponding element-wise to the `Vect`.
public export
data All : (0 p : a -> Type) -> Vect n a -> Type where
  Nil  : All p Nil
  (::) : {0 xs : Vect n a} -> p x -> All p xs -> All p (x :: xs)

||| If there does not exist an element that satifies the property, then it is
||| the case that all elements do not satisfy.
export
negAnyAll : {xs : Vect n a} -> Not (Any p xs) -> All (Not . p) xs
negAnyAll {xs=Nil} _ = Nil
negAnyAll {xs=(x::xs)} f = (f . Here) :: negAnyAll (f . There)

export
notAllHere : {0 p : a -> Type} -> {xs : Vect n a} -> Not (p x) -> All p (x :: xs) -> Void
notAllHere _ Nil impossible
notAllHere np (p :: _) = np p

export
notAllThere : {0 p : a -> Type} -> {xs : Vect n a} -> Not (All p xs) -> All p (x :: xs) -> Void
notAllThere _ Nil impossible
notAllThere np (_ :: ps) = np ps

||| Given a decision procedure for a property, decide whether all elements of
||| a vector satisfy it.
|||
||| @ p the property
||| @ dec the decision procedure
||| @ xs the vector to examine
export
all : (dec : (x : a) -> Dec (p x)) -> (xs : Vect n a) -> Dec (All p xs)
all _ Nil = Yes Nil
all d (x::xs) with (d x)
  all d (x::xs) | No prf = No (notAllHere prf)
  all d (x::xs) | Yes prf =
    case all d xs of
      Yes prf' => Yes (prf :: prf')
      No prf' => No (notAllThere prf')


module Andb3

andb3 : (a : Bool) -> (b : Bool) -> (c : Bool) -> Bool
andb3 True True True = True
andb3 a b c = False

tabt1 : (andb3 True True True) = True
tabt1 = Refl

tabt2 : (andb3 False True True) = False
tabt2 = Refl

tabt3 : (andb3 True False True) = False
tabt3 = Refl

tabt4 : (andb3 True True False) = False
tabt4 = Refl

tabt5 : (andb3 True False False) = False
tabt5 = Refl

tabt6 : (andb3 False True False) = False
tabt6 = Refl

tabt7 : (andb3 False False True) = False
tabt7 = Refl

tabt8 : (andb3 False False False) = False
tabt8 = Refl

tabt9 : (andb3 False True True) = False
tabt9 = Refl


module Quantities.Core

import public Quantities.FreeAbelianGroup
import public Quantities.Power

%default total
%access public export

||| Elementary quantities
record Dimension where
  constructor MkDimension
  name : String

implementation Eq Dimension where
  (MkDimension a) == (MkDimension b) = a == b

implementation Ord Dimension where
  compare (MkDimension a) (MkDimension b) = compare a b

-- Compound quantities

||| A quantity is a property that can be measured.
Quantity : Type
Quantity = FreeAbGrp Dimension

||| The trivial quantity
Scalar : Quantity
Scalar = unit

||| Create a new quantity.
mkQuantity : List (Dimension, Integer) -> Quantity
mkQuantity = mkFreeAbGrp

infixl 6 </>

-- Synonyms (quantites are multiplied, not added!)
||| Product quantity
(<*>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
(<*>) = (<<+>>)

||| Quotient quantity
(</>) : Ord a => FreeAbGrp a -> FreeAbGrp a -> FreeAbGrp a
a </> b = a <*> freeAbGrpInverse b

||| Convert dimensions to quantities
implicit
dimensionToQuantity : Dimension -> Quantity
dimensionToQuantity = inject

||| Elementary Unit
record ElemUnit (q : Quantity) where
  constructor MkElemUnit
  name : String
  conversionRate : Double

-- ElemUnit with its quantity hidden
data SomeElemUnit : Type where
  MkSomeElemUnit : (q : Quantity) -> ElemUnit q -> SomeElemUnit

quantity : SomeElemUnit -> Quantity
quantity (MkSomeElemUnit q _) = q

elemUnit : (seu : SomeElemUnit) -> ElemUnit (quantity seu)
elemUnit (MkSomeElemUnit _ u) = u

name : SomeElemUnit -> String
name x = name (elemUnit x)

implementation Eq SomeElemUnit where
 a == b = quantity a == quantity b && name a == name b

implementation Ord SomeElemUnit where
  compare a b with (compare (quantity a) (quantity b))
    | LT = LT
    | GT = GT
    | EQ = compare (name a) (name b)

implicit
elemUnitToSomeElemUnitFreeAbGrp : ElemUnit q -> FreeAbGrp SomeElemUnit
elemUnitToSomeElemUnitFreeAbGrp {q} u = inject (MkSomeElemUnit q u)

conversionRate : SomeElemUnit -> Double
conversionRate u = conversionRate (elemUnit u)

joinedQuantity : FreeAbGrp SomeElemUnit -> Quantity
joinedQuantity = lift quantity

data Unit : Quantity -> Type where
  MkUnit : (exponent : Integer) -> (elemUnits : FreeAbGrp SomeElemUnit) ->
           Unit (joinedQuantity elemUnits)

rewriteUnit : r = q -> Unit q -> Unit r
rewriteUnit eq unit = rewrite eq in unit

base10Exponent : Unit q -> Integer
base10Exponent (MkUnit e _) = e

someElemUnitFreeAbGrp : Unit q -> FreeAbGrp SomeElemUnit
someElemUnitFreeAbGrp (MkUnit _ us) = us

implementation Eq (Unit q) where
  x == y = base10Exponent x == base10Exponent y &&
           someElemUnitFreeAbGrp x == someElemUnitFreeAbGrp y

||| The trivial unit
One : Unit Scalar
One = MkUnit 0 neutral

||| Multiples of ten
Ten : Unit Scalar
Ten = MkUnit 1 neutral

||| One hundredth
Percent : Unit Scalar
Percent = MkUnit (-2) neutral

||| One thousandth
Promille : Unit Scalar
Promille = MkUnit (-3) neutral

||| The trivial unit (synonymous with `one`)
UnitLess : Unit Scalar
UnitLess = One

implicit
elemUnitToUnit : {q : Quantity} -> ElemUnit q -> Unit q
elemUnitToUnit {q} u = rewriteUnit eq (MkUnit 0 (inject (MkSomeElemUnit q u)))
  where eq = sym (inject_lift_lem quantity (MkSomeElemUnit q u))

||| Compute conversion factor from the given unit to the base unit of the
||| corresponding quantity.
joinedConversionRate : Unit q -> Double
joinedConversionRate (MkUnit e (MkFreeAbGrp us)) = fromUnits * fromExponent
  where fromUnits    = product $ map (\(u, i) => ((^) @{floatmultpower}) (conversionRate u) i) us
        fromExponent = ((^) @{floatmultpower}) 10 e

||| Constructs a new unit given a name and conversion factor from an existing unit.
defineAsMultipleOf : String -> Double -> Unit q -> ElemUnit q
defineAsMultipleOf name factor unit = MkElemUnit name (factor * joinedConversionRate unit)

-- Syntax sugar for defining new units
syntax "< one" [name] equals [factor] [unit] ">" = defineAsMultipleOf name factor unit

implementation Show (Unit q) where
  show (MkUnit 0 (MkFreeAbGrp [])) = "unitLess"
  show (MkUnit e (MkFreeAbGrp [])) = "ten ^^ " ++ show e
  show (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
    else "ten ^^ " ++ show e ++ " <**> " ++ fromUnits
    where monom : (SomeElemUnit, Integer) -> String
          monom (unit, 1) = name unit
          monom (unit, i) = name unit ++ " ^^ " ++ show i
          fromUnits = monom u ++ concatMap ((" <**> " ++) . monom) us

||| Pretty-print a unit (using only ASCII characters)
showUnit : Unit q -> String
showUnit (MkUnit 0 (MkFreeAbGrp [])) = ""
showUnit (MkUnit e (MkFreeAbGrp [])) = "10^" ++ show e
showUnit (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
  else "10^" ++ show e ++ " " ++ fromUnits
  where monom : (SomeElemUnit, Integer) -> String
        monom (unit, 1) = name unit
        monom (unit, i) = name unit ++ "^" ++ show i
        fromUnits = monom u ++ concatMap ((" " ++) . monom) us

toSuperScript : Char -> Char
toSuperScript '1' = '¹'
toSuperScript '2' = '²'
toSuperScript '3' = '³'
toSuperScript '4' = '⁴'
toSuperScript '5' = '⁵'
toSuperScript '6' = '⁶'
toSuperScript '7' = '⁷'
toSuperScript '8' = '⁸'
toSuperScript '9' = '⁹'
toSuperScript '0' = '⁰'
toSuperScript '-' = '⁻'
toSuperScript x   = x

toSuper : String -> String
toSuper = pack . map toSuperScript . unpack

||| Pretty-print a unit
showUnitUnicode : Unit q -> String
showUnitUnicode (MkUnit 0 (MkFreeAbGrp [])) = ""
showUnitUnicode (MkUnit e (MkFreeAbGrp [])) = "10" ++ toSuper (show e)
showUnitUnicode (MkUnit e (MkFreeAbGrp (u :: us))) = if e == 0 then fromUnits
  else "10" ++ toSuper (show e) ++ " " ++ fromUnits
  where monom : (SomeElemUnit, Integer) -> String
        monom (unit, 1) = name unit
        monom (unit, i) = name unit ++ toSuper (show i)
        fromUnits = monom u ++ concatMap ((" " ++) . monom) us

infixr 10 ^^
||| Power unit
(^^) : Unit q -> (i : Integer) -> Unit (q ^ i)
(^^) (MkUnit e us) i = rewriteUnit eq (MkUnit (i*e) (us ^ i))
  where eq = sym (lift_power_lem quantity us i)

||| Inverse unit (e.g. the inverse of `second` is `one <//> second` a.k.a. `hertz`)
unitInverse : {q : Quantity} -> Unit q -> Unit (freeAbGrpInverse q)
unitInverse {q} u = rewrite (freeabgrppower_correct q (-1))
                    in u ^^ (-1)

infixl 6 <**>,<//>

||| Product unit
(<**>) : Unit r -> Unit s -> Unit (r <*> s)
(<**>) (MkUnit e rs) (MkUnit f ss) = rewriteUnit eq (MkUnit (e+f) (rs <*> ss))
  where eq = sym (lift_mult_lem quantity rs ss)

||| Quotient unit
(<//>) : Unit r -> Unit s -> Unit (r </> s)
(<//>) a b = a <**> unitInverse b

infixl 5 =| -- sensible?
||| Numbers tagged with a unit
data Measurement : {q : Quantity} -> Unit q -> Type -> Type where
  (=|) : a -> (u : Unit q) -> Measurement u a

||| Extract the number
getValue : {q : Quantity} -> {u : Unit q} ->
           Measurement {q} u a -> a
getValue (x =| _) = x

implementation Functor (Measurement {q} u) where
  map f (x =| _) = f x =| u

implementation Eq a => Eq (Measurement {q} u a) where
  (x =| _) == (y =| _) = x == y

implementation Ord a => Ord (Measurement {q} u a) where
  compare (x =| _) (y =| _) = compare x y

implementation Show a => Show (Measurement {q} u a) where
  show (x =| _) = show x ++ " =| " ++ show u

implementation Num a => Semigroup (Measurement {q} u a) where
  (x =| _) <+> (y =| _) = (x + y) =| u

implementation Num a => Monoid (Measurement {q} u a) where
  neutral = fromInteger 0 =| u

implementation (Neg a, Num a) => Group (Measurement {q} u a) where
  inverse (x =| _) = (-x) =| u

implementation (Neg a, Num a) => AbelianGroup (Measurement {q} u a) where

||| Pretty-print a measurement (using only ASCII characters)
showMeasurement : Show a => {q : Quantity} -> {u : Unit q} ->
                  (Measurement u a) -> String
showMeasurement (x =| u) =
  show x ++ (if base10Exponent u == 0 then " " else "*") ++ showUnit u

||| Pretty-print a measurement (using only ASCII characters)
showMeasurementUnicode : Show a => {q : Quantity} -> {u : Unit q} ->
                         (Measurement u a) -> String
showMeasurementUnicode (x =| u) =
  show x ++ (if base10Exponent u == 0 then " " else "·") ++ showUnit u

infixl 5 :|

||| Type synonym for `Measurement`
(:|) : Unit q -> Type -> Type
(:|) = Measurement

||| Flatten nested measurements
joinUnits : {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
            (u :| (v :| a)) -> (u <**> v) :| a
joinUnits ((x =| v) =| u) = x =| (u <**> v)

||| Double with a unit
F : Unit q -> Type
F u = Measurement u Double

infixl 9 |*|,|/|

||| Product measurement
(|*|) : Num a => {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
        u :| a -> v :| a -> (u <**> v) :| a
(|*|) (x =| u) (y =| v) = (x*y) =| (u <**> v)

||| Quotient measurement (the second measurement mustn't be zero!)
(|/|) : {q : Quantity} -> {r : Quantity} -> {u : Unit q} -> {v : Unit r} ->
        F u -> F v -> F (u <//> v)
(|/|) (x =| u) (y =| v) = (x/y) =| (u <//> v)

infixl 10 |^|

||| Power measurement
(|^|) : {q : Quantity} -> {u : Unit q} -> F u -> (i : Integer) -> F (u ^^ i)
(|^|) (x =| u) i = (((^) @{floatmultpower}) x i) =| u ^^ i

||| Square root measurement
sqrt : {q : Quantity} -> {u : Unit q} -> F (u ^^ 2) -> F u
sqrt {q} {u} (x =| _) = (sqrt x) =| u

||| Round measurement to the next integer below
floor : {q : Quantity} -> {u : Unit q} -> F u -> F u
floor = map floor

||| Round measurement to the next integer above
ceiling : {q : Quantity} -> {u : Unit q} -> F u -> F u
ceiling = map ceiling

||| Convert measurements to a given unit
convertTo : {from : Unit q} -> (to : Unit q) -> F from -> F to
convertTo to (x =| from) = (x * (rateFrom / rateTo)) =| to
  where rateFrom = joinedConversionRate from
        rateTo   = joinedConversionRate to

||| Flipped version of `convertTo`
as : {from : Unit q} -> F from -> (to : Unit q) -> F to
as x u = convertTo u x

||| Convert with implicit target unit
convert : {from : Unit q} -> {to : Unit q} -> F from -> F to
convert {to=to} x = convertTo to x

||| Promote values to measurements of the trivial quantity
implicit
toUnitLess : a -> Measurement unitLess a
toUnitLess x = x =| unitLess

implementation Num a => Num (Measurement unitLess a) where
  x + y = (getValue x + getValue y) =| unitLess
  x * y = (getValue x * getValue y) =| unitLess
  fromInteger i = fromInteger i =| unitLess

implementation Neg a => Neg (Measurement unitLess a) where
  negate x = negate (getValue x) =| unitLess
  x - y = (getValue x - getValue y) =| unitLess

implementation Abs a => Abs (Measurement unitLess a) where
  abs x = abs (getValue x) =| unitLess


> module CoinductiveCalculus.CoinductiveCalculus

> import Syntax.PreorderReasoning

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

> %hide Stream
> %hide head
> %hide tail
> %hide (+)
> %hide plusZeroRightNeutral

* Streams

For a type |T|, streams of values of type |T| can be described by values
of type |Stream T| with

> Stream : Type -> Type

The idea is that any |Stream T| has a head and a tail

> head : {T : Type} -> Stream T -> T
> tail : {T : Type} -> Stream T -> Stream T

and that piecing together a |T| with a |Stream T| yields a |Stream T|:

> cons : {T : Type} -> T -> Stream T -> Stream T

The stream operations |head|, |tail| and |cons| are required to fulfil
three properties:

> headConsProp : {T : Type} -> (t : T) -> (s : Stream T) -> head (cons t s) = t

> tailConsProp : {T : Type} -> (t : T) -> (s : Stream T) -> tail (cons t s) = s

> consHeadTailProp : {T : Type} -> (s : Stream T) -> cons (head s) (tail s) = s

* Differentiation and integration

We want to look at differentiation and integration of functions of real
variables from the point of view of streams. More specifically, we want
to understand which properties differentiation and integration have to
fulfill when we consider these operations as operations on streams of
type |Stream R = R -> R|. Here

> R : Type

is meant to represent real numbers and

> F : Type
> F = R -> R

are differentiable and integrable functions on |R|. For the time being,
we represent differentiation and integration through functions

> D : F -> F
> S : R -> R -> F -> R

with |D f| and |S a b f| representing the derivative of |f| and the
integral of |f| on |[a,b]|.

* Head, tail and cons for functions/streams

How can we implement |head| for |Stream R = F|? We have

> headF : F -> R

The natural way to compute a real number from a |f : F| is to simply
evaluate |f|. We require our "real numbers" to contain a zero element

> zero : R

and we define

> headF f = f zero

What about the tail of a function |f|?

> tailF : F -> F

The type of |tailF| is |F -> F|, just like the type of |D|. Thus, we
take

> tailF = D

We are left with the implementation of |consF|:

> consF : R -> F -> F

Of course, we want |headF|, |tailF| and |consF| to fulfill the
properties of stream operations. In particular, we want

< consF (headF f) (tailF f) = f

For |f = consF a g| and our definitions of |headF| and |tailF|, this is
equivalent to

< consF (headF f) (tailF f) = f
<
<   ={ def. of f }=
<
< consF (headF (consF a g)) (tailF (consF a g)) = consF a g
<
<   ={ def. of consF, tailF }=
<
< consF ((consF a g) zero) (D (consF a g)) = consF a g

Sufficient conditions for the last equality to hold are

< (consF a g) zero = a

and

< D (consF a g) = g

The first condition could be fulfilled by defining |consF a g| to be
|const a|. But the second condition requires |consF a g| has to be an
anti-derivative of |g|. This suggests the definition

> (+) : R -> R -> R

> consF a f = \ x => a + S zero x f

where we can think of |(+)| as representing the standard addition on
real numbers.

* Properties of |R|, |D| and |S|

Which properties do |R|, |D| and |S| have to satisfy for |headF|,
|tailF| and |consF| to be stream operations? Our definition already
requires |R| to be equipped with a zero element and with a |(+)|:

< R : Type
< zero : R
< (+) : R -> R -> R

If we also require integration to fulfill

> intProp1 : (a : R) -> (f : F) -> S a a f = zero

and |zero| to be a

> plusZeroRightNeutral : (left : R) -> left + zero = left

We can derive a formal proof of |headF (consF a f) = a|:

> headConsPropF : (a : R) -> (f : F) -> headF (consF a f) = a
> headConsPropF a f = ( headF (consF a f) )
>                   ={ Refl }=
>                     ( headF (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( a + S zero zero f )
>                   ={ cong (intProp1 zero f) }=
>                     ( a + zero )
>                   ={ plusZeroRightNeutral a }=
>                     ( a )
>                   QED

Satisfying |tailF (consF a f) = f| requires some more assumptions.
Consistently with the interpretation of |D f| representing the
derivative of |f|, we need

> derConstZero : (a : R) -> D (const a) = const zero

and

> derLinear1 : (f, g : F) -> D (\ x => f x + g x) = \ x => (D f) x + (D g) x

Moreover |S| has to be an "anti-derivative"

> intAntiDer : (f : F) -> D (\ x => S zero x f) = f

We also need |zero| to be left-neutral

> plusZeroLeftNeutral : (right : R) -> zero + right = right

and equality on |F| to be extensional:

> extEqF : (f, g : F) -> ((x : R) -> f x = g x) -> f = g

With these assumptions, we can derive

> lemma : (f : F) -> (x : R) -> zero + f x = f x
> lemma f x = ( zero + f x )
>           ={ plusZeroLeftNeutral (f x) }=
>             ( f x )
>           QED

and, finally

> tailConsPropF : (a : R) -> (f : F) -> tailF (consF a f) = f
> tailConsPropF a f = ( tailF (consF a f) )
>                   ={ Refl }=
>                     ( tailF (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( D (\ x => a + S zero x f) )
>                   ={ Refl }=
>                     ( D (\ x => (const a) x + (\ y => S zero y f) x) )
>                   ={ derLinear1 (const a) (\ y => S zero y f) }=
>                     ( \ x => (D (const a)) x + (D (\ y => S zero y f)) x )
>                   ={ cong {f = \ h => \ x => h x + (D (\ y => S zero y f)) x } (derConstZero a) }=
>                     ( \ x => (const zero) x + (D (\ y => S zero y f)) x )
>                   ={ cong {f = \ h => \ x => (const zero) x + h x} (intAntiDer f) }=
>                     ( \ x => (const zero) x + f x )
>                   ={ Refl }=
>                     ( \ x => zero + f x )
>                   ={ extEqF (\ x => zero + f x) (\ x => f x) (lemma f) }=
>                     ( \ x => f x )
>                   ={ Refl }=
>                     ( f )
>                   QED

We are left with the last property: |consF (headF f) (tailF f) = f|. To
prove this property, we need three more assumptions

> (-) : R -> R -> R

> plusAnyMinus : (x, y : R) -> x + (y - x) = y

> derAntiInt : (f : F) -> (a : R) -> (b : R) -> S a b (D f) = f b - f a

With these, one has

> lemma1 : (c : R) -> (f : F) -> (x : R) -> (c + (f x - c) = f x)
> lemma1 c f x = plusAnyMinus c (f x)

> lemma2 : (f : F) -> (c : R) -> (a : R) -> (b : R) -> c + S a b (D f) = c + (f b - f a)
> lemma2 f c a b = ( c + S a b (D f) )
>                ={ cong (derAntiInt f a b) }=
>                  ( c + (f b - f a) )
>                QED

> consHeadTailPropF : (f : F) -> consF (headF f) (tailF f) = f
> consHeadTailPropF f = ( consF (headF f) (tailF f) )
>                     ={ Refl }=
>                       ( consF (f zero) (D f) )
>                     ={ Refl }=
>                       ( \ x => f zero + S zero x (D f) )
>                     ={ extEqF (\ x => f zero + S zero x (D f))
>                               (\ x => f zero + (f x - f zero))
>                               (lemma2 f (f zero) zero) }=
>                       ( \ x => f zero + (f x - f zero) )
>                     ={ extEqF (\ x => f zero + (f x - f zero))
>                               (\ x => f x)
>                               (lemma1 (f zero) f) }=
>                       ( \ x => f x )
>                     ={ Refl }=
>                       ( f )
>                     QED

* Properties of |R|, |D| and |S| (wrap up)

  ( 1) R : Type
  ( 2) zero : R
  ( 3) (+)  :  R -> R -> R
  ( 4) (-)  :  R -> R -> R
  ( 5) plusAnyMinus : (x, y : R) -> x + (y - x) = y
  ( 6) plusZeroLeftNeutral   :  (right : R) -> zero + right = right
  ( 7) plusZeroRightNeutral  :  ( left : R) -> left +  zero =  left

  ( 8) derConstZero : (a : R) -> D (const a) = const zero
  ( 9) derLinear1 : (f, g : F) -> D (\ x => f x + g x) = \ x => (D f) x + (D g) x

  (10) intProp1 : (a : R) -> (f : F) -> S a a f = zero
  (11) intAntiDer : (f : F) -> D (\ x => S zero x f) = f
  (12) derAntiInt : (f : F) -> (a : R) -> (b : R) -> S a b (D f) = f b - f a

  (13) extEqF : (f, g : F) -> ((x : R) -> f x = g x) -> f = g

Properties (1-7) follow from standard axioms on real numbers. (8-9)
follow from the standard definition of derivative. (10-12) follows from ?

> {-

> ---}


module Addition.Lemmas.Carry

import Common.Util
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.GroupCancelMisc
import Proofs.GroupTheory
import Proofs.TranslationInvarianceTheory
import Proofs.Interval

%default total
%access export

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
shiftToLeft : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    Between leq (neg (u + u), neg u) x ->
    Between leq (a + neg u, a) (a + u + x)
shiftToLeft spec u a x given = rewriteBetween o2 o3 o1 where
  o1 : Between leq (a + u + neg (u + u), a + u + neg u) (a + u + x)
  o1 = translateIntervalL (invariantOrder spec) (a + u) given
  o2 : a + u + neg (u + u) = a + neg u
  o2 = groupCancelMisc2 (group spec) a u _
  o3 : a + u + neg u = a
  o3 = groupCancel3bis (group spec) a u

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
shiftLeftToSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    leq a (u + neg a) ->
    Between leq (neg (u + u), neg u) x ->
    InSymRange leq neg (u + neg a) (a + u + x)
shiftLeftToSymRange {s} spec u a x bound given = o4 where
  sx : s
  sx = a + u + x
  o1 : Between leq (a + neg u, a) sx
  o1 = shiftToLeft spec u a x given
  o2 : Between leq (a + neg u, u + neg a) sx
  o2 = weakenR (order spec) bound o1
  o3 : neg (u + neg a) = a + neg u
  o3 = groupInverseAntiInverse (group spec) u a
  o4 : Between leq (neg (u + neg a), u + neg a) sx
  o4 = rewriteBetween (sym o3) Refl o2

||| Adhoc lemma.
||| Start with `computeCarry` to understand where it fits.
||| Derived from `shiftLeftToSymRange` using symmetry.
shiftRightToSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
    (u,a,x : s) ->
    leq a (u + neg a) ->
    Between leq (u, u + u) x ->
    InSymRange leq neg (u + neg a) (x + neg (a + u))
shiftRightToSymRange spec u a x bound given = rewrite sym o2 in o1 where
  o1 : InSymRange leq neg (u + neg a) (neg (a + u + neg x))
  o1 = invertSymRange spec $
       shiftLeftToSymRange spec u a (neg x) bound $
       invertBetween spec given
  o2 : neg (a + u + neg x) = x + neg (a + u)
  o2 = groupInverseAntiInverse (group spec) (a + u) x

||| Lemma: turn an interval into a proper SymRange.
toSymRange : {(+) : Binop s} ->
  PartiallyOrderedGroupSpec (+) _ neg leq ->
  isAbelian (+) ->
    Between leq (a + neg b, neg a + b) x ->
    InSymRange leq neg (b + neg a) x
toSymRange spec abel =
  rewriteBetween (sym $ groupInverseAntiInverse (group spec) _ _) (abel _ _)


module Elem

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

elem_test : Elem 2 [1..4]
elem_test = There Here

isElem : DecEq a => (x : a) -> (xs : List a) -> Maybe (Elem x xs)
isElem x [] = Nothing
isElem x (y :: xs) = case decEq x y of
                          Yes Refl => Just Here
                          No contra => do p <- isElem x xs
                                          Just (There p)


{- Example (modified) by Chris Done,
 - from: https://gist.github.com/chrisdone/672efcd784528b7d0b7e17ad9c115292

 - This files gives an example of a dependently typed printf function. printf
 - takes a format string as its first argument, for example:
      "This is a format string with an int %d and a string %s."
 - Our printf has the following type:
      printf : (s : String) -> interpFormat ( formatString s )
 - Here, the type of the expression `printf s` for a format string `s` is calculated
 - from the value of the format string. `interpFormat ( formatString s)` is a function
 - whose number of arguments and their types are determined by the format string's
 - value. Thus, a compiler error is thrown if the wrong arguments are passed
 - for a given format string. -}

%default total -- turns on totality checking for all functions

{- Idris can try and check that functions are total, i.e. that they terminate.
 - This is too hard a problem in general, but Idris can check totality for the
 - specific class of recursive functions which shrink toward a base case on
 - every call. -}

-- Formatting AST.
data Format
  = FInt Format
  | FString Format
  | FOther Char Format
  | FEnd

-- Parse the format string (list of characters) into an AST.
-- Example: "%d,%s"  →   (FInt (FOther ',' (FString FEnd)))
format : List Char -> Format
format ('%' :: 'd' :: cs ) = FInt ( format cs )
format ('%' :: 's' :: cs ) = FString ( format cs )
format ( c :: cs )         = FOther c ( format cs )
format []                  = FEnd

-- Convenience function to unpack a string into a list of chars, then
-- run format on it. Note that in Idris strings are not lists of characters.
formatString : String -> Format
formatString s = format ( unpack s )

-- Convert a format AST into a type.
-- Example: FInt (FOther ',' (FString FEnd))   →   Int -> String -> String
interpFormat : Format -> Type
interpFormat (FInt f)     = Int -> interpFormat f
interpFormat (FString f)  = String -> interpFormat f
interpFormat (FOther _ f) = interpFormat f
interpFormat FEnd         = String

-- Dependently-typed part: turn a formatting AST into a well-typed
-- function accepting n arguments.
-- Example:
--      toFunction (FInt (FString FEnd))
--    →
--      \a i s => a ++ (show i) ++ s
{-
-}
toFunction : (fmt : Format) -> String -> interpFormat fmt
toFunction ( FInt f ) a     = \i => toFunction f ( a ++ show i )
toFunction ( FString f ) a  = \s => toFunction f ( a ++ s )
toFunction ( FOther c f ) a = toFunction f ( a ++ pack [c])
toFunction FEnd a           = a

-- Dependently-typed part: turn a formatting string into a well-typed
-- function accepting n arguments.
-- Example: printf "%d%s" → \i s => (show i) ++ s
printf : (s : String) -> interpFormat ( formatString s )
printf s = toFunction ( formatString s ) ""

{- Now we can see printf in action. The following typechecks: -}

output : String
output = printf "My name is %s, and I am %d years old" "Isaac" 22

{- The following does not: -}

outputBad : String
outputBad = printf "My name is %s, and I am %d years old" 22 "Isaac"

{- Indeed, the compiler error is:

 Mismatch between: String and Int

 -}


> module Rel.TotalPreorder

> -- import Rel.Preorder

> %default total

> %access public export

> ||| TotalPreorder
> data TotalPreorder : {A : Type} -> (A -> A -> Type) -> Type where
>   MkTotalPreorder : {A : Type} ->
>                     (R : A -> A -> Type) ->
>                     (reflexive : (x : A) -> R x x) ->
>                     (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) ->
>                     (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) ->
>                     TotalPreorder R

> {-

> ||| TotalPreorder
> data TotalPreorder : Type -> Type where
>   MkTotalPreorder : {A : Type} ->
>                     (R : A -> A -> Type) ->
>                     (reflexive : (x : A) -> R x x) ->
>                     (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) ->
>                     (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) ->
>                     TotalPreorder A

> ---}


> module SequentialDecisionProblems.applications.FreezeOrIncrease

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Sigma.Sigma

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

* Freeze / Increase options:

> data FreezeOrIncrease = Freeze | Increase

* |FreezeOrIncrease| is finite and non-empty:

> to : FreezeOrIncrease -> Fin 2
> to Freeze   =    FZ
> to Increase = FS FZ

> from : Fin 2 -> FreezeOrIncrease
> from             FZ   = Freeze
> from         (FS FZ)  = Increase
> from     (FS (FS  k)) = absurd k

> toFrom : (k : Fin 2) -> to (from k) = k
> toFrom             FZ   = Refl
> toFrom         (FS FZ)  = Refl
> toFrom     (FS (FS  k)) = absurd k

> fromTo : (a : FreezeOrIncrease) -> from (to a) = a
> fromTo Freeze   = Refl
> fromTo Increase = Refl

> |||
> finiteFreezeOrIncrease : Finite FreezeOrIncrease
> finiteFreezeOrIncrease = MkSigma 2 (MkIso to from toFrom fromTo)

> |||
> cardNotZFreezeOrIncrease : CardNotZ finiteFreezeOrIncrease
> cardNotZFreezeOrIncrease = cardNotZLemma finiteFreezeOrIncrease Freeze

> {-

> ---}


CBool : Type
CBool = (B : Type) -> B -> B -> B

toBool : CBool -> Bool
toBool = \b => b Bool True False

ctrue : CBool
ctrue = \b, t, f => t

and : CBool -> CBool -> CBool
and = \a, b, bb, t, f => a bb (b bb t f) f

CNat : Type
CNat = (n : Type) -> (n -> n) -> n -> n

add : CNat -> CNat -> CNat
add = \a, b, n, s, z => a n s (b n s z)

cmul : CNat -> CNat -> CNat
cmul = \a, b, n, s => a n (b n s)

suc : CNat -> CNat
suc = \a, n, s, z => s (a n s z)

CEq : {A : Type} -> A -> A -> Type
CEq = \x, y => (P : A -> Type) -> P x -> P y

crefl : {A : Type} -> {x : A} -> CEq {A} x x
crefl = \p, px => px

n2 : CNat
n2 = \n, s, z => s (s z)

n3 : CNat
n3 = \n, s, z => s (s (s z))

n4 : CNat
n4 = \n, s, z => s (s (s (s z)))

n5 : CNat
n5 = \n, s, z => s (s (s (s (s z))))

n10 : CNat
n10  = cmul n2 n5

n10b : CNat
n10b = cmul n5 n2

n15 : CNat
n15 = add n10  n5

n15b : CNat
n15b   = add n10b n5

n18 : CNat
n18    = add n15  n3

n18b : CNat
n18b   = add n15b n3

n19 : CNat
n19    = add n15  n4

n19b : CNat
n19b   = add n15b n4

n20 : CNat
n20    = cmul n2 n10

n20b : CNat
n20b   = cmul n2 n10b

n21 : CNat
n21    = suc n20

n21b : CNat
n21b   = suc n20b

n22 : CNat
n22    = suc n21

n22b : CNat
n22b   = suc n21b

n23 : CNat
n23    = suc n22

n23b : CNat
n23b   = suc n22b

n100 : CNat
n100   = cmul n10   n10

n100b : CNat
n100b  = cmul n10b  n10b

n10k : CNat
n10k   = cmul n100  n100

n10kb : CNat
n10kb  = cmul n100b n100b

n100k : CNat
n100k  = cmul n10k  n10

n100kb : CNat
n100kb = cmul n10kb n10b

n1M : CNat
n1M    = cmul n10k  n100

n1Mb : CNat
n1Mb   = cmul n10kb n100b

n5M : CNat
n5M    = cmul n1M   n5

n5Mb : CNat
n5Mb   = cmul n1Mb  n5

n10M : CNat
n10M   = cmul n5M   n2

n10Mb : CNat
n10Mb  = cmul n5Mb  n2

Tree : Type
Tree = (T : Type) -> (T -> T -> T) -> T -> T

leaf : Tree
leaf = \t, n, l => l

node : Tree -> Tree -> Tree
node = \t1, t2, t, n, l => n (t1 t n l) (t2 t n l)

fullTree : CNat -> Tree
fullTree = \n => n Tree (\t => node t t) leaf

-- full tree with given trees at bottom level
fullTreeWithLeaf : Tree -> CNat -> Tree
fullTreeWithLeaf = \bottom, n => n Tree (\t => node t t) bottom

forceTree : Tree -> CBool
forceTree = \t => t CBool and ctrue

t15 : Tree
t15  = fullTree n15
t15b : Tree
t15b = fullTree n15b
t18 : Tree
t18  = fullTree n18
t18b : Tree
t18b = fullTree n18b
t19 : Tree
t19  = fullTree n19
t19b : Tree
t19b = fullTree n19b
t20 : Tree
t20  = fullTree n20
t20b : Tree
t20b = fullTree n20b
t21 : Tree
t21  = fullTree n21
t21b : Tree
t21b = fullTree n21b
t22 : Tree
t22  = fullTree n22
t22b : Tree
t22b = fullTree n22b
t23 : Tree
t23  = fullTree n23
t23b : Tree
t23b = fullTree n23b

-- CNat conversion
--------------------------------------------------------------------------------

-- convn1M : CEq Main.n1M Main.n1Mb
-- convn1M = crefl

-- convn5M : CEq Main.n5M Main.n5Mb
-- convn5M = crefl

-- convn10M : CEq Main.n10M Main.n10Mb
-- convn10M = crefl

-- Full tree conversion
--------------------------------------------------------------------------------

-- convt15  : CEq Main.t15  Main.t15b
-- convt15  = crefl
-- convt18  : CEq Main.t18  Main.t18b
-- convt18  = crefl
-- convt19  : CEq Main.t19  Main.t19b
-- convt19  = crefl
-- convt20  : CEq Main.t20  Main.t20b
-- convt20  = crefl
-- convt21  : CEq Main.t21  Main.t21b
-- convt21  = crefl
-- convt22  : CEq Main.t22  Main.t22b
-- convt22  = crefl
-- convt23  : CEq Main.t23  Main.t23b
-- convt23  = crefl

-- Full meta-containing tree conversion
--------------------------------------------------------------------------------

-- convmt15 : CEq Main.t15b  (fullTreeWithLeaf ? Main.n15 )
-- convmt15 = crefl
-- convmt18 : CEq Main.t18b  (fullTreeWithLeaf ? Main.n18 )
-- convmt18 = crefl
-- convmt19 : CEq Main.t19b  (fullTreeWithLeaf ? Main.n19 )
-- convmt19 = crefl
-- convmt20 : CEq Main.t20b  (fullTreeWithLeaf ? Main.n20 )
-- convmt20 = crefl
-- convmt21 : CEq Main.t21b  (fullTreeWithLeaf ? Main.n21 )
-- convmt21 = crefl
-- convmt22 : CEq Main.t22b  (fullTreeWithLeaf ? Main.n22 )
-- convmt22 = crefl
-- convmt23 : CEq Main.t23b  (fullTreeWithLeaf ? Main.n23 )
-- convmt23 = crefl

-- Full tree forcing
--------------------------------------------------------------------------------

-- forcet15 : CEq (toBool (forceTree Main.t15)) True
-- forcet15 = crefl
-- forcet18 : CEq (toBool (forceTree Main.t18)) True
-- forcet18 = crefl
-- forcet19 : CEq (toBool (forceTree Main.t19)) True
-- forcet19 = crefl
-- forcet20 : CEq (toBool (forceTree Main.t20)) True
-- forcet20 = crefl
-- forcet21 : CEq (toBool (forceTree Main.t21)) True
-- forcet21 = crefl
forcet22 : CEq (toBool (forceTree Main.t22)) True
forcet22 = crefl
-- forcet23 : CEq (toBool (forceTree Main.t23)) True
-- forcet23 = crefl


{- Another feature of the Idris2 type system, which comes from the underlying
 - Quantitative Type Theory, are quantities. Each value in a type can be annotated
 - as follows:
 -   0 - Argument erased at runtime, i.e. is only available at type-checking
 -   1 - Argument must be used exactly once each time the function is called.
       - No annotation means the argument can be used any number of times
 - The full inferred type of `id` below is shown in `id2`. -}

id : a -> a
id x = x

id2 : {0 a : Type} -> (1 x : a) -> a -- implicit eraced argument,
id2 x = x

{- We can see the effect of quantities (although not yet why they are useful)
 - through the following example. Consider the following definition. -}

duplicate : (1 x : a) -> (a, a)
duplicate x = ?hole

{- Inspecting ?hole above yields

 0 a : Type
 1 x : a
 -------------------------------------
 hole : (a, a)

 - Thus, idris is telling us we cannot use `a` in a term (only a type) and
 - we can use `x` exactly once. Say we do use it once:

-}

duplicate2 : (1 x : a) -> (a, a)
duplicate2 x = (?hole2, x)

{- On the hole `?hole2` above, we get the following. Note how the quantity of `x`
 - has changed from 1 to 0, since it has been used once.

 0 a : Type
 0 x : a
 -------------------------------------
 hole2 : a

 - Thus, this function is impossible to write without removing the quanity
 - constraint. We cannot use `x` twice.
 -}

duplicate3 : (x : a) -> (a, a)
duplicate3 x = (x, x)

{- Watch the following talk by the creator of Idris, starting at 26:15 for an
 - example of how quantities could be useful in practice. Or watch the whole
 - video, it gives a bunch of cool examples and should be accessible after
 - reading these notes.

 - https://www.youtube.com/watch?v=DRq2NgeFcO0}


module AssRecRule

import Data.Fin
import Data.Vect

% access public export

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

mapList : (a: Type) -> (b: Type) -> (f: a -> b) -> List a -> List b
mapList a b f = recList a (List b) base step where
  base = []
  step head tail prev = (f head) :: prev

foldList : (a: Type) ->  (init: a) -> (op : a -> a -> a) -> List a -> a
foldList a init op = recList a a base step where
  base = init
  step head tail prev = op head prev

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

inducFin : (xs : (n: Nat) -> Fin n -> Type) ->
  (base : (m: Nat) -> xs (S m) FZ) ->
  (step : (p: Nat) -> (k: Fin p) ->  (prev: xs p k) -> (xs (S p) (FS k))) ->
  (q: Nat) -> (j: Fin q) -> xs q j
inducFin xs base step (S l) FZ = base l
inducFin xs base step (S l) (FS x) =
  step l x prev where
    prev = inducFin xs base step l x

fetchFamily: (a: Type) -> (n: Nat) -> Fin n -> Type
fetchFamily a n x = ((Vect n a) -> a)

fetchElem : (a: Type) -> (q: Nat) -> (j: Fin q) -> (Vect q a -> a)
fetchElem a  = inducFin (fetchFamily a) base step where
  base m (x :: xs) =  x
  step p k prev (x :: xs) =
    fetchElem a p k xs


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

%name Vect xs, ys, zs

replicate : {m : Nat} -> a -> Vect m a

transpose : {m : Nat} -> Vect n (Vect m a) -> Vect m (Vect n a)
transpose [] = ?transpose_rhs_1
transpose (x :: xs) = ?transpose_rhs_2


> module SequentialDecisionProblems.ViabilityDefaults

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

> import Unit.Properties

> %default total
> %auto_implicits off

This is the default implementation of |Viable|: all states are viable
for 0 steps; a state is viable for |n + 1| steps iff it has a control
such that 1) the set of next possible states is not empty and 2) all
next possible states are viable for |n| steps. These two conditions are
encoded in the notion of "good" control, see |Utils|:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable {t}  Z    _ = Unit
> SequentialDecisionProblems.CoreTheory.Viable {t} (S n) x = GoodCtrl t x n

Trivially, for every state that is viable for |n + 1| steps we can
compute a good control

> -- viableSpec0 : (x : State t) -> Viable Z x
> SequentialDecisionProblems.CoreTheory.viableSpec0 x = ()

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x n
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} x v = v

> -- viableSpec2 : (x : State t) -> GoodCtrl t x n -> Viable (S n) x
> SequentialDecisionProblems.CoreTheory.viableSpec2 {t} {n} x gy = gy

If users can show that ..., see |Utils|. For |M = List|, for instance,
... are implemented in |NonDeterministic Defaults|:

> -- finiteViable : {t : Nat} ->
> --                (n : Nat) -> (x : State t) -> Finite (Viable n x)
> SequentialDecisionProblems.Utils.finiteViable Z     _ = finiteUnit
> SequentialDecisionProblems.Utils.finiteViable (S m) x = finiteGoodCtrl m x

> -- decidableViable : {t : Nat} ->
> --                   (n : Nat) -> (x : State t) -> Dec (Viable n x)
> SequentialDecisionProblems.Utils.decidableViable  Z    _ = Yes MkUnit
> SequentialDecisionProblems.Utils.decidableViable (S m) x = decidableGoodCtrl m x

> {-

> ---}


module Shape

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

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle

data ShapeView : Shape -> Type where
  STriangle  : ShapeView (triangle  base   height)
  SRectangle : ShapeView (rectangle width  height)
  SCircle    : ShapeView (circle    radius)

shapeView : (s: Shape) -> ShapeView s
shapeView (Triangle   x y) = STriangle
shapeView (Rectangle  x y) = SRectangle
shapeView (Circle     x)   = SCircle

area : Shape -> Double
area x with (shapeView x)
  area (triangle  base    height) | STriangle   = 0.5 * base * height
  area (rectangle width   height) | SRectangle  = width * height
  area (circle    radius)         | SCircle     = pi * radius * radius


module Ord

record Album where
    constructor MkAlbum
    artist : String
    title : String
    year : Integer

Eq Album where
  (==) (MkAlbum a t y) (MkAlbum a' t' y') = a == a' && t == t' && y == y'

Ord Album where
  compare (MkAlbum a t y) (MkAlbum a' t' y') = case compare a a' of
                                                    EQ => case compare y y' of
                                                               EQ => compare t t'
                                                               d_y => d_y
                                                    d_a => d_a

Show Album where
  show (MkAlbum artist title year) = title ++ " by " ++ artist ++ " (Released on: " ++ show year ++ ")"

help : Album
help = MkAlbum "The Beatles" "Help" 1965

rubbersoul : Album
rubbersoul = MkAlbum "The Beatles" "Rubber Soul" 1965

clouds : Album
clouds = MkAlbum "Joni Mitchell" "Clouds" 1969

hunkydory : Album
hunkydory = MkAlbum "David Bowie" "Hunky Dory" 1971

heroes : Album
heroes = MkAlbum "David Bowie" "Heroes" 1977

collection : List Album
collection = [help, rubbersoul, clouds, hunkydory, heroes]

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

-- Ex. 7_1
Eq Shape where
  (==) (Triangle x z) (Triangle y w) = x == y && z == w
  (==) (Rectangle x z) (Rectangle y w) = x == y && z == w
  (==) (Circle x) (Circle y) = x == y
  (==) _ _ = False

-- Ex. 7_2

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

Ord Shape where
  compare x y = let sa1 = getArea x
                    sa2 = getArea y
                    in compare sa1 sa2

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


-- ------------------------------------------------------------ [ Literals.idr ]
||| Module    : Literals.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
||| Deal with literal values at the type-level.
module Commons.Data.Literals

%default total
%access public export

||| Proof that the given value level `b` of type `ty` has value `a`.
data Literal : (ty : Type)
            -> (a : ty)
            -> Type
  where
    MkLiteral : (b : ty)
             -> (prf : b = a)
             -> Literal ty a

newLiteral : (b : ty) -> Literal ty b
newLiteral b = MkLiteral b Refl

||| Representation of String literals.
LitString : String -> Type
LitString str = Literal String str

||| Proof that the given natural `o` is the successor of `n`.
data Next : (n : Nat) -> Type where
  MkNext : (o : Nat) -> (prf : o = S n) -> Next n

newNext : (o,n : Nat) -> (prf : o = S n) -> Next n
newNext o _ prf = MkNext o prf

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


||| Mathematicians often make an appeal to 'symmetry' to derive
||| variations on a lemma or theorem.
module Symmetry.Opposite

import Specifications.TranslationInvariance
import Specifications.Ring

%default total
%access export

private
oppAssoc : isAssociative op -> isAssociative (flip op)
oppAssoc spec x y z = sym (spec z y x)

namespace Monoid
  opposite : MonoidSpec op e -> MonoidSpec (flip op) e
  opposite (MkMonoid a l r) = MkMonoid (oppAssoc a) r l

namespace Group
  opposite : GroupSpec op e inv -> GroupSpec (flip op) e inv
  opposite (MkGroup m l r) = MkGroup (opposite m) r l

namespace PreRing
  multiplicativeOpposite : PreRingSpec add mul -> PreRingSpec add (flip mul)
  multiplicativeOpposite {add} {mul} (MkPreRing l r abel) =
    MkPreRing rop lop abel where
      rop : isDistributativeL add (flip mul)
      rop a x y = r x y a
      lop : isDistributativeR add (flip mul)
      lop x y a = l a x y

namespace Ring
  multiplicativeOpposite : RingSpec add zero neg mul ->
    RingSpec add zero neg (flip mul)
  multiplicativeOpposite (MkRing pre grp multassoc) =
    MkRing (multiplicativeOpposite pre) grp (oppAssoc multassoc)

namespace PartiallyOrderedMagma
  opposite : PartiallyOrderedMagmaSpec op leq ->
    PartiallyOrderedMagmaSpec (flip op) leq
  opposite (MkPartiallyOrderedMagma o l r) = MkPartiallyOrderedMagma o r l

namespace PartiallyOrderedGroup
  opposite : PartiallyOrderedGroupSpec op inv e leq ->
    PartiallyOrderedGroupSpec (flip op) inv e leq
  opposite (MkPartiallyOrderedGroup g m) =
    MkPartiallyOrderedGroup (opposite g) (opposite m)


%default total

%hide Prelude.Nat.LT
%hide Prelude.Interfaces.LT
%hide Prelude.Interfaces.(<=)
%hide Prelude.Interfaces.(>)
%hide Prelude.List.filter
%hide Prelude.List.merge
%hide Prelude.List.splitAt
%hide Prelude.WellFounded.Smaller

someList : List Nat
someList = [9,1,5,5,0,2,3,7,6,11,1]

data Acc : (lessThan : a -> a -> Type) -> (x : a) -> Type where
  MkAcc :
    -- potentially infinite tuple
    -- potentially infinite number of children in the tree
    -- but each subtree has a finite depth
    (acc : (y : a) -> (y `lessThan` x) -> Acc lessThan y)
      -> Acc lessThan x

interface WF (lt : a -> a -> Type) where
  wf : (x : _) -> Acc lt x

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

data LE : Nat -> Nat -> Type where
  LEZ : Z `LE` n
  LES : m `LE` n -> S m `LE` S n

LT : Nat -> Nat -> Type
LT m n = LE (S m) n

leRefl : x `LE` x
leRefl {x = Z} = LEZ
leRefl {x = (S x)} = LES leRefl

leTrans : (x `LE` y) -> (y `LE` z) -> (x `LE` z)
leTrans  LEZ _ = LEZ
leTrans (LES xLEy) (LES yLEz) = LES $ leTrans xLEy yLEz

wfLT : (x : Nat) -> Acc LT x
wfLT x = MkAcc (f x)
  where
    f : (x : Nat) -> (y : Nat) -> (y `LT` x) -> Acc LT y
    f (S x) y (LES yLEx) = MkAcc (\z, zLTy => f x z $ leTrans zLTy yLEx)
    -- LEZ cannot prove "strictly smaller than" because LT has (S _) on the LHS
    -- and LEZ has Z on the LHS

{-
decLE : (m, n : Nat) -> Dec (m `LE` n)
decLE Z n = Yes LEZ
decLE (S k) Z = No lemmaLTZ
decLE (S k) (S j) with (decLE k j)
  | Yes yep = Yes $ LES yep
  | No nope = No $ f nope
    where
      f : (LE k j -> Void) -> LE (S k) (S j) -> Void
      f nope (LES pf) = nope pf
-}

(<=) : Nat -> Nat -> Bool
(<=) Z n = True
(<=) (S m) Z = False
(<=) (S m) (S n) = m <= n

(>) : Nat -> Nat -> Bool
(>) m n = not (m <= n)

filter : (a -> Bool) -> List a -> List a
filter p [] = []
filter p (x :: xs) with (p x)
  | True = x :: filter p xs
  | False = filter p xs

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

shorter : List a -> List a -> Type
shorter xs ys = length xs `LT` length ys

wfShorter : (xs : List a) -> Acc Main.shorter xs
wfShorter xs = MkAcc (f xs)
  where
    f : (xs : List a) -> (ys : List a) -> (ys `Main.shorter` xs) -> Acc Main.shorter ys
    f (x :: xs) ys (LES ysLExs) = MkAcc (\zs, zsLTys => f xs zs $ leTrans zsLTys ysLExs)

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

{- Comes from Prelude now
interface Sized a where
  size : a -> Nat
-}

Smaller : Sized a => a -> a -> Type
Smaller x y = size x `LT` size y

SizeAcc : Sized a => a -> Type
SizeAcc x = Acc Smaller x

wfSmaller : Sized a => (x : a) -> SizeAcc x
wfSmaller x = MkAcc $ f (size x)
  where
    f : (sizeX : Nat) -> (y : a) -> (size y `LT` sizeX) -> SizeAcc y
    f (S n) y (LES yLEx)
      = MkAcc (\z, zLTy =>
          f n z (leTrans zLTy yLEx)
        )

{- comes from Prelude now
implementation Sized (List a) where
  size = length
-}

{-
wfSmaller : Sized a => (x : a) -> Acc Smaller x
wfSmaller x = MkAcc (f x)
  where
    f : (x, y : a) -> (y `Smaller` x) -> Acc Smaller y
    f x y pf with (size x) proof xSize
      f x y pf | Z = lemmaLTZ pf
      f x y (LES yLEx) | S n = MkAcc (\z, zLTy => f x z $ leTrans zLTy ?rhs)
      -- we cannot do this because for the inductive step, we need a subterm of x
      -- but we have no way to obtain it
-}

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

-- qSort with Acc

leS : (m `LE` n) -> (m `LE` S n)
leS  LEZ    = LEZ
leS (LES x) = LES (leS x)

filterLen : {p : a -> Bool} -> {xs : List a} -> length (filter p xs) `LE` length xs
filterLen {xs = []} = LEZ
filterLen {p} {xs = x :: xs} with (p x)
  | True = LES $ filterLen
  | False = leS $ filterLen

qsort' : (xs : List Nat) -> (Acc Main.shorter xs) -> List Nat
qsort' [] acc = []
qsort' (x :: xs) (MkAcc acc) =
  qsort' (filter (<= x) xs) (acc _ $ LES filterLen)
  ++ [x]
  ++ qsort' (filter (> x) xs) (acc _ $ LES filterLen)

qsort : List Nat -> List Nat
qsort xs = qsort' xs (wfShorter xs)

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

-- QSortAcc directly

data QSortAcc : List Nat -> Type where
  QNil : QSortAcc []
  QCons : QSortAcc (filter (<= x) xs) -> QSortAcc (filter (> x) xs) -> QSortAcc (x :: xs)

qsortAccLo : (x : _) -> QSortAcc xs -> QSortAcc (filter (<= x) xs)
qsortAccLo x pf = ?rhsX1

qsortAccHi : (x : _) -> QSortAcc xs -> QSortAcc (filter (> x) xs)
qsortAccHi x pf = ?rhsX2

qsortA' : (xs : List Nat) -> QSortAcc xs -> List Nat
qsortA' [] QNil = []
qsortA' (x :: xs) (QCons lo hi)
    = qsortA' (filter (<= x) xs) lo
    ++ [x]
    ++ qsortA' (filter (> x) xs) hi

obsBool : (x : Bool) -> Either (x = True) (x = False)
obsBool True = Left Refl
obsBool False = Right Refl

filterDbl : (p : a -> Bool) -> (xs : List a) -> filter p (filter p xs) = filter p xs
filterDbl p xs = ?filterDblHole

qsortAcc : (xs : List Nat) -> QSortAcc xs
qsortAcc [] = QNil
qsortAcc (x :: xs) = QCons (f x xs) ?rhsX3
  where
    f : (x : Nat) -> (xs : List Nat) -> QSortAcc (filter (<= x) xs)
    f x [] = QNil
    f x (y :: xs) with (y <= x)
      | True = ?qSortAccA
      | False = ?qSortAccB

{-
    f x [y] with (y <= x)
      | True = QCons QNil QNil
      | False = QNil
    f x (y :: z :: xs) with (y <= x)
      | True = ?rhs
      | False = ?rhs2
-}

qsortA : List Nat -> List Nat
qsortA xs = qsortA' xs (qsortAcc xs)

---

-- via Acc

qsortAcc' : (xs : List Nat) -> Acc Main.shorter xs -> QSortAcc xs
qsortAcc' [] acc = QNil
qsortAcc' (x :: xs) (MkAcc acc)
    = QCons
        (qsortAcc' _ (acc _ $ LES filterLen))
        (qsortAcc' _ (acc _ $ LES filterLen))

qsort2 : List Nat -> List Nat
qsort2 xs = qsortA' xs $ qsortAcc' xs (wfShorter xs)

---

data Split : List a -> Type where
  SNil : Split []
  SOne : (x : a) -> Split [x]
  SMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> Split (x :: xs ++ y :: ys)

pushL : (x : a) -> Split xs -> Split (x :: xs)
pushL x  SNil = SOne x
pushL x (SOne y) = SMore x [] y []
pushL x (SMore y ys z zs) = SMore x (y :: ys) z zs

{-
split : (xs : List a) -> Split xs
split [] = SNil
split [x] = SOne x
split (x :: y :: xs) = step (1 + length xs) x y xs
  where
    step : (counter : Nat) -> (x, y : a) -> (xs : List a) -> Split (x :: y :: xs)
    step  Z    x y xs = SMore x [] y xs
    step (S Z) x y xs = SMore x [] y xs
    step (S (S k)) x y [] = SMore x [] y []
    step (S (S k)) x y (z :: xs) = pushL x $ step k y z xs
-}

halve : (xs : List a) -> Split xs
halve []  = SNil
halve [x] = SOne x
halve (x :: y :: xs) with (1 + length xs)
  halve (x :: y :: xs) |      Z  = SMore x [] y xs
  halve (x :: y :: xs) |    S Z  = SMore x [] y xs
  halve (x :: y :: []) | S (S k) = SMore x [] y []
  halve (x :: y :: z :: zs) | S (S k) = pushL x (halve (y :: z :: zs) | k)

shorterL : xs `shorter` (xs ++ y :: ys)
shorterL {xs = []} = LES LEZ
shorterL {xs = (x :: xs)} = LES shorterL

shorterR : ys `shorter` (x :: xs ++ ys)
shorterR {xs = []} = LES leRefl
shorterR {xs = x :: xs} = leS $ shorterR {x=x}

merge : List Nat -> List Nat -> List Nat
merge (x :: xs) (y :: ys) with (x <= y)
  | True  = x :: merge xs (y :: ys)
  | False = y :: merge (x :: xs) ys
merge [] ys = ys
merge xs [] = xs

msort1' : (xs : List Nat) -> (Acc Main.shorter xs) -> List Nat
msort1' xs acc with (halve xs)
  msort1' []  acc | SNil = []
  msort1' [x] acc | SOne x = [x]
  msort1' (y :: ys ++ z :: zs) (MkAcc acc) | SMore y ys z zs
    = merge
        (msort1' (y :: ys) (acc _ $ shorterL {xs = y::ys}))
        (msort1' (z :: zs) (acc _ $ shorterR {ys = z::zs}))

msort1 : List Nat -> List Nat
msort1 xs = msort1' xs (wfShorter xs)

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

mutual
  data MSAcc' : Split xs -> Type where
    MSNil : MSAcc' SNil
    MSOne : MSAcc' (SOne x)
    MSMore :
      MSAcc (x :: xs)
      -> MSAcc (y :: ys)
      -> MSAcc' (SMore x xs y ys)

  MSAcc : List a -> Type
  MSAcc xs = MSAcc' (halve xs)

msAcc : (xs : List Nat) -> MSAcc xs
msAcc xs with (wfShorter xs)
  msAcc xs | acc with (halve xs)
    msAcc []  | acc | SNil   = MSNil
    msAcc [x] | acc | SOne x = MSOne
    msAcc (y :: ys ++ z :: zs) | MkAcc acc | SMore y ys z zs
      = MSMore
        (msAcc _ | acc _ (shorterL {xs = y :: ys}))
        (msAcc _ | acc _ (shorterR {ys = z :: zs}))

msort2' : (xs : List Nat) -> MSAcc xs -> List Nat
msort2' xs acc with (halve xs)
  msort2' []  MSNil | SNil   = []
  msort2' [x] MSOne | SOne x = [x]
  msort2' (y :: ys ++ z :: zs) (MSMore accL accR) | SMore y ys z zs
    = merge
        (msort2' (y :: ys) accL)
        (msort2' (z :: zs) accR)

msort2 : List Nat -> List Nat
msort2 xs = msort2' xs (msAcc xs)

-- views for convenience
-- views for termination

-- Acc is more general induction hypothesis than QSortAcc
-- more general => easier to work with (easier to prove from)
  -- probably a bit harder to prove BUT
  -- still obviously true
  -- and proving the inductive step may be easier (actually feasible at all)

-- end up with views

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

%default total

subst : (f : a -> Type) -> x = y -> f x -> f y
subst f Refl = \x => x

data SplitC : (List a -> Type) -> List a -> Type where
  SCNil : SplitC srg []
  SCOne : (x : a) -> SplitC srg [x]
  SCMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> (rxs : srg (x :: xs))
    -> (rys : srg (y :: ys))
    -> SplitC srg (x :: xs ++ y :: ys)

data SplitRecC : List a -> Type where
  SRC : ((n : Nat) -> SplitC SplitRecC xs) -> SplitRecC xs

pushSC : (x : a) -> SplitC (const ()) xs -> SplitC (const ()) (x :: xs)
pushSC x  SCNil = SCOne x
pushSC x (SCOne y) = SCMore x [] y [] () ()
pushSC x (SCMore y ys z zs () ()) = SCMore x (y::ys) z zs () ()

splitAt : (n : Nat) -> (xs : List a) -> SplitC (const ()) xs
splitAt n [] = SCNil
splitAt n [x] = SCOne x
splitAt Z (x :: y :: ys) = SCMore x [] y ys () ()
splitAt (S k) (x :: y :: ys) = pushSC x $ splitAt k (y :: ys)

lemmaApp : (xs : List a) -> (ys : List a) -> length ys `LE` length (xs ++ ys)
lemmaApp []      ys = leRefl
lemmaApp (x::xs) ys = leS $ lemmaApp xs ys

splitC : (xs : List a) -> (n : Nat) -> SplitC SplitRecC xs
splitC xs n with (wfSmaller xs)
  splitC xs n | acc with (splitAt n xs)
    splitC []  n | acc | SCNil = SCNil
    splitC [x] n | acc | SCOne x = SCOne x
    splitC (y :: ys ++ z :: zs) n | MkAcc acc | SCMore y ys z zs () ()
        = SCMore y ys z zs
            (SRC $ \n' => splitC (y :: ys) n' | acc _ (LES shorterL))
            (SRC $ \n' => splitC (z :: zs) n' | acc _ (LES $ lemmaApp ys (z::zs)))

splitRecC : (xs : List a) -> SplitRecC xs
splitRecC xs = SRC $ splitC xs

unpack' : Nat -> List Nat -> List (List Nat)
unpack' x xs with (splitRecC (x :: xs))
  unpack' x    xs   | SRC splitAt with (splitAt x)
    unpack' x  []   | SRC splitAt | SCOne x = []  -- dangling length tag
    unpack' x (ys ++ z :: zs) | SRC splitAt | SCMore x ys z zs rys rzs
        = ys :: unpack' z zs | rzs

unpackL : List Nat -> List (List Nat)
unpackL []        = []
unpackL (x :: xs) = unpack' x xs

packL : List (List Nat) -> List Nat
packL [] = [0]
packL (xs :: xss) = length xs :: xs ++ packL xss

{-
*views> unpackL [1,3,0,3,1,2,3,2,0,1,4,1,2,3,4,0]
[[3], [1, 2, 3], [0, 1], [1, 2, 3, 4]] : List (List Nat)
-}

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

{-
data ModView : Nat -> Nat -> Type where
  Base : ModView x y
  Step : ModView x y -> ModView x (x + y)

modView : (x', y : Nat) -> ModView (S x') y
modView  x'    Z = Base
modView  Z    (S y') = ?rhs_1  -- dividing by 1
modView (S k) (S y') = ?rhs_3
-}

{-
mod : (x : Nat) -> (y : Nat) -> Nat
mod x y acc with
-}

data SplitRec : List a -> Type where
  SRNil : SplitRec []
  SROne : (x : a) -> SplitRec [x]
  SRMore :
    (x : a) -> (xs : List a)
    -> (y : a) -> (ys : List a)
    -> (sxs : SplitRec (x :: xs))
    -> (sys : SplitRec (y :: ys))
    -> SplitRec (x :: xs ++ y :: ys)

splitRec : (xs : List a) -> SplitRec xs
splitRec xs with (wfSmaller xs)
  splitRec xs | acc with (halve xs)
    splitRec []  | acc | SNil   = SRNil
    splitRec [x] | acc | SOne x = SROne x
    splitRec (y :: ys ++ z :: zs) | MkAcc acc | SMore y ys z zs
      = SRMore y ys z zs
          (splitRec _ | acc _ (shorterL {xs = y::ys}))
          (splitRec _ | acc _ (shorterR {x=z} {ys = z::zs}))

msortR : List Nat -> List Nat
msortR xs with (splitRec xs)
  msortR []  | SRNil   = []
  msortR [x] | SROne x = [x]
  msortR (y :: ys ++ z :: zs) | SRMore y ys z zs sys szs
    = merge
        (msortR (y :: ys) | sys)
        (msortR (z :: zs) | szs)

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

data SnocViewRec : List a -> Type where
  SVRNil : SnocViewRec (Nil {elem=a})
  SVRSnoc : (sxs : SnocViewRec xs)
    -> (x : a)
    -> SnocViewRec (xs ++ [x])

%hide Prelude.Basics.cong

cong : {f : a -> b} -> x = y -> f x = f y
cong Refl = Refl

appNil : (xs : List a) -> xs ++ [] = xs
appNil [] = Refl
appNil (x :: xs) = cong $ appNil xs

appAssoc : (xs : List a) -> (ys : List a) -> (zs : List a) -> xs ++ (ys ++ zs) = (xs ++ ys) ++ zs
appAssoc [] ys zs = Refl
appAssoc (x :: xs) ys zs = cong $ appAssoc xs ys zs

sr : (sxs : SnocViewRec xs) -> (ys : List a) -> SnocViewRec (xs ++ ys)
sr {xs} sxs [] = rewrite appNil xs in sxs
sr {xs} sxs (y :: ys) = rewrite appAssoc xs [y] ys in sr (SVRSnoc sxs y) ys

snocViewRec : (xs : List a) -> SnocViewRec xs
snocViewRec = sr SVRNil

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

data VList : List a -> Type where
  VNil : VList []
  VOne : (x : a) -> VList [x]
  VMore : (x : a) -> VList xs -> (y : a) -> VList (x :: xs ++ [y])

pushV : (x : a) -> VList xs -> VList (x :: xs)
pushV x  VNil = VOne x
pushV x (VOne y) = VMore x VNil y
pushV x (VMore y ys z) = VMore x (pushV y ys) z

vList : (xs : List a) -> VList xs
vList [] = VNil
vList (x :: xs) = pushV x (vList xs)

{-
vStep : SnocViewRec (x :: xs ++ [y]) -> SnocViewRec (x :: xs)
vStep {x} {xs} {y} (SVRSnoc {xs = x :: xs} sxs y) = sxs
-}


module EqualityIn

interface Preorder t (po : t -> t -> Type) where
  transitive : (0 a, b, c : t) -> po a b -> po b c -> po a c
  reflexive : (0 a : t) -> po a a

interface Preorder t eq => Equivalence t (eq : t -> t -> Type) where
  symmetric : (0 a, b : t) -> eq a b -> eq b a

interface Equivalence t eq => Congruence t (f : t -> t) (eq : t -> t -> Type) where
  congruent : (0 a, b : t) -> eq a b -> eq (f a) (f b)

Preorder t Equal where
  transitive _ _ _ ab bc = trans ab bc
  reflexive _ = Refl

Equivalence t Equal where
  symmetric _ _ ab = sym ab

Congruence t f Equal where
  congruent _ _ ab = cong f ab

abba : a = b -> b = a
abba = symmetric a b


module Poly

%access public export

%default total

repeat : (x : x_ty) -> (count : Nat) -> List x_ty
repeat x Z = []
repeat x (S k) = x :: repeat x k

test_repeat1 : repeat 4 2 = [4, 4]
test_repeat1 = Refl

test_repeat2 : repeat False 1 = [False]
test_repeat2 = Refl

namespace MumbleGrumble
    data Mumble : Type where
        A : Mumble
        B : Mumble -> Nat -> Mumble
        C : Mumble

    data Grumble : (x : Type) -> Type where
        D : Mumble -> Grumble x
        E : x -> Grumble x

rev : (l : List a) -> List a
rev [] = []
rev (h :: t) = (rev t) ++ [h]

test_rev1 : rev [1, 2] = [2, 1]
test_rev1 = Refl

test_rev2 : rev [True] = [True]
test_rev2 = Refl

len : (l : List a) -> Nat
len [] = Z
len (h :: t) = S (len t)

test_length1 : length [1, 2, 3] = 3
test_length1 = Refl

app_nil_r : (l : List a) -> l ++ [] = l
app_nil_r [] = Refl
app_nil_r (x :: xs) = rewrite app_nil_r xs in Refl

app_nil : (l : List a) -> [] ++ l = l
app_nil l = Refl

app_assoc : (l, m, n : List a) -> l ++ m ++ n = (l ++ m) ++ n
app_assoc [] m n = Refl
app_assoc (x :: xs) m n = rewrite app_assoc xs m n in Refl

app_length : (l1, l2 : List a) -> length (l1 ++ l2) = length l1 + length l2
app_length [] l2 = Refl
app_length (x :: xs) l2 = rewrite app_length xs l2 in Refl

rev_app_distr : (l1, l2 : List a) -> rev (l1 ++ l2) = rev l2 ++ rev l1
rev_app_distr [] l2 = rewrite app_nil_r (rev l2) in Refl
rev_app_distr (x :: xs) l2 =
    rewrite rev_app_distr xs l2 in
        rewrite sym $ app_assoc (rev l2) (rev xs) [x] in
            Refl

rev_involutive : (l : List a) -> rev (rev l) = l
rev_involutive [] = Refl
rev_involutive (x :: xs) =
    rewrite rev_app_distr (rev xs) [x] in
        rewrite rev_involutive xs in
            Refl

split : (l : List (x, y)) -> (List x, List y)
split [] = ([], [])
split ((a, b) :: xs) =
    let
        (ys, zs) = split xs
    in
        (a :: ys, b :: zs)

test_split : split [(1, False), (2, False)] = ([1, 2], [False, False])
test_split = Refl

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

test_nth_error1 : nth_error [4, 5, 6, 7] 0 = Just 4
test_nth_error1 = Refl

test_nth_error2 : nth_error [[1], [2]] 1 = Just [2]
test_nth_error2 = Refl

test_nth_error3 : nth_error [True] 2 = Nothing
test_nth_error3 = Refl

hd_error : (l : List a) -> Maybe a
hd_error [] = Nothing
hd_error (x :: xs) = Just x

test_hd_error1 : hd_error [1, 2] = Just 1
test_hd_error1 = Refl

test_hd_error2 : hd_error [[1], [2]] = Just [1]
test_hd_error2 = Refl

map_rev : (f : x -> y) -> (l : List x) -> map f (rev l) = rev (map f l)
map_rev f [] = Refl
map_rev f (x :: xs) = ?map_rev_rhs_2