module Primes

import NatUtils
import gcd
import Data.Fin
import NatOrder
import SriramAssRecRule

%access public export
%default total

--isDivisible a b can be constucted if b divides a
isDivisible : Nat -> Nat -> Type
isDivisible a b = (n : Nat ** (GT n 0, a = b * n))

--1 divides everything
oneDiv : (a : Nat) -> {auto x : GT a 0} -> isDivisible a 1
oneDiv a {x=pf} = (a ** (pf , rewrite plusZeroRightNeutral a in Refl))

--If 1|a => 1*c | a*c
mulDiv : (a, c : Nat) -> {auto pf1 : GT a 0} -> {auto pf2 : GT c 0} ->
  isDivisible a 1 -> isDivisible (a * c) c
mulDiv a c {pf1=p} x = (a ** (p ,rewrite multCommutative a c in Refl))

--Either(a=b)(_) <=> Either (S a = S b)(_)
help1 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a))) ->
  Either (S a = S b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help1 {a} {b} (Left l) = Left (eqSucc a b l)
help1 (Right r) = Right r

--Either(_)(Either(Sa<Sb)(_)) <=> Either (_)(Either(a<b)(_))
help2 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a))) ->
  Either (a = b) (Either (LT (S a) (S b)) (LT (S b) (S a)))
help2 (Left l) = Left l
help2 {a} {b} (Right (Left l)) = Right(Left (LTESucc l))
help2 (Right (Right r)) = Right (Right r)

--Either(_)(Either(_)(Sb<Sa)) <=> Either (_)(Either(_)(b<a))
help3 : {a : Nat} -> {b : Nat} ->
  Either (a = b) (Either (LT a b) (LT b a)) ->
  Either (a = b) (Either (LT a b) (LT (S b) (S a)))
help3 (Left l) = Left l
help3 (Right (Left l)) = Right(Left l)
help3 {a} {b} (Right (Right r)) = Right (Right (LTESucc r))

|||Either a = b, a < b, or a > b
totOrdNat : (a : Nat) -> (b : Nat) ->
  Either (a = b) (Either (LT a b) (LT b a))
totOrdNat Z Z = Left Refl
totOrdNat Z (S k) = Right (Left (LTESucc LTEZero))
totOrdNat (S k) Z = Right (Right (LTESucc LTEZero))
totOrdNat (S k) (S j) = help1 (help2 (help3 (totOrdNat k j)))

--LTE a b => LTE a*n b*n
multRightLTE : (a,b : Nat) -> (n : Nat) -> GT n 0 ->
  LTE a b -> LTE (a*n) (b*n)
multRightLTE a b (S Z) (LTESucc LTEZero) lteab =
                            rewrite multOneRightNeutral a in
                            rewrite multOneRightNeutral b in
                            lteab
multRightLTE a b (S (S k)) (LTESucc LTEZero{right=(S k)}) lteab =
          rewrite multRightSuccPlus a (S k) in
          rewrite multRightSuccPlus b (S k) in
          ltePlusIsLTE lteab
          (multRightLTE a b (S k) (LTESucc LTEZero{right=k}) lteab)

--If a = b*n, b <= a
aEqProdImpAGtB : (a,b,n : Nat) -> GT n 0 -> (a = b*n) -> LTE b a
aEqProdImpAGtB _ _ Z LTEZero _ impossible
aEqProdImpAGtB _ _ Z (LTESucc _) _ impossible
aEqProdImpAGtB (b * (S k)) b (S k) x Refl = case b of
              Z => LTEZero
              (S m) =>
                rewrite sym (multOneLeftNeutral (S m)) in
                rewrite multCommutative (S m) (S k) in
                rewrite multDistributesOverPlusRight k (S Z) m in
                rewrite plusCommutative (k*1) (k*m) in
                rewrite plusAssociative m (k*m) (k*1) in
                rewrite plusCommutative (m + k*m) (k*1) in
                rewrite sym (multDistributesOverPlusRight (S k) 1 m) in
                multRightLTE 1 (S k) (S m) (LTESucc (LTEZero)) x

--If b | a => b <= a
bDivAImpAGtB : (a,b,n : Nat) -> isDivisible a b -> LTE b a
bDivAImpAGtB a b n (x ** pf) = case (fst pf) of
              (LTESucc LTEZero{right=k}) => aEqProdImpAGtB a b (S k) (fst pf) (snd pf)

--GT implies Not LTE
gtImpliesNotLTE : GT a b -> Not (LTE a b)
gtImpliesNotLTE {a=Z} {b=_} LTEZero impossible
gtImpliesNotLTE {a=Z} {b=_} (LTESucc _) impossible
gtImpliesNotLTE {a=(S k)} {b=Z} x = case isLTE (S k) Z of
                                 (Yes prf) => absurd
                                 (No contra) => contra
gtImpliesNotLTE {a=(S k)} {b=(S j)} x = case isLTE (S k) (S j) of
                                 (Yes prf) => void
                                      (gtImpliesNotLTE (fromLteSucc x) (fromLteSucc prf))
                                 (No contra) => contra

--If b > a => b does not divide a
bGtAImpNotbDivA : (a,b,n : Nat) -> GT b a -> (isDivisible a b -> Void)
bGtAImpNotbDivA a b n x = impliesContrapositive
                          (isDivisible a b)
                          (LTE b a)
                          (bDivAImpAGtB a b n)
                          (gtImpliesNotLTE x)

--(S (S k)) = 0 is not possible
zNotEqSS : (k : Nat) -> ((S (S k)) = 0 -> Void)
zNotEqSS Z = absurd
zNotEqSS (S k) = absurd

--isDivisible p 0 => (S (S k)) = 0
help4 : (p : Nat) -> LTE 2 p -> isDivisible p 0 -> p = 0
help4 Z LTEZero _ impossible
help4 Z (LTESucc _) _ impossible
help4 (S Z) (LTESucc LTEZero) _ impossible
help4 (S Z) (LTESucc (LTESucc _)) _ impossible
help4 (S (S k)) (LTESucc (LTESucc LTEZero)) x = snd (snd x)

--If x = 0, and p >= 2, x cannot divide p
zNotDivp : (p : Nat) -> LTE 2 p -> ((isDivisible p 0) -> Void)
zNotDivp Z LTEZero impossible
zNotDivp Z (LTESucc _) impossible
zNotDivp (S Z) (LTESucc LTEZero) impossible
zNotDivp (S Z) (LTESucc (LTESucc _)) impossible
zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)) =
                        impliesContrapositive
                        (isDivisible (S (S k)) 0)
                        ((S (S k)) = 0)
                        (help4 (S (S k)) (LTESucc (LTESucc LTEZero)))
                        (zNotEqSS k)

-- Helping out metaHelp
metaMetaHelp5 : (j : Nat) -> (S (j+0)) = (S j)
metaMetaHelp5 Z = Refl
metaMetaHelp5 (S k) = rewrite plusZeroRightNeutral k in Refl

--Helping out help5
metaHelp5 : (S (S k)) = (S (j+0)) -> (S (S k)) = (S (j))
metaHelp5 {j} prf = rewrite sym (metaMetaHelp5 j) in prf

-- Helping out the absurd case
help5: (S (S k)) = (S (j+0)) -> LT (S j) (S (S k)) ->  LTE (S Z) 0
help5 {k} {j} prf x = lteMinusConstantRight {c=(S j)}
            (rewrite sym (metaMetaHelp5 j) in
             rewrite sym prf in
             rewrite eqSucc (S (S k)) (S j) (metaHelp5 prf) in
             x)

--If a divides b => b=a*n
bDivAImpBEqAN : (a,b : Nat) -> isDivisible b a ->  (k : Nat ** b = a * k)
bDivAImpBEqAN a b (p ** (proofGT, proofEq)) = (p ** proofEq)

--To help out help6
metaHelp6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = x*c) -> q = c -> (p = q*x)
metaHelp6 p x c prf prf1 = rewrite prf1 in
                       rewrite multCommutative c x in prf

--To help out a case in notDivIfRem
help6 : (p : Nat) -> (x : Nat) -> (c : Nat) ->
  (p = q*x) -> (p = (S r) + q*x) ->
  (Z = (S r))
help6 p x c {q} {r} p1 p2 = plusRightCancel Z (S r) (q*x) (trans (sym p1) p2)

--To help out another case of notDivIfRem
help7 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) -> (r : Nat) ->
        c + k = q -> p = x*c -> p = (S r) + q*x ->
        Z = (S r) + k*x
help7 p x c k r pfSum pfMul pfRem =
          plusRightCancel Z ((S r)+k*x) (c*x)
          (rewrite sym (plusAssociative (S r) (k*x) (c*x)) in
           rewrite plusCommutative (k*x) (c*x) in
           rewrite sym (multDistributesOverPlusLeft c k x) in
           rewrite pfSum in
           rewrite sym (multCommutative x c) in
           rewrite sym (pfMul) in pfRem)

--Helper for help8
metahelp8 : (x : Nat) -> (S q) + k = c -> x +(q+k)*x = c*x
metahelp8 x prf = rewrite sym prf in Refl

--Last case!
help8 : (p : Nat) -> (x : Nat) -> (c : Nat) -> (k : Nat) ->
        (m : Nat) -> (r : Nat) -> (q : Nat) ->
        (S q) + k = c -> (S (S r)) + m = x -> p = x*c -> p = (S r) + q*x ->
        Z = k*(S r) + (S k)*(S m)
help8 p x c k m r q qLtc srLtx pfMul pfRem =
          plusLeftCancel (S r) Z (k*(S r) + (S k)*(S m))
          (rewrite plusAssociative (S r) (k*(S r)) ((S k)*(S m)) in
           rewrite sym (multDistributesOverPlusRight (S k) (S r) (S m)) in
           rewrite plusAssociative r (S Z) m in
           rewrite plusCommutative r (S Z) in
           rewrite srLtx in
           rewrite sym (plusCommutative (k*x) ((S (S r)) + m)) in
           rewrite srLtx in
           rewrite plusCommutative (k*x) x in
           rewrite plusZeroRightNeutral r in
           plusLeftCancel (q*x) (S r) (x + k*x)
           (rewrite plusAssociative (q*x) x (k*x) in
            rewrite plusCommutative (q*x) x in
            rewrite sym (multDistributesOverPlusLeft (S q) k x) in
            rewrite metahelp8 {q=q} {k=k} {c=c} x qLtc in
            rewrite (multCommutative c x) in
            rewrite sym pfMul in
            rewrite plusCommutative (q*x) (S r) in
            (sym pfRem)))

help9 : (k,r,m : Nat) ->
        Z = k*(S r) + (S k)*(S m) -> Z = (S k)*(S m) + k*(S r)
help9 k r m prf = rewrite plusCommutative ((S k)*(S m)) (k*(S r)) in prf

--To help out the last case, by creating a term of an uninhabited type
notDivIfRem : (p : Nat) -> (x : Nat) -> (r : Nat) -> {q : Nat} ->
  (p = (S r) + q*x) -> LT (S r) x ->
  (c : Nat ** p = x * c) -> Void
notDivIfRem p x r {q=q} prfRem prfLt (c ** prfDiv) =
    case decEq q c of
        (Yes prf) => absurd $
                      (help6 p x c (metaHelp6 p x c prfDiv prf) prfRem)
        (No contra) => case totOrdNat q c of
              (Left l) => void (contra l)
              (Right (Left qLtc)) => case (lteToLEQ qLtc) of
                        (k ** pf1) => case (lteToLEQ prfLt) of
                          (m ** pf2) => absurd $
                              help9 k r m
                                (help8 p x c k m r q pf1 pf2 prfDiv prfRem)
              (Right (Right qGtc)) => case (lteToLEQ (lteSuccLeft qGtc)) of
                          (k ** pf) => absurd $
                              (help7 p x c k r pf prfDiv prfRem)

--The usual case for divisibility
usual : (p : Nat) -> LTE 2 p -> (x : Nat) -> (LT 0 x) -> (LT x p) ->
  (euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))) ->
  Dec (isDivisible p x)
usual Z LTEZero _ _ _ _ impossible
usual Z (LTESucc _) _ _ _ _ impossible
usual (S Z) (LTESucc LTEZero) _ _ _ _ impossible
usual (S Z) (LTESucc (LTESucc _)) _ _ _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z LTEZero _ _ impossible
usual (S (S _)) (LTESucc (LTESucc LTEZero)) Z (LTESucc _) _ _ impossible
usual (S (S k)) (LTESucc (LTESucc LTEZero))
      (S j) (LTESucc LTEZero)
      xLtp euc with (euc)
        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (Z ** (Z ** (pf,_))) = absurd $ pf

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S Z) ** (Z ** (pf,_))) = absurd $
                      (help5 pf xLtp)

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | ((S (S b)) ** (Z ** (pf,_))) =
                Yes ((S (S b)) ** ((LTESucc LTEZero),
                                    (rewrite multCommutative (S j) (S (S b)) in pf)))

        usual (S (S k)) (LTESucc (LTESucc LTEZero))
              (S j) (LTESucc LTEZero)
              xLtp euc | (_ ** ((S a) ** (pf1,pf2))) = No
                              (impliesContrapositive
                                (isDivisible (S (S k)) (S j))
                                (c : Nat ** (S (S k)) = (S j) * c)
                                (bDivAImpBEqAN (S j) (S (S k)))
                                (notDivIfRem (S (S k)) (S j) a pf1 pf2))

--Decidability for divisibility
decDiv : (p : Nat) -> LTE 2 p -> (x : Nat) ->
  {euc : (q : Nat ** (r : Nat ** ((p = r + (q * x)), LT r x)))} ->
  Dec (isDivisible p x)
decDiv Z LTEZero _ impossible
decDiv Z (LTESucc _) _ impossible
decDiv (S Z) (LTESucc LTEZero) _ impossible
decDiv (S Z) (LTESucc (LTESucc _)) _ impossible
decDiv (S (S k)) (LTESucc (LTESucc LTEZero)) x {euc=big} =
    case totOrdNat (S (S k)) x of
      (Left l) => Yes (1 ** ((LTESucc LTEZero),
                             rewrite l in
                             rewrite sym (multOneRightNeutral x) in
                             Refl))
      (Right (Left l)) => No (bGtAImpNotbDivA
                              (S (S k)) x
                              (divNatNZ x (S (S k)) SIsNotZ)
                              l)
      (Right (Right r)) => case x of
          Z => No (zNotDivp (S (S k)) (LTESucc (LTESucc LTEZero)))
          (S m) => usual (S (S k)) (LTESucc (LTESucc LTEZero)) (S m)
                   (LTESucc LTEZero) r big


module Problem01
-- Find the last element of a list.

myLastV : Vect (S n) a -> a
myLastV [x] = x
myLastV (_::x::xs) = myLastV (x::xs)

myIsCons : List a -> Bool
myIsCons [] = False
myIsCons (x::xs) = True

myLastL : (l : List a) -> (ok : isCons l = True) -> a
myLastL [x] _ = x
myLastL (y::x::xs) _ = myLastL (x::xs) Refl


data Tree elem = ||| A (sub-)tree with no data.
                 Empty
               | ||| A node with a left subtree, a value, and a right subtree.
                 Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1, tree2

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


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

%name Vect xs, ys, zs

curry : ((a, b) -> c) -> a -> b -> c
curry f x y = ?curry_rhs

uncurry : (a -> b -> c) -> (a, b) -> c
uncurry f x = ?uncurry_rhs

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

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


module Printf

data Format = Number Format
            | Str Format
            | Lit Char Format  -- do we really need String literals?
            | Chr Format       -- from exercise 2
            | Dbl Format
            | End

total PrintfType : Format -> Type
PrintfType (Number fmt) = Int -> PrintfType fmt  -- NOTE: it would be nice if
                                                 -- we could specify
                                                 -- Num a => a -> PrintfType fmt
PrintfType (Str fmt) = String -> PrintfType fmt
PrintfType (Lit lit fmt) = PrintfType fmt
PrintfType End = String  -- teeechnically it should be IO ().
                         -- sprintf would have type ... -> String
PrintfType (Chr fmt) = Char -> PrintfType fmt
PrintfType (Dbl fmt) = Double -> PrintfType fmt

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

toFormat : List Char -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: cs) = Number (toFormat cs)
toFormat ('%' :: 's' :: cs) = Str (toFormat cs)
toFormat ('%' :: 'c' :: cs) = Chr (toFormat cs)
toFormat ('%' :: 'f' :: cs) = Dbl (toFormat cs)
toFormat (c :: cs) = Lit c (toFormat cs)  -- sorry, I'm lazy

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

printfExample : String
printfExample = printf "%d %d      %%%%%%s" 10 2 "foo"

-- NOTEs:
-- Using Lit Char instead of Lit String made things easier when building
-- literals.  I'm curious about the efficiency though...

-- There's still a bit of dependency between format (PrintfType) and
-- toFormat.  For example there is no guarantee that toFormat
-- will produce a case for all possible Formats.
-- I wonder if there are languages where we can specify that a function
-- must be surjective.

-- Let's go back to Chapter6.idr


> module Nat.Coprime

> import Nat.GCD
> import Nat.GCDAlgorithm
> import Unique.Predicates
> import Equality.Properties
> import Nat.GCDEuclid
> import Pairs.Operations
> import Sigma.Sigma

> %default total

> %access public export

> |||
> data Coprime : (m : Nat) -> (n : Nat) -> Type where
>   MkCoprime : {m, n : Nat} -> gcdAlg m n = S Z -> Coprime m n

> |||
> CoprimeUnique : {m, n : Nat} -> Unique (Coprime m n)
> CoprimeUnique {m} {n} (MkCoprime p) (MkCoprime q) = cong (uniqueEq (gcdAlg m n) (S Z) p q)


module Chapter3

import TypesAndFunctions
import Category
import Isomorphism
import Universality
import Naturality

%default total

Exercise_3_1_1 : {cat : Category} -> {a, b, c : Object cat} ->
  Isomorphic {cat} a b -> Bijection (Morphism cat a c) (Morphism cat b c)
Exercise_3_1_1 {cat}
  (abIsomorphism ** (baIsomorphism ** ((isLeftInverse, isRightInverse)))) =
    ((\f : Morphism cat a c => f .* baIsomorphism) **
     ((\g : Morphism cat b c => g .* abIsomorphism) **
     ((\f' : Morphism cat a c =>
       let
         assoc = Associativity cat f' baIsomorphism abIsomorphism
         rightId = RightIdentity cat f'
       in
       replace {p=(\f'' => f'' = f')} (sym assoc)
         (replace {p=(\z => f' .* z = f')} (sym isLeftInverse) rightId),
      \g' : Morphism cat b c =>
       let
         assoc = Associativity cat g' abIsomorphism baIsomorphism
         rightId = RightIdentity cat g'
       in
       replace {p=(\g'' => g'' = g')} (sym assoc)
         (replace {p=(\z => g' .* z = g')} (sym isRightInverse) rightId)))))

Exercise_3_1_2 : {cat : Category} -> (a : Object cat) -> Isomorphic {cat} a a
Exercise_3_1_2 a =
  (catId a ** (catId a ** (LeftIdentity _ _, LeftIdentity _ _)))

Exercise_3_1_3 : {cat : Category} -> {a, b : Object cat} ->
  IsTerminal {cat} a -> IsTerminal {cat} b -> Isomorphic {cat} a b
Exercise_3_1_3 aIsTerminal bIsTerminal =
  (fst (bIsTerminal a) ** (fst (aIsTerminal b) **
    (IdOnlyTerminalEndomorphism aIsTerminal
      (fst (aIsTerminal b) .* fst (bIsTerminal a)),
    (IdOnlyTerminalEndomorphism bIsTerminal
      (fst (bIsTerminal a) .* fst (aIsTerminal b))))))

Exercise_3_1_4 : {cat : Category} -> {a, b : Object cat} ->
  (aIsTerminal : IsTerminal {cat} a) -> (bIsTerminal : IsTerminal {cat} b) ->
  IsUnique {cat} {a} {b}
    (IsIsomorphism {cat} {a} {b})
    (fst (Exercise_3_1_3 {cat} {a} {b} aIsTerminal bIsTerminal))
Exercise_3_1_4 {cat} {a} {b} aIsTerminal bIsTerminal =
  ((fst (aIsTerminal b) **
   (IdOnlyTerminalEndomorphism aIsTerminal _,
    IdOnlyTerminalEndomorphism bIsTerminal _)),
   \g : Morphism cat a b,
    g' : DPair (Morphism cat b a) (IsInverse {cat} g) =>
      snd (snd (bIsTerminal a)) g ())

Exercise_3_2_1_left : {cat : Category} -> {a, b, x, y : Object cat} ->
  (fInv : Morphism cat b a) -> (g : Morphism cat x y) ->
  (h : Morphism cat a x) ->
  ((preCompose {cat} {a=b} {b=a} {c=y} fInv) .
    (postCompose {cat} {a} {b=x} {c=y} g)) h =
  After cat {a=b} {b=x} {c=y} g (After cat {a=b} {b=a} {c=x} h fInv)
Exercise_3_2_1_left fInv g h = Associativity cat g h fInv

Exercise_3_2_1_right : {cat : Category} -> {a, b, x, y : Object cat} ->
  (fInv : Morphism cat b a) -> (g : Morphism cat x y) ->
  (h : Morphism cat a x) ->
  ((postCompose {cat} {a=b} {b=x} {c=y} g) .
    (preCompose {cat} {a=b} {b=a} {c=x} fInv)) h =
  After cat {a=b} {b=x} {c=y} g (After cat {a=b} {b=a} {c=x} h fInv)
Exercise_3_2_1_right fInv g h = Refl

Exercise_3_3_1 : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  Morphism cat observerB observerA
Exercise_3_3_1 = ObserverChangeInducedMorphism

Exercise_3_3_2 : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  (natural : ObserverChangeIsNatural {cat} {observerA} {observerB} beta) ->
  (y : Object cat) -> (g : Morphism cat observerA y) ->
  beta y g =
    After cat {a=observerB} {b=observerA} {c=y}
      g (Exercise_3_3_1 {cat} {observerA} {observerB} beta)
Exercise_3_3_2 beta natural y g =
  appEq {x=g} (ObserverChangeIsPreComposition beta natural y)


-- Adder.idr

-- Demonstrate functions with variable number of arguments by an
-- adder function

AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType = (next : numType) -> AdderType k numType

||| An adder function for variable number of arguments
adder : Num numType => (numargs : Nat) -> (acc : numType) -> AdderType numargs numType
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)


module Game

import Quantities
import Quantities.Screen

ScreenSpeed : Quantity
ScreenSpeed = ScreenLength </> Time

Pxs : Unit ScreenSpeed
Pxs = Pixel <//> Second

record PlayerState where
  constructor MkPlayerState
  xSpeed : F Pxs
  ySpeed : F Pxs
  xPos   : F Px
  yPos   : F Px

gravity : Quantities.Core.F (Pxs <//> Second)
gravity = -800 =| (Pxs <//> Second)

-- Update player position and speed after a given duration
updatePlayerState : F Second -> PlayerState -> PlayerState
updatePlayerState dt (MkPlayerState xs ys xp yp) =
  let newYPos = yp <+> ys |*| dt
  in if newYPos <= (0 =| Px)
       then MkPlayerState (0 =| Pxs) (0 =| Pxs) xp (0 =| Px)
       else MkPlayerState xs (ys <+> gravity |*| dt)
                          (xp <+> xs |*| dt) newYPos


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

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


module Data.LeftistHeap

import Decidable.Order

%default total

mutual
  export
  data Heap : .(constraint : Ordered a rel) -> .(count : Nat) -> Type where
       Empty : Heap _ Z
       Node : (n : Nat)
           -> (value : a)
           -> {countLeft : Nat}
           -> (left : Heap constraint countLeft)
           -> {countRight : Nat}
           -> (right : Heap constraint countRight)
           -> .{auto fitsLeft : Fits value left}
           -> .{auto fitsRight : Fits value right}
           -> .{auto leftistPrf : LTE (rank right) (rank left)}
           -> .{auto rankPrf : n = S $ rank right}
           -> Heap constraint (S $ countLeft + countRight)

  Fits : {constraint : Ordered a rel} -> a -> Heap constraint cnt -> Type
  Fits {cnt = Z} _ _ = ()
  Fits {cnt = S _} x h = rel x (findMin h)

  rank : Heap _ _ -> Nat
  rank Empty = Z
  rank (Node _ _ _ right) = S $ rank right

  export
  findMin : .{constraint : Ordered a _} -> Heap constraint (S _) -> a
  findMin (Node _ value _ _) = value

export
empty : Heap _ Z
empty = Empty

makeFit : .{constraint : Ordered a rel}
       -> .(fitsValue : a)
       -> (value : a)
       -> {count1 : Nat}
       -> {count2 : Nat}
       -> (h1 : Heap constraint count1)
       -> (h2 : Heap constraint count2)
       -> .{auto fits1 : Fits value h1}
       -> .{auto fits2 : Fits value h2}
       -> .{auto relPrf : rel fitsValue value}
       -> Subset (Heap constraint (S $ count1 + count2)) (Fits fitsValue)
makeFit {count1} {count2} {relPrf} fitsValue value h1 h2 with (order {to = LTE} (rank h1) (rank h2))
  | (Left _) = rewrite plusCommutative count1 count2 in
               Element (Node _ value h2 h1) relPrf
  | (Right _) = Element (Node _ value h1 h2) relPrf

covering
mergeHelper : .{constraint : Ordered a rel}
           -> .{value : a}
           -> {count1 : Nat}
           -> {count2 : Nat}
           -> (h1 : Heap constraint count1)
           -> (h2 : Heap constraint count2)
           -> .{auto fits1 : Fits value h1}
           -> .{auto fits2 : Fits value h2}
           -> Subset (Heap constraint (count1 + count2)) (Fits value)
mergeHelper Empty Empty = Element Empty ()
mergeHelper {fits1} h@(Node {countLeft} {countRight} n _ _ _) Empty = rewrite plusZeroRightNeutral (countLeft + countRight) in Element h fits1
mergeHelper {fits2} Empty h@(Node {countLeft} {countRight} n _ _ _) = Element h fits2
mergeHelper {value} {rel}
            (Node {countLeft = countLeft1} {countRight = countRight1} _ value1 left1 right1)
            (Node {countLeft = countLeft2} {countRight = countRight2} _ value2 left2 right2)
  = case order {to = rel} value1 value2 of
    Left orderPrf => rewrite sym $ plusAssociative countLeft1 countRight1 (S $ countLeft2 + countRight2) in
                     let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value1} right1 (Node _ value2 left2 right2) in
                     makeFit value value1 left1 mergedHeap
    Right orderPrf => rewrite sym $ plusSuccRightSucc (countLeft1 + countRight1) (countLeft2 + countRight2) in
                      rewrite plusCommutative countLeft2 countRight2 in
                      rewrite plusAssociative (countLeft1 + countRight1) countRight2 countLeft2 in
                      let (Element mergedHeap fitsMergedHeap) = mergeHelper {value = value2} (Node _ value1 left1 right1) right2 in
                      makeFit value value2 mergedHeap left2

export
merge : .{constraint : Ordered a rel}
     -> {count1 : Nat} -> {count2 : Nat}
     -> (h1 : Heap constraint count1) -> (h2 : Heap constraint count2)
     -> Heap constraint (count1 + count2)
merge Empty Empty = Empty
merge {count1} h Empty = rewrite plusZeroRightNeutral count1 in h
merge Empty h = h
merge h1@(Node _ _ _ _) h2@(Node _ _ _ _)
  = assert_total $ case order {to = rel} (findMin h1) (findMin h2) of
    Left orderPrf => case mergeHelper {value = (findMin h1)} h1 h2 {fits1 = reflexive (findMin h1)} of
                     Element h _ => h
    Right orderPrf => case mergeHelper {value = (findMin h2)} h1 h2 {fits2 = reflexive (findMin h2)} of
                      Element h _ => h

export
insert : .{constraint : Ordered a _} -> .{n : Nat} -> a -> Heap constraint n -> Heap constraint (S n)
insert value heap = merge (Node 1 value Empty Empty) heap

export
deleteMin : .{constraint : Ordered a _} -> {n : Nat} -> Heap constraint (S n) -> Heap constraint n
deleteMin (Node _ _ left right) = merge left right

namespace OrderedLeftistHeap
  export
  data CountedHeap : .(constraint : Ordered a rel) -> Type where
       MkCountedHeap : (n : Nat) -> (Heap constraint n) -> CountedHeap constraint

  export
  empty : CountedHeap _
  empty = MkCountedHeap Z empty

  export
  count : CountedHeap _ -> Nat
  count (MkCountedHeap n _) = n

  export
  findMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> Maybe ty
  findMin (MkCountedHeap Z _) = Nothing
  findMin (MkCountedHeap (S _) h) = Just $ findMin h

  export
  merge : .{constraint : Ordered _ _} -> CountedHeap constraint -> CountedHeap constraint -> CountedHeap constraint
  merge (MkCountedHeap count1 h1) (MkCountedHeap count2 h2) = MkCountedHeap (count1 + count2) (merge h1 h2)

  export
  insert : .{constraint : Ordered ty _} -> ty -> CountedHeap constraint -> CountedHeap constraint
  insert a (MkCountedHeap n h) = MkCountedHeap (S n) (insert a h)

  export
  deleteMin : .{constraint : Ordered ty _} -> CountedHeap constraint -> CountedHeap constraint
  deleteMin orig@(MkCountedHeap Z h) = orig
  deleteMin (MkCountedHeap (S n) h) = MkCountedHeap n (deleteMin h)


import Data.Vect

allLengths : Vect l String -> Vect l Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs

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

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

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

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

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

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


> module InfiniteHorizonSequentialDecisionProblems.Theory

> import Data.Vect

> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Vect.Operations

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

* Sequential decision processes

> State  :  Type
> Ctrl   :  (x : State) -> Type
> M      :  Type -> Type
> nexts  :  (x : State) -> (y : Ctrl x) -> M State
> fmap   :  {A, B : Type} -> (A -> B) -> M A -> M B

* Sequential decision problems

> Val              :  Type
> reward           :  (x : State) -> (y : Ctrl x) -> (x' : State) -> Val
> plus             :  Val -> Val -> Val
> LTE              :  Val -> Val -> Type
> meas             :  M Val -> Val

* Policies

> Policy  :  Type
> Policy  =  (x : State) -> Ctrl x

* The value of policies

> ||| A value function ...
> val : State -> Policy -> Val

> ||| ... that fulfils the specification
> valSpec  :  Type
> valSpec  =  (x : State) -> (p : Policy) ->
>             val x p
>             =
>             meas (fmap (\ x' => reward x (p x) x' `plus` val x' p) (nexts x (p x)))

* Optimality of policies

> |||
> Opt    :  Policy -> Type
> Opt p  =  (x : State) -> (p' : Policy) -> val x p' `LTE` val x p

* Optimal policies

> |||
> cval        :  (x : State) -> Ctrl x -> (p : Policy) -> Val
> cval x y p  =  meas (fmap (\ x' => reward x y x' `plus` val x' p) (nexts x y))

> cvalargmax      :  (x : State) -> (p : Policy) -> Ctrl x

> ||| A policy ...
> opt : Policy

> ||| ... that fulfils Bellman's equation
> optSpec  :  Type
> optSpec  =  (x : State) -> opt x = cvalargmax x opt

* Optimality of |opt|

** Additional assumptions

> reflexiveLTE     :  (a : Val) -> a `LTE` a
> transitiveLTE    :  {a, b, c : Val} -> a `LTE` b -> b `LTE` c -> a `LTE` c
> monotonePlusLTE  :  {a, b, c, d : Val} -> a `LTE` b -> c `LTE` d -> (a `plus` c) `LTE` (b `plus` d)
> measMon          :  {A : Type} ->
>                     (f : A -> Val) -> (g : A -> Val) ->
>                     ((a : A) -> (f a) `LTE` (g a)) ->
>                     (ma : M A) -> meas (fmap f ma) `LTE` meas (fmap g ma)

> cvalmax         :  (x : State) -> (p : Policy) -> Val
> cvalargmaxSpec  :  (x : State) -> (p : Policy) -> cvalmax x p = cval x (cvalargmax x p) p
> cvalmaxSpec     :  (x : State) -> (y : Ctrl x) -> (p : Policy) -> (cval x y p) `LTE` (cvalmax x p)

** |opt| is optimal

> mutual

>   ||| ... is an optimal policy
>   optLemma1  :  (vs : valSpec) -> (os : optSpec) ->
>                 (x : State) -> (y : Ctrl x) -> (p : Policy) ->
>                 cval x y p `LTE` cval x y opt
>   optLemma1 vs os x y p = s9 where
>     f' : State -> Val
>     f' = \ x' => reward x y x' `plus` val x' p
>     f  : State -> Val
>     f  = \ x' => reward x y x' `plus` val x' opt
>     s1 : (x' : State) -> val x' p `LTE` val x' opt
>     s1 x' = assert_total (optLemma2 vs os) x' p
>     s2 : (x' : State) -> (f' x') `LTE` (f x')
>     s2 x' = monotonePlusLTE (reflexiveLTE (reward x y x')) (s1 x')
>     s3 : meas (fmap f' (nexts x y)) `LTE` meas (fmap f (nexts x y))
>     s3 = measMon f' f s2 (nexts x y)
>     s9 : cval x y p `LTE` cval x y opt
>     s9 = s3

>   ||| ... is an optimal policy
>   optLemma2 : (vs : valSpec) -> (os : optSpec) -> Opt opt
>   optLemma2 vs os x p' = s9 where
>     s1 : val x p' = cval x (p' x) p'
>     s1 = vs x p'
>     s2 : cval x (p' x) p' `LTE` cval x (p' x) opt
>     s2 = assert_total optLemma1 vs os x (p' x) p'
>     s3 : cval x (p' x) opt `LTE` cvalmax x opt
>     s3 = cvalmaxSpec x (p' x) opt
>     s4 : cvalmax x opt = cval x (cvalargmax x opt) opt
>     s4 = cvalargmaxSpec x opt
>     s5 : cval x (cvalargmax x opt) opt = cval x (opt x) opt
>     s5 = replace {P = \ U => cval x U opt = cval x (opt x) opt} (os x) Refl
>     s6 : cval x (opt x) opt = val x opt
>     s6 = sym (vs x opt)
>     s7 : cval x (p' x) p' `LTE` cvalmax x opt
>     s7 = transitiveLTE s2 s3
>     s8 : val x p' `LTE` cvalmax x opt
>     s8 = replace {P = \ W => W `LTE` cvalmax x opt} (sym s1) s7
>     s9 : val x p' `LTE` val x opt
>     s9 = replace {P = \ W => val x p' `LTE` W} (trans (trans s4 s5) s6) s8

* Can one compute optimal policies?

If |State| is finite

> finiteState : Finite State

we can compute the number of values of type |State| and collect them in
a vector

> cardState : Nat
> cardState = card finiteState

> vectState : Vect cardState State
> vectState = toVect finiteState

For a fixed policy |p|, we can represent the value of |p| by a value table

> vt : Policy -> Vect cardState Val

> val x p = index k (vt p) where
>   k : Fin cardState
>   k = lookup x vectState (toVectComplete finiteState x)

In this case, the specification of |val|

< valSpec  =  (x : State) -> (p : Policy) ->
<             val x p
<             =
<             meas (fmap (\ x' => reward x (p x) x' `plus` val x' p) (nexts x (p x)))

defines a linear, implicit problem for the components |vt p|. Let

> {-

> ---}


{-------------------------------------------------------------
            Equivlance relation rules mod n.
-------------------------------------------------------------}

|||
||| ModEq n x y is (aweful) prefix notation for a type x == y (mod n).
|||
||| This is a singleton dependent type, and it is inhabited solely
||| by its constructor.  So you can pattern match on tye constructor
||| by there are no values.
|||
data ModEq : (n:Nat) -> (x:Nat) -> (y:Nat) -> Type where
    {- 3 constructors, we mostly think of n, x, y as implicit.
        reflexive:      x==x (mod n),
        left-induct:    x == y (mod n) => x+n == y      (mod n)
        right-induct:   x == y (mod n) => x == (y+n)    (mod n)
    -}
  Reflex : (x:Nat) -> ModEq n x x  --- Needs syntatic sugar, for now prefix
  LInd : (ModEq n x y) -> ModEq n (x+n) y
  RInd : (ModEq n x y) -> ModEq n x (y+n)

{- Proof of reflexive property. -}
total
isRefl : (x:Nat) -> ModEq n x x
isRefl x = Reflex x

{----- Proof of symmetric property. -----}
total
isSym : (ModEq n x y) -> ModEq n y x
{- x=x => x=x -}
isSym (Reflex x) = Reflex x
{-
    (LInd (x=y=>(x+n)=y)
  & u={x=y})
  -------------------
    u={x=y}
  ------------------
    y=x (induct on u)
   ------------------
    RInd y=x = y=(x+n)
 -}
isSym (LInd u)   = RInd (isSym u)
{- x=(y+n) => u={x=y} => y=x (induct) => (y+n)=x -}
isSym (RInd u)   = LInd (isSym u)

{----- Proof of transitive property. -----}
total isTrans : (ModEq n x y) -> (ModEq n y z) -> (ModEq n x z)
--isTrans (RInd _) (LInd _) = ?isTrans_rhs_1
{- x=x & x=y => x=y -}
isTrans (Reflex x) v = v
isTrans u (Reflex y) = u
{- ((x=y=>(x+n)=y) & y=z) => x=y & y=z => x=z (induct) => (x+n)=z -}
isTrans (LInd u) v = LInd (isTrans u v)
isTrans u (RInd v) = RInd (isTrans u v)
{- (x=y=>x=(y+n)) & (y=z=>(y+n)=z) => x=y & y=z => x=z (induct) -}
isTrans (RInd u) (LInd v) {n} {x} {y=x+n} = isTrans u v  -- Note: need to expose implicit y=x+n

{----- Proof of congruence property. -----}
total isCong : (ModEq n x y) -> (ModEq n a b) -> (ModEq n (x+a) (y+b))
isCong (Reflex x) (Reflex a) = Reflex (x+a)
isCong {n} (LInd {x} u) (Reflex a) =
    {-
        (x+n) == y (mod n) because u={x == y (mod n)}
        a == a (mod n)
        ---------------------------------------------
        x+a == y+a (mod n)        (induct)
        ---------------------------------------------
        (x+a)+n == y+a (mod n)    (LInd)
        ---------------------------------------------
        x+(a+n) == y+a (mod n)    (Associative)
        ---------------------------------------------
        x+(n+a) == y+a (mod n)    (Commutative)
        ---------------------------------------------
        (x+n)+a == y+a (mod n)    (Associative)
    -}
    let w = (x+a)+n in LInd (isCong u (Reflex a))
    rewrite plusCommutative n x in
        rewrite plusAssociative n x a in
            rewrite plusAssociative (x+a) n in w

isCong {n} (RInd {y} u) (Reflex a) =
--    rewrite plusAssociative y n a in
        rewrite plusCommutative a n in
            rewrite plusAssociative y a n in
                RInd (isCong u (Reflex a))
isCong {n} {x} u (LInd {x=a} v) =   -- imiplicitly need n, x, a in scope.
    {-
        u={x == y (mod n) }
        (a+n) == b only if, v={a==b}
        ----------------------
        x+a == y+b by induction on u, v
        ----------------------
        (x+a)+n == y+b by LInd
        x+(a+n) == y+b by associativity
     -}
    rewrite plusAssociative x a n  in LInd (isCong u v)
isCong {n} {y} u (RInd {y=b} v) =   -- imiplicitly need n, x, a in scope.
    {-
        u={x == y (mod n) }
        a == (b+n) only if, v={a==b}
        ----------------------
        x+a == y+b by induction on u, v
        ----------------------
        x+a == (y+b)+n by RInd
        x+a == y+(b+n) by associativity
    -}
    rewrite plusAssociative y b n  in RInd (isCong u v)


module LeftistHeap

import Heap

%default total
%access private

export
data LeftistHeap a = E | T Int a (LeftistHeap a) (LeftistHeap a)

rank : LeftistHeap a -> Int
rank E           = 0
rank (T r _ _ _) = r

makeT : a -> LeftistHeap a -> LeftistHeap a -> LeftistHeap a
makeT x a b = if rank a >= rank b then T (rank b + 1) x a b
              else T (rank a + 1) x b a

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

  insert x h = merge (T 1 x E E) h

  merge h  E  = h
  merge E  h  = h
  merge h1@(T _ x a1 b1) h2@(T _ y a2 b2) =
    if x <= y then makeT x a1 (merge b1 h2)
    else makeT y a2 (merge h1 b2)

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

  deleteMin E = idris_crash "empty heap"
  deleteMin (T _ x a b) = merge a b


module Cic

import Bits
import Synchronous
import Unsigned

import Data.Bits

%access export
%default total

-- See Hogenauer's 1981 paper "An Economical Class of Digital Filters for
-- Decimation and Interpolation". All the equations are referenced against this
-- paper

--------------------------------------------------------------------------------
-- CIC subcircuits
--------------------------------------------------------------------------------

||| Prune an `Unsigned n` down to a smaller `Unsigned m`
prune : Unsigned n -> Unsigned m
prune {n} {m} x = saturate . cast $
  shiftR (cast . cast {to=Double} $ cast x {to=Integer}) -- Horrible!
         (cast $ n `minus` m)

||| Extend an `Unsigned n` up to a larger `Unsigned m`
extend : Unsigned n -> Unsigned m
extend = saturate . cast

||| Integrator circuit
partial
integrate : Stream (Unsigned n) -> Stream (Unsigned n)
integrate xs = liftA2 (addWrap) xs (delay 0 $ integrate xs)

||| Boolean true every Rth cycle, starting at first cycle
everyR : (r: Nat) -> Stream Bool
everyR   Z    = pure False
everyR (S j) = map (\a=>modNatNZ a (S j) SIsNotZ == 0) $ counterFrom 0

||| Downsampler circuit
downsample : (r: Nat) -> Stream a -> Stream (Maybe a)
downsample r = zipWith (\e, x=>if e then Just x else Nothing) (everyR r)

||| Comb filter circuit
comb : (m : Nat) -> Stream (Maybe (Unsigned n)) -> Stream (Maybe (Unsigned n))
comb _ xs = map (\(a,b)=>map (`minusWrap` b) a) $
            zip xs (regMaybe 0 xs) -- TODO Delay by m... and get

--------------------------------------------------------------------------------
-- Wordlength calculations
--------------------------------------------------------------------------------

||| Recursive definition of a binomial coefficient
nChooseK : (n: Nat) -> (k: Nat) -> Nat
nChooseK n Z = 1
nChooseK Z (S k) = 0
nChooseK (S n) (S k) = if k>n then 0 else
                       nChooseK n k + nChooseK n (S k)

||| Helper to divide two `Nat`s safely, returning zero for division by zero
||| (fight me, mathematicians)
divNatOrZero : Nat -> Nat -> Nat
divNatOrZero k Z = Z
divNatOrZero k (S j) = divNatNZ k (S j) SIsNotZ

parameters (r, n, m : Nat)

  ||| Partial system function, $h_j(k)$ (Eq. 9b)
  hjk : (j, k : Nat) -> Integer
  hjk j k = case j <= n of
    True  => sum $ map (\l => pow (-1) l * cast (
                                (nChooseK n l) *
                                (nChooseK ((n `minus` j)+(k `minus` r*m*l)) (k `minus` r*m*l)))
                       ) [0..(divNatOrZero k (r*m))]
    False => pow (-1) k * cast (nChooseK (minus (2*n+1) j) k)

  ||| Variance error gain for stage j, $F(j)$ (Eq. 16b)
  fj : (j : Nat) -> Double
  fj j = case j == (2*n+1) of
      True  => 1.0
      False => sqrt . cast . sum $ map (\k=>pow (hjk j k) 2) [0..((r*m `minus` 1) * n + j `minus` 1)]

  ||| Max unpruned wordlength, $B_{max}$ (Eq 12)
  bmax : (bin : Nat) -> Nat
  bmax bin = bin + clog2 (pow (r*m) n)

  ||| Error at output due to final rounding/truncation, $E_{2N+1}$ (Eq. 12)
  eT2n1 : (bin, bout : Nat) -> Integer
  eT2n1 bin bout = pow 2 $ bmax bin `minus` bout

  ||| Variance at output due to final rounding/truncation, $\sigma_T_{2N+1}$ (Eq. 14)
  sigmaT2n1 : (bin, bout : Nat) -> Double
  sigmaT2n1 bin bout = sqrt $ cast (pow  (eT2n1 bin bout) 2) / 12.0

  ||| Bits to prune at stage j, $B_j$ (Eq. 21).
  ||| We use log laws to avoid errors with an integer implementation of log2
  bj : (bin, bout, j : Nat) -> Nat
  bj bin bout j = flog2Approx $ (sigmaT2n1 bin bout) * (sqrt $ 6.0 / (cast n)) / fj j

  ||| Bits to keep at stage j
  cicAccPruned : (bin, bout, j : Nat) -> Nat
  cicAccPruned bin bout j = if j==0 then bmax bin else
                                  if j>=(2*n+1) then bout else
                                  bmax bin `minus` bj bin bout j

--------------------------------------------------------------------------------
-- CIC decimator
--------------------------------------------------------------------------------

  ||| Recursive integrator chain
  partial --Because of integrate
  cicDecimateRecI : (bin, bout, j : Nat)
    -> Stream (Unsigned (cicAccPruned bin bout 0))
    -> Stream (Unsigned (cicAccPruned bin bout j))
  cicDecimateRecI bin bout  Z    = id
  cicDecimateRecI bin bout (S j) = map prune . integrate .
                                   cicDecimateRecI bin bout j

  ||| Recursive comb filter chain
  cicDecimateRecC : (bin, bout, j : Nat)
    -> Stream (Maybe (Unsigned (cicAccPruned bin bout n)))
    -> Stream (Maybe (Unsigned (cicAccPruned bin bout (j+n))))
  cicDecimateRecC bin bout  Z    = id
  cicDecimateRecC bin bout (S j) = map (map prune) . comb m .
                                   cicDecimateRecC bin bout j
  ||| CIC decimator circuit
  partial --Because of integrate
  cicDecimate : Stream (Unsigned bin) -> Stream (Maybe (Unsigned bout))
  cicDecimate {bin} {bout} =
    map (map prune) .                        -- Final truncation, after
    cicDecimateRecC bin bout n .             -- Recursive comb steps, after
    downsample r .                           -- Downsample, after
    cicDecimateRecI bin bout n .             -- Recursive integrate steps, after
    map (extend {m=cicAccPruned bin bout 0}) -- Input extend

-- TODO Is it worth proving that cicAccPruned bin bout (2*n+1)) == bout?

||| Example of calculating pruning for Hogenauer's design example (Section IV. D)
mainBj : IO ()
mainBj = print $ map (bj 25 4 1 16 16) [1..8]

||| Example of simulating `cicDecimate`
partial
mainSim : IO ()
mainSim = do let dut = cicDecimate {bin=8} {bout=8} 3 3 1
             let inp = map (\t=> saturate {n=8} . cast $
                                 sin (t*2*pi/10.0) * 127 + 127 )
                       $ counterFrom 0 {ty=Double}
             let out = take 40 $ simulate dut inp
             putStrLn . show $ zip (take 40 inp) out


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

%name Vect xs, ys, zs

transpose : {m : Nat} -> Vect n (Vect m a) -> Vect m (Vect n a)
transpose [] = ?empties
transpose (x :: xs) = let xs_trans = transpose xs in
                          ?transposeHelper


module Coinduction

corecord Stream a where
  head : a
  tail : Stream a

total causal
zeros : Stream Nat
&head zeros = Z
&tail zeros = zeros

total causal
repeat : a -> Stream a
&head repeat n = n
&tail repeat n = repeat n

total causal
map : (a -> b) -> Stream a -> Stream b
&head map f s = f (head s)
&tail map f s = map f (tail s)

total causal
nats : Stream Nat
&head nats = Z
&tail nats = map S nats

total causal
zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c
&head zipWith f s t = f (head s) (head t)
&tail zipWith f s t = zipWith f (tail s) (tail t)

total causal
fib : Stream Nat
&head       fib = Z
&head &tail fib = S Z
&tail &tail fib = zipWith (+) fib (tail fib)

total causal
unfold : (s -> (a, s)) -> s -> Stream a
&head unfold step x = fst (step x)
&tail unfold step x = unfold step (snd (step x))

total causal
interleave : Stream a -> Stream a -> Stream a
&head interleave s t = head s
&tail interleave s t = interleave t (tail s)

total causal
toggle : Stream Nat
&head       toggle = Z
&head &tail toggle = S Z
&tail &tail toggle = toggle

total causal
paperfold : Stream Nat
&head paperfold = Z
&tail paperfold = interleave paperfold toggle

total causal
paperfold' : Stream Nat
paperfold' = interleave toggle paperfold'

total causal
cycle : Nat -> Stream Nat
cycle n = cycle' n n
  where
    total causal
    cycle' : Nat -> Nat -> Stream Nat
    &head cycle' Z     m = Z
    &head cycle' (S n) m = (S n)
    &tail cycle' Z     m = cycle' m m
    &tail cycle' (S n) m = cycle' n m

total causal
fac : Stream Nat
&head fac = (S Z)
&tail fac = (zipWith (*) (map S nats) fac)

total causal
mergef : (Nat -> Nat -> Stream Nat -> Stream Nat) ->
              Stream Nat -> Stream Nat -> Stream Nat
mergef f s t = f (head s) (head t) (mergef f (tail s) (tail t))

total causal
prepend : List a -> Stream a -> Stream
prepend []       s = s
prepend (x ::xs) s = x :: (prepend xs s)

corecord Tree : Type -> Type where
  value : Tree a -> a
  left  : Tree a -> Tree a
  right : Tree a -> Tree a

total causal
tmap : (a -> b) -> Tree a -> Tree b
&value tmap f t = f (value t)
&left  tmap f t = tmap f (left  t)
&right tmap f t = tmap f (right t)

total causal
tzip : (a -> b -> c) -> Tree a -> Tree b -> Tree c
&value tzip f t r = f (value t) (value r)
&left  tzip f t r = tzip f (left  t) (left  r)
&right tzip f t r = tzip f (right t) (right r)

total causal
trepeat : a -> Tree a
&value trepeat n = n
&left  trepeat n = trepeat n
&right trepeat n = trepeat n

total causal
carry : Tree Nat
&value carry = S Z
&left  carry = trepeat Z
&right carry = tmap S carry

total causal unfoldTree : (s -> (a, s, s)) -> s -> Tree a
&value unfoldTree step x = fst' (step x)
&left  unfoldTree step x = unfoldTree step (snd' (step x))
&right unfoldTree step x = unfoldTree step (trd' (step x))

total causal
calculateWilfully : Tree (Nat, Nat)
calculateWilfully = grow((S Z), (S Z))
  where
    total causal
    grow : (Nat, Nat) -> Tree(Nat, Nat)
    grow (n, d) = MkTree (n, d) (grow(n, n + d)) (grow(n + d, d))

corecord Partiality : Type -> Type where
  p : Partiality a -> Either a (Partiality a)
  constructor P

total causal
never : Partiality a
never = P (Right never)

total causal
bind : Partiality a -> (a -> Partiality b) -> Partiality b
bind (P (Left x)) f = f x
bind (P (Right x)) f = P (Right (bind x f))

corecord FunMachine : Type -> Type where
  skip : FunMachine a -> FunMachine a
  calc : FunMachine a -> (a, FunMachine a)
  fun  : FunMachine a -> (a -> a)

total causal
multmachine : Stream Nat -> FunMachine Nat
&skip multmachine s = multmachine (tail s)
&calc multmachine s =
     (fun (multmachine $ tail s) (head s) ,
      multmachine $ tail s)
&fun  multmachine s = (*) (head s)

data Response = OK | BadRequest

total
reject : a -> Response
reject _ = BadRequest

total causal
pingserver : FunMachine Response
&skip pingserver = pingserver
&calc pingserver = (OK, pingserver)
&fun  pingserver = reject

corecord Idler : Type -> Type where
  idle : Idler a -> Idler a
  stop : Idler a -> a

total causal
pingserver' : Idler Response
&idle pingserver' = pingserver'
&stop pingserver' = OK

ping' : Response
ping' = stop (idle (idle pingserver'))

total causal
imap : (a -> b) -> Idler a -> Idler b
&idle imap f i = imap f (idle i)
&stop imap f i = f (stop i)

total causal
counter : Nat -> Idler Nat
&idle counter n = imap S (counter n)
&stop counter n = n


module Utils

import Data.Vect

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

take' : (n : Nat) -> (xs : Stream a) -> Vect n a
take' Z _ = []
take' (S n) (x :: xs) = x :: (take' n xs)

export
shift : Nat -> Vect n a -> Vect n a
shift Z xs = xs
shift (S k) [] = []
shift {n = S m} (S k) (x :: xs) = take' (S m) $ drop (S k) $ cycle (x :: xs)

export
max' : Ord a => Vect (S n) a -> a
max' (x :: xs) = foldl max x xs

export
min' : Ord a => Vect (S n) a -> a
min' (x :: xs) = foldl min x xs

export
allPairs : Vect (S n) a -> Vect (S n) (Vect n (a, a))
allPairs {n} xs = g xs n where
  f : Vect (S n) a -> Vect n (a, a)
  f (x :: xs) = map (MkPair x) xs

  g : Vect (S n) a -> (m : Nat) -> Vect (S m) (Vect n (a, a))
  g xs Z = [f xs]
  g xs (S k) = (f $ shift (S k) xs) :: g xs k


module Algebra.Solver.Ring.Expr

import public Data.List.Elem
import public Algebra.Ring
import Syntax.PreorderReasoning

%default total

--------------------------------------------------------------------------------
--          Natural Numbers
--------------------------------------------------------------------------------

||| Multiplies a value `n` times with itself. In case of `n`
||| being zero, this returns `1`.
public export
pow : Ring a => a -> Nat -> a
pow x 0     = 1
pow x (S k) = x * pow x k

--------------------------------------------------------------------------------
--          Expression
--------------------------------------------------------------------------------

||| Data type representing expressions in a commutative ring.
|||
||| This is used to at compile time compare different forms of
||| the same expression and proof that they evaluate to
||| the same result.
|||
||| An example:
|||
||| ```idris example
||| 0 binom1 : {x,y : Bits8} -> (x + y) * (x + y) === x * x + 2 * x * y + y * y
||| binom1 = solve [x,y]
|||                ((x .+. y) * (x .+. y))
|||                (x .*. x + 2 *. x *. y + y .*. y)
||| ```
|||
||| @ a  the type used in the arithmetic expression
||| @ as list of variables which don't reduce at compile time
|||
||| In the example above, `x` and `y` are variables, while `2`
||| is a literal known at compile time. To make working with
||| variables more convenient (the have to be wrapped in data
||| constructor `Var`, by using function `var` for instance),
||| additional operators for addition, multiplication, and
||| subtraction are provided.
|||
||| In order to proof that two expressions evaluate to the
||| same results, the following steps are taken at compile
||| time:
|||
||| 1. Both expressions are converted to a normal form via
|||    `Algebra.Solver.Ring.Sum.normalize`.
||| 2. The normal forms are compared for being identical.
||| 3. Since in `Algebra.Solver.Ring.Sum` there is a proof that
|||    converting an expression to its normal form does not
|||    affect the result when evaluating it, if the normal
|||    forms are identical, the two expressions must evaluate
|||    to the same result.
|||
||| You can find several examples of making use of this
||| in `Data.Prim.Integer.Extra`.
public export
data Expr : (a : Type) -> (as : List a) -> Type where
  ||| A literal. This should be a value known at compile time
  ||| so that it reduces during normalization.
  Lit   : (v : a) -> Expr a as

  ||| A variabl. This is is for values not known at compile
  ||| time. In order to compare and merge variables, we need an
  ||| `Elem x as` proof.
  Var   : (x : a) -> Elem x as -> Expr a as

  ||| Negates and expression.
  Neg   : Expr a as -> Expr a as

  ||| Addition of two expressions.
  Plus  : (x,y : Expr a as) -> Expr a as

  ||| Multiplication of two expressions.
  Mult  : (x,y : Expr a as) -> Expr a as

  ||| Subtraction of two expressions.
  Minus : (x,y : Expr a as) -> Expr a as

||| While this allows you to use the usual operators
||| for addition and multiplication, it is often convenient
||| to use related operators `.*.`, `.+.`, and similar when
||| working with variables.
public export
Num a => Num (Expr a as) where
  (+) = Plus
  (*) = Mult
  fromInteger = Lit . fromInteger

public export
Neg a => Neg (Expr a as) where
  negate = Neg
  (-)    = Minus

||| Like `Var` but takes the `Elem x as` as an auto implicit
||| argument.
public export
var : {0 as : List a} -> (x : a) -> Elem x as => Expr a as
var x = Var x %search

--------------------------------------------------------------------------------
--          Syntax
--------------------------------------------------------------------------------

infixl 8 .+., .+, +.

infixl 8 .-., .-, -.

infixl 9 .*., .*, *.

||| Addition of variables. This is an alias for
||| `var x + var y`.
public export
(.+.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.+.) x y = Plus (var x) (var y)

||| Addition of variables. This is an alias for
||| `x + var y`.
public export
(+.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(+.) x y = Plus x (var y)

||| Addition of variables. This is an alias for
||| `var x + y`.
public export
(.+) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.+) x y = Plus (var x) y

||| Subtraction of variables. This is an alias for
||| `var x - var y`.
public export
(.-.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.-.) x y = Minus (var x) (var y)

||| Subtraction of variables. This is an alias for
||| `x - var y`.
public export
(-.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(-.) x y = Minus x (var y)

||| Subtraction of variables. This is an alias for
||| `var x - y`.
public export
(.-) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.-) x y = Minus (var x) y

||| Multiplication of variables. This is an alias for
||| `var x * var y`.
public export
(.*.) :  {0 as : List a}
      -> (x,y : a)
      -> Elem x as
      => Elem y as
      => Expr a as
(.*.) x y = Mult (var x) (var y)

||| Multiplication of variables. This is an alias for
||| `var x * y`.
public export
(*.) :  {0 as : List a}
     -> (x : Expr a as)
     -> (y : a)
     -> Elem y as
     => Expr a as
(*.) x y = Mult x (var y)

||| Multiplication of variables. This is an alias for
||| `x * var y`.
public export
(.*) :  {0 as : List a}
     -> (x : a)
     -> (y : Expr a as)
     -> Elem x as
     => Expr a as
(.*) x y = Mult (var x) y

--------------------------------------------------------------------------------
--          Evaluation
--------------------------------------------------------------------------------

||| Evaluation of expressions. This keeps the exact
||| structure of the expression tree. For instance
||| `eval $ x .*. (y .+. z)` evaluates to `x * (y + z)`.
public export
eval : Ring a => Expr a as -> a
eval (Lit v)     = v
eval (Var x y)   = x
eval (Neg v)     = neg $ eval v
eval (Plus x y)  = eval x + eval y
eval (Mult x y)  = eval x * eval y
eval (Minus x y) = eval x - eval y

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

||| Proof that addition of exponents is equivalent to multiplcation
||| of the two terms.
export
0 ppow :  Ring a
       => (m,n : Nat)
       -> (x   : a)
       -> pow x (m + n) === pow x m * pow x n
ppow 0     n x = sym multOneLeftNeutral
ppow (S k) n x = Calc $
  |~ x * pow x (plus k n)
  ~~ x * (pow x k * pow x n) ... cong (x*) (ppow k n x)
  ~~ (x * pow x k) * pow x n ... multAssociative


import Decidable.Equality

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

-- the equalities below (i.e (x = y) -> Void ) get constrained
-- to be the same value (i.e (x = x) -> Void )

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

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

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


||| Properties of the reverse function.
module Data.List.Reverse

import Data.Nat
import Data.List
import Data.List.Equalities

%default total

export
reverseOntoAcc : (xs, ys, zs : List a) ->
  reverseOnto (ys ++ zs) xs = (reverseOnto ys xs) ++ zs
reverseOntoAcc [] _ _ = Refl
reverseOntoAcc (x :: xs) (ys) (zs) = reverseOntoAcc xs (x :: ys) zs

||| Serves as a specification for reverseOnto.
export
reverseOntoSpec : (xs, ys : List a) -> reverseOnto xs ys = reverse ys ++ xs
reverseOntoSpec xs ys = reverseOntoAcc ys [] xs

||| The reverse of an empty list is an empty list.  Together with reverseCons,
||| serves as a specification for reverse.
export
reverseNil : reverse [] = []
reverseNil = Refl

||| The reverse of a cons is the reverse of the tail followed by the head.
||| Together with reverseNil serves as a specification for reverse.
export
reverseCons : (x : a) -> (xs : List a) -> reverse (x::xs) = reverse xs `snoc` x
reverseCons x xs = reverseOntoSpec [x] xs

||| Reversing an append is appending reversals backwards.
export
reverseAppend : (xs, ys : List a) ->
  reverse (xs ++ ys) = reverse ys ++ reverse xs
reverseAppend [] ys = sym (appendNilRightNeutral (reverse ys))
reverseAppend (x :: xs) ys =
  rewrite reverseCons x (xs ++ ys) in
    rewrite reverseAppend xs ys in
      rewrite reverseCons x xs in
        sym $ appendAssociative (reverse ys) (reverse xs) [x]

||| A slow recursive definition of reverse.
public export
0 slowReverse : List a -> List a
slowReverse [] = []
slowReverse (x :: xs) = slowReverse xs `snoc` x

||| The iterative and recursive defintions of reverse are the same.
export
reverseEquiv : (xs : List a) -> slowReverse xs = reverse xs
reverseEquiv [] = Refl
reverseEquiv (x :: xs) =
  rewrite reverseEquiv xs in
    rewrite reverseAppend [x] xs in
      Refl

||| Reversing a singleton list is a no-op.
export
reverseSingletonId : (x : a) -> reverse [x] = [x]
reverseSingletonId _ = Refl

||| Reversing a reverse gives the original.
export
reverseReverseId : (xs : List a) -> reverse (reverse xs) = xs
reverseReverseId [] = Refl
reverseReverseId (x :: xs) =
  rewrite reverseCons x xs in
    rewrite reverseAppend (reverse xs) [x] in
      rewrite reverseReverseId xs in
        Refl

||| Reversing onto preserves list length.
export
reverseOntoLength : (xs, acc : List a) ->
  length (reverseOnto acc xs) = length acc + length xs
reverseOntoLength [] acc = rewrite plusZeroRightNeutral (length acc) in Refl
reverseOntoLength (x :: xs) acc =
  rewrite reverseOntoLength xs (x :: acc) in
    plusSuccRightSucc (length acc) (length xs)

||| Reversing preserves list length.
export
reverseLength : (xs : List a) -> length (reverse xs) = length xs
reverseLength xs = reverseOntoLength xs []

||| Equal reversed lists are equal.
export
reverseEqual : (xs, ys : List a) -> reverse xs = reverse ys -> xs = ys
reverseEqual xs ys prf =
  rewrite sym $ reverseReverseId xs in
    rewrite prf in
      reverseReverseId ys


-- Tree.idr
--
-- Demonstates generic data types

module Tree

||| A binary tree
public export
data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

%name Tree tree, tree1

||| Inserts a new element into a binary search tree
export
insert : Ord elem => elem -> Tree elem -> Tree elem
insert x Empty = Node Empty x Empty
insert x (Node left val right) = case compare x val of
                                      LT => Node (insert x left) val right
                                      EQ => Node left val right
                                      GT => Node left val (insert x right)


module RationalSetoid
import Rational
import SignedInt
import Setoid
import SignedSetoid
import NatExtension

%default total
%access public export

rationalReflx : Reflx RationalEq
rationalReflx (MkRat a b) = RationalRefl (signedReflx (a $* (S b)))

rationalSymm : Symm RationalEq
rationalSymm (MkRat a1 b1) (MkRat a2 b2) (RationalRefl rr) = RationalRefl (signedSymm (a1 $* (S b2)) (a2 $* (S b1)) rr)

rationalTrans : Trans RationalEq
rationalTrans (MkRat (SInt p1 n1) b1) (MkRat (SInt p2 n2) b2) (MkRat (SInt p3 n3) b3)
      (RationalRefl (SignedRefl sr12)) (RationalRefl (SignedRefl sr23)) = RationalRefl (SignedRefl sr13)
  where
    _1 : (p1 * S b2) * S b3 + (n2 * S b1) * S b3 = (p2 * S b1) * S b3 + (n1 * S b2) * S b3
    _1 = trans (trans l_tr (cong {f = (* S b3)} sr12)) r_tr
        where
          l_tr : (p1 * S b2) * S b3 + (n2 * S b1) * S b3 = ((p1 * S b2) + (n2 * S b1)) * S b3
          l_tr = sym (multDistributesOverPlusLeft (p1 * S b2) (n2 * S b1) (S b3))

          r_tr : ((p2 * S b1) + (n1 * S b2)) * S b3 = (p2 * S b1) * S b3 + (n1 * S b2) * S b3
          r_tr = multDistributesOverPlusLeft (p2 * S b1) (n1 * S b2) (S b3)

    _2 : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 = (p3 * S b2) * S b1 + (n2 * S b3) * S b1
    _2 = trans (trans l_tr (cong {f = (* S b1)} sr23)) r_tr
      where
        l_tr : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 = ((p2 * S b3) + (n3 * S b2)) * S b1
        l_tr = sym (multDistributesOverPlusLeft (p2 * S b3) (n3 * S b2) (S b1))

        r_tr : ((p3 * S b2) + (n2 * S b3)) * S b1 = (p3 * S b2) * S b1 + (n2 * S b3) * S b1
        r_tr = multDistributesOverPlusLeft (p3 * S b2) (n2 * S b3) (S b1)

    _3 : ((p1 * S b2) * S b3 + (n2 * S b1) * S b3) + ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) =
         ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) + ((p3 * S b2) * S b1 + (n2 * S b3) * S b1)
    _3 = rewrite _1 in rewrite _2 in Refl

    _4 : (p1 * S b2) * S b3 + (n3 * S b2) * S b1 = (n1 * S b2) * S b3 + (p3 * S b2) * S b1
    _4 = rewrite plusCommutative (p1 * S b2 * S b3) (n3 * S b2 * S b1) in _47
      where
        _41 : ((p1 * S b2) * S b3 + (n2 * S b1) * S b3) + ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) =
                   ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) + ((p1 * S b2) * S b3 + (n2 * S b3) * S b1)
        _41 =
            rewrite sym $ multAssociative n2 (S b3) (S b1) in
            rewrite sym $ multAssociative n2 (S b1) (S b3) in
            rewrite sym $ multCommutative (S b3) (S b1) in
            rewrite plusCommutative ((p1 * S b2) * S b3 + n2 * (S (b1 + b3 * S b1))) ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) in
            Refl

        _42 : ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) + (p1 * S b2) * S b3 + (n2 * S b3) * S b1 =
               ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) + (p3 * S b2) * S b1 + (n2 * S b3) * S b1
        _42 =
            rewrite sym $ plusAssociative ((p2 * S b3) * S b1 + (n3 * S b2) * S b1) ((p1 * S b2) * S b3) ((n2 * S b3) * S b1) in
            rewrite sym $ plusAssociative ((p2 * S b1) * S b3 + (n1 * S b2) * S b3) ((p3 * S b2) * S b1) ((n2 * S b3) * S b1) in
            rewrite sym _41 in
            _3

        _43 : (p2 * S b3) * S b1 + (n3 * S b2) * S b1 + (p1 * S b2) * S b3 =
               (p2 * S b1) * S b3 + (n1 * S b2) * S b3 + (p3 * S b2) * S b1
        _43 = plusRightCancel _ _ (n2 * S b3 * S b1) _42

        _44 : (p2 * S b3) * S b1 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
               (p2 * S b1) * S b3 + ((n1 * S b2) * S b3 + (p3 * S b2) * S b1)
        _44 =
            rewrite plusAssociative ((p2 * S b3) * S b1) ((n3 * S b2) * S b1) ((p1 * S b2) * S b3) in
            rewrite plusAssociative ((p2 * S b1) * S b3) ((n1 * S b2) * S b3) ((p3 * S b2) * S b1) in
            _43

        _45 : (p2 * S b1) * S b3 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
                   (p2 * S b3) * S b1 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3)
        _45 =
            rewrite sym $ multAssociative p2 (S b1) (S b3) in
            rewrite multCommutative (S b1) (S b3) in
            rewrite multAssociative p2 (S b3) (S b1) in
            Refl

        _46 : (p2 * S b1) * S b3 + ((n3 * S b2) * S b1 + (p1 * S b2) * S b3) =
               (p2 * S b1) * S b3 + ((n1 * S b2) * S b3 + (p3 * S b2) * S b1)
        _46 = rewrite _45 in _44

        _47 : (n3 * S b2) * S b1 + (p1 * S b2) * S b3 =
               (n1 * S b2) * S b3 + (p3 * S b2) * S b1
        _47 = plusLeftCancel (p2 * S b1 * S b3) _ _ _46

    _5 : S b2 * (p1 * S b3 + n3 * S b1) = S b2 * (n1 * S b3 + p3 * S b1)
    _5 =
        rewrite multDistributesOverPlusRight (S b2) (p1 * S b3) (n3 * S b1) in
        rewrite multDistributesOverPlusRight (S b2) (n1 * S b3) (p3 * S b1) in
        rewrite takeY (S b2) p1 (S b3) in
        rewrite takeY (S b2) n1 (S b3) in
        rewrite takeY (S b2) p3 (S b1) in
        rewrite takeY (S b2) n3 (S b1) in
        _4

    sr13 : p1 * S b3 + n3 * S b1 = p3 * S b1 + n1 * S b3
    sr13 =
        rewrite plusCommutative (p3 * S b1) (n1 * S b3) in
        multLeftCancel _ _ _ _5

RationalSetoid : Setoid
RationalSetoid = MkSetoid Rational RationalEq (EqProof RationalEq rationalReflx rationalSymm rationalTrans)


module UnivalenceFromScratch

-- Based on http://www.cs.bham.ac.uk/~mhe/agda-new/UnivalenceFromScratch.html

data Sigma : (x : Type) -> (y : x -> Type) -> Type where
  Pair : (a : x) -> y a -> Sigma x y

-- We need something like --without-K
data Id : {x : Type} -> x -> x -> Type where
  Refl : (a : x) -> Id a a

J : {x : Type} ->
    (alpha : (a, b : x) -> Id a b -> Type) ->
    ((a : x) -> alpha a a (Refl a)) ->
    (a, b : x) -> (p : Id a b) -> alpha a b p
J alpha f b b (Refl b) = f b

isSingleton : Type -> Type
isSingleton x = Sigma x (\a => (b : x) -> Id a b)

fiber : {x, y : Type} -> (x -> y) -> y -> Type
fiber {x} f b = Sigma x (\a => Id (f a) b)

isEquiv : {x, y : Type} -> (x -> y) -> Type
isEquiv {y} f = (b : y) -> isSingleton (fiber f b)

Eq : Type -> Type -> Type
Eq x y = Sigma (x -> y) (\f => isEquiv f)

singletonType : {x : Type} -> x -> Type
singletonType {x} a = Sigma x (\b => Id b a)

eta : {x : Type} -> (a : x) -> singletonType a
eta a = Pair a (Refl a)

singletonTypesAreSingletons : {x : Type} -> (a : x) -> isSingleton (singletonType a)
singletonTypesAreSingletons = h
  where
    alpha : (b, a : x) -> Id b a -> Type
    alpha b a p = Id (eta a) (Pair b p)
    f : (a : x) -> alpha a a (Refl a)
    f a = Refl (eta a)
    phi : (b, a : x) -> (p : Id b a) -> Id (eta a) (Pair b p)
    phi = J alpha f
    g : (a : x) -> (sigma : singletonType a) -> Id (eta a) sigma
    g a (Pair b p) = phi b a p
    h : (a : x) -> Sigma (singletonType a) (\b => (sigma : singletonType a) -> Id b sigma)
    h a = Pair (eta a) (g a)

id : (x : Type) -> x -> x
id x a = a

idIsEquiv : (x : Type) -> isEquiv (id x)
idIsEquiv x = g
 where
  g : (a : x) -> isSingleton (fiber (id x) a)
  g = singletonTypesAreSingletons

IdToEq : (x, y : Type) -> Id x y -> Eq x y
IdToEq = J alpha f
  where
    alpha : (x, y : Type) -> Id x y -> Type
    alpha x y p = Eq x y
    f : (x : Type) -> alpha x x (Refl x)
    f x = Pair (id x) (idIsEquiv x)

isUnivalent : Type
isUnivalent = (x, y : Type) -> isEquiv (IdToEq x y)


module Data.List.Predicates.Unique

import public Data.List.NotElem

%default total
%access public export

data Unique : (prfSame : a -> a -> Type)
            -> (ns : List a)
            -> Type
  where
    Empty : Unique p Nil
    Extend : (node : a)
          -> (prfNotElem : NotElem p node ns)
          -> (rest : Unique p ns)
          -> Unique p (node :: ns)

nodeIsFoundLater : (contra : NotElem prfSame x xs -> Void)
                -> Unique prfSame (x :: xs)
                -> Void
nodeIsFoundLater contra (Extend x prfNotElem rest) = contra prfNotElem

restNotUnique : (contra : Unique prfSame xs -> Void)
             -> (prfX : NotElem prfSame x xs)
             -> Unique prfSame (x :: xs)
             -> Void
restNotUnique contra prfX (Extend x prfNotElem rest) = contra rest

unique : (decEq : (x,y : a) -> Dec (prfSame x y))
     -> (xs    : List a)
     -> Dec (Unique prfSame xs)
unique decEq [] = Yes Empty
unique decEq (x :: xs) with (notElem decEq x xs)
  unique decEq (x :: xs) | (Yes prfX) with (unique decEq xs)
    unique decEq (x :: xs) | (Yes prfX) | (Yes prfXS) = Yes (Extend x prfX prfXS)
    unique decEq (x :: xs) | (Yes prfX) | (No contra) = No (restNotUnique contra prfX)

  unique decEq (x :: xs) | (No contra) = No (nodeIsFoundLater contra)

toList : {ns : List a} -> Unique prfSame ns -> List a
toList Empty = []
toList (Extend node prfNotElem rest) = node :: toList rest

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


module Progress

-- Progress theorem for the 'Step' relation.

import Step
import Subst
import Term

%default total
%access export

-------------------------------------
-- Begin: PROGRESS (AND PRESERVATION)

-- Function 'progress' proves the usual progress lemma.
--
-- Progress: a closed, well-typed term is either a value
--           or it can take a step in the reduction relation.
--
-- Preservation: after reducing a term of type 't' by one
--               step, the resulting term is again of type 't'.
--
--   ***  Note that preservation is already built into     ***
--   ***  the relation 'Step' as defined in module "Step". ***
--
progress : (e : Term [] t) -> Either (Value e) (e' : Term [] t ** (Step e e'))
-- Expressions that are variables cannot occur in an empty context:
-- (In other words, variables are not closed expressions.)
progress (TVar _) impossible
-- Abstractions are values already:
progress (TAbs _) = Left VAbs
-- Applications can reduce in three different ways, the most
-- interesting of which occurs when both arguments of 'App'
-- are values already: in this case, the function 'subst'
-- is required:
progress (TApp e1 e2) = case progress e1 of
  Right (e' ** st) => Right (TApp e' e2 ** StApp1 st)
  Left  v1         =>
    case progress e2 of
         Right (e' ** st) => Right (TApp e1 e' ** StApp2 v1 st)
         Left  v2         => case e1 of
                                  TAbs f => let e'' = subst e2 First f
                                            in Right (e'' ** StBeta v2)
-- When the fix-point operator is applied to a value,
-- that value is necessarily an abstraction; hence
-- the function 'subst' is used in reducing 'Fix _':
progress (TFix e) = case progress e of
  Right (e' ** st) => Right (TFix e' ** StFix st)
  Left v           =>
    case e of
         TAbs f => let e'' = subst (TFix (TAbs f)) First f
                   in Right (e'' ** StFixBeta)
-- The constant 'Zero' is a value already:
progress TZero = Left VZero
--
progress (TSucc e) = case progress e of
  Right (e' ** st) => Right (TSucc e' ** StSucc st)
  Left  v          => Left (VSucc v)
progress (TPred e) = case progress e of
  Right (e' ** st) => Right (TPred e' ** StPred st)
  Left v           =>
    case e of
         TZero    => Right (TZero ** StPredZero)
         TSucc e' => case v of
                          VAbs     impossible
                          VZero    impossible
                          VSucc v' => Right (e' ** StPredSucc v')
--
progress (TIfz e1 e2 e3) = case progress e1 of
  Right (e' ** st) => Right $ (TIfz e' e2 e3 ** StIfz st)
  Left v           => case v of
                           VAbs     impossible
                           VZero    => Right (e2 ** StIfzZero)
                           VSucc v' => Right (e3 ** StIfzSucc v')

-- End: PROGRESS (AND PRESERVATION)
-----------------------------------

-------------------------------
-- Begin: VALUE <=> IRREDUCIBLE

-- Establish that values cannot be further reduced under 'Step'.
valueIrreducible : (e : Term [] t) ->
                   Value e ->
                   {e' : Term [] t} -> Step e e' -> Void
valueIrreducible TZero     VZero     _           impossible
valueIrreducible (TSucc n) (VSucc v) (StSucc st) = valueIrreducible n v st
valueIrreducible (TAbs _)  VAbs      _           impossible

-- Establish that irreducible expressions (under 'Step') are values:
irreducibleValue : (e : Term [] t) ->
                   ({e' : Term [] t} -> Step e e' -> Void) ->
                   Value e
irreducibleValue e notStep = case progress e of
  Right (_ ** st) => absurd $ notStep st
  Left v          => v

coTransStepValueIrreducible : CoTransStep e1 e2 -> Value e1 -> e1 = e2
coTransStepValueIrreducible (CoTStRefl e1)       v = Refl
coTransStepValueIrreducible (CoTStTrans st ctst) v = absurd $ valueIrreducible _ v st

-- End: VALUE <=> IRREDUCIBLE
-----------------------------


module Instances.TrustInteger

import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Instances.Notation

%default total
%access public export

data IntegerLeq : Integer -> Integer -> Type where
  CheckIntegerLeq : So (intToBool (prim__slteBigInt a b)) -> IntegerLeq a b

soIntegerLeq : IntegerLeq a b -> So (intToBool (prim__slteBigInt a b))
soIntegerLeq (CheckIntegerLeq so) = so

decideLeq : (a,b : Integer) -> Dec (IntegerLeq a b)
decideLeq a b = case isItSo (intToBool (prim__slteBigInt a b)) of
  Yes oh => Yes (CheckIntegerLeq oh)
  No contra => No (contra . soIntegerLeq)

implementation Ringops Integer where Ng = negate

implementation Decidable [Integer, Integer] IntegerLeq where
  decide = decideLeq

postulate integerDiscreteOrderedRing :
  specifyDiscreteOrderedRing {leq = IntegerLeq}

integerDiscreteOrderedGroup : specifyDiscreteOrderedGroup {leq = IntegerLeq}
integerDiscreteOrderedGroup = discreteOrderedGroup integerDiscreteOrderedRing

integerPartiallyOrderedGroup : specifyPartiallyOrderedGroup {leq = IntegerLeq}
integerPartiallyOrderedGroup = partiallyOrderedGroup integerDiscreteOrderedGroup


module Main

import Data.String
import Data.List

maxByThird : Ord c => List (a, b, c) -> (a, b, c)
maxByThird = foldr1 (\(ax, ay, av), (x, y, v) => if v > av then (x, y, v) else (ax, ay, av))

cell : Integer -> Integer -> Integer -> Integer
cell x y serial = (mod (div ((((x + 10) * y) + serial) * (x + 10)) 100) 10) - 5

grid : Integer -> List (List Integer)
grid serial = [[cell x y serial | y <- [1..300]] | x <- [1..300]]

squareCell : Integer -> Integer -> Integer -> List (List Integer) -> Integer
squareCell size x y g = if (x + size - 1) > 300 || (y + size - 1) > 300 then 0 else
    sum
    . map (
        sum
        . List.take (fromIntegerNat size)
        . List.drop (fromIntegerNat (y - 1))
        )
    . List.take (fromIntegerNat size)
    . List.drop (fromIntegerNat (x - 1))
    $ g

square : Integer -> List (List Integer) -> (Integer, Integer, Integer)
square size g = maxByThird [(x, y, squareCell size x y g) | x <- [1..300 - (size - 2)], y <- [1..300 - (size - 2)]]

part1 : List (List Integer) -> (Integer, Integer, Integer)
part1 = square 3

part2 : List (List Integer) -> (Integer, Integer, Integer)
part2 g = maxByThird [square size g | size <- [1..10]]

main : IO()
main = do
    (Right str) <- readFile "11.in"
    let (Just serial) = String.parseInteger str
    let g = grid serial
    putStrLn "(x, (y, power)"
    printLn $ square 1 g
    printLn $ square 2 g
    putStrLn "Solution for part 1:"
    printLn $ square 3 g
    printLn $ square 4 g
    printLn $ square 5 g
    printLn $ square 6 g
    printLn $ square 7 g
    printLn $ square 8 g
    printLn $ square 9 g
    printLn $ square 10 g
    printLn $ square 11 g
    printLn $ square 12 g
    printLn $ square 13 g
    printLn $ square 14 g
    printLn $ square 15 g
    printLn $ square 16 g
    printLn $ square 17 g
    printLn $ square 18 g
    printLn $ square 19 g
    printLn $ square 20 g
    printLn $ square 21 g
    printLn $ square 22 g
    printLn $ square 23 g
    printLn $ square 24 g
    printLn $ square 25 g
    printLn $ square 26 g
    printLn $ square 27 g
    printLn $ square 28 g
    printLn $ square 29 g

    -- I do not want to optimize this right now, so... it works so it's good.
    -- You just take the biggest power, seems to be between 13 and 20 all the time.
    -- Starts at one, the size is the line number, not counting the info lines.

-- Solution part 1: 235,87
-- Solution part 2: 234,272,18


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

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

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

descibeListEnd : Show a => List a -> String
descibeListEnd xs = describeHelper xs (listLast xs)

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

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


import Aoc
import Data.Nat
import Data.Strings

Point : Type
Point = (Integer, Integer)

||| Add two points.
(+~) : Point -> Point -> Point
(+~) (x,y) (x',y') = (x+x',y+y')
infixl 5 +~

||| Scale a point.
(*~) : Integer -> Point -> Point
(*~) n (x,y) = (n*x,n*y)
infixl 6 *~

||| Turn a vector 90° to the left. (+x is >, +y is ^)
turnLeft : Point -> Point
turnLeft (x,y) = (-y,x)

||| Turn a vector 90° to the right. (+x is >, +y is ^)
turnRight : Point -> Point
turnRight (x,y) = (y,-x)

manhattanNorm : Point -> Integer
manhattanNorm (x,y) = abs x + abs y

record Ship where
  constructor MkShip
  position : Point
  direction : Point

data Instruction
  = North Integer
  | South Integer
  | East Integer
  | West Integer
  | Left90 Nat
  | Right90 Nat
  | Forward Integer

||| Move a ship's position.
move : Point -> Ship -> Ship
move d s = record { position $= (+~ d) } s

||| Move a ship's waypoint (direction vector).
moveWaypoint : Point -> Ship -> Ship
moveWaypoint d s = record { direction $= (+~ d) } s

||| Follow an instruction, * style.
step1 : Ship -> Instruction -> Ship
step1 s (North n) = move (0, n) s
step1 s (South n) = move (0, -n) s
step1 s (East n) = move (n, 0) s
step1 s (West n) = move (-n, 0) s
step1 s (Left90 n) = record { direction $= times n turnLeft } s
step1 s (Right90 n) = record { direction $= times n turnRight } s
step1 s (Forward n) = move (n *~ s.direction) s

||| Follow an instruction, ** style.
step2 : Ship -> Instruction -> Ship
step2 s (North n) = moveWaypoint (0, n) s
step2 s (South n) = moveWaypoint (0, -n) s
step2 s (East n) = moveWaypoint (n, 0) s
step2 s (West n) = moveWaypoint (-n, 0) s
step2 s (Left90 n) = record { direction $= times n turnLeft } s
step2 s (Right90 n) = record { direction $= times n turnRight } s
step2 s (Forward n) = move (n *~ s.direction) s

||| Try to divide a natural number by 90.
div90 : Nat -> Maybe Nat
div90 n =
  case divmodNatNZ n 90 SIsNotZ of
    (k, 0) => Just k
    _ => Nothing

||| Try to parse an instruciton.
parseInstruction : String -> Maybe Instruction
parseInstruction s =
  case break isDigit s of
    ("N", n) => North <$> parsePositive n
    ("S", n) => South <$> parsePositive n
    ("E", n) => East <$> parsePositive n
    ("W", n) => West <$> parsePositive n
    ("L", n) => Left90 <$> (parsePositive n >>= div90)
    ("R", n) => Right90 <$> (parsePositive n >>= div90)
    ("F", n) => Forward <$> parsePositive n
    _ => Nothing

main : IO ()
main = do
  xs <- parseLines parseInstruction
  let ship1 = foldl step1 (MkShip (0, 0) (1, 0)) xs
  putStr "*   "; printLn (manhattanNorm ship1.position)
  let ship2 = foldl step2 (MkShip (0, 0) (10, 1)) xs
  putStr "**  "; printLn (manhattanNorm ship2.position)


module Data.AVL.Core.Quantifiers

import public Data.Tree
import public Data.AVL.Core
import public Data.AVL.Core.API

%default total
%access export

namespace AVL
  namespace Keys

    public export
    data HasKey : (key : typeKey)
               -> (tree : AVLTree h typeKey typeValue)
               -> Type
      where
        IsKey : (prf : IsKeyIn key (Subset.getWitness avl))
             -> HasKey key avl

    keyNotInAVlTree : (contra : IsKeyIn key tree -> Void)
                   -> HasKey key (Element tree prf)
                   -> Void
    keyNotInAVlTree contra (IsKey x) = contra x

    isKey : DecEq typeKey
         => (key : typeKey)
         -> (tree : AVLTree h typeKey typeValue)
         -> Dec (HasKey key tree)
    isKey key (Element tree prf) with (isKey key tree)
      isKey key (Element tree prf) | (Yes x) = Yes (IsKey x)
      isKey key (Element tree prf) | (No contra) = No (keyNotInAVlTree contra)

    public export
    data All : (predicate : typeKey -> Type)
            -> (tree : AVLTree h typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.Keys.All p (Subset.getWitness avl))
               -> All p avl

  namespace Values

    public export
    data HasValue : (value : typeValue)
                 -> (tree : AVLTree h typeKey typeValue)
                 -> Type
      where
        IsValue : (prf : IsValueIn value (Subset.getWitness avl))
               -> HasValue value avl

    valueNotInAVLTree : (contra : IsValueIn value tree -> Void)
                     -> HasValue value (Element tree prf)
                     -> Void
    valueNotInAVLTree contra (IsValue prf) = contra prf

    isValue : DecEq typeValue
           => (value : typeValue)
           -> (tree : AVLTree h typeKey typeValue)
           -> Dec (HasValue value tree)
    isValue value (Element tree prf) with (isValue value tree)
      isValue value (Element tree prf) | (Yes x) = Yes (IsValue x)
      isValue value (Element tree prf) | (No contra) = No (valueNotInAVLTree contra)

    public export
    data All : (predicate : typeValue -> Type)
            -> (tree : AVLTree h typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.Values.All p (Subset.getWitness avl))
               -> AVL.Values.All p avl

  namespace KVPairs

    public export
    data All : (predicate : typeKey -> typeValue -> Type)
            -> (tree : AVLTree k typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.KVPairs.All p (Subset.getWitness avl))
                -> All p avl


module Sub01Apply18x3

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(6x+1) --B[1,-2]--> 3x
export
apply18x3 : (Not . P) (S (plus (plus (plus k k) (plus k k)) (plus k k)))
  -> (m : Nat **
      (LTE (S m) (S (plus (plus (plus k k) (plus k k)) (plus k k))), (Not . P) m))
apply18x3 {k} col = (k ** (lte18x3 k, b18x3To3x k col)) where
  lte18x3 : (k:Nat) -> LTE (S k) (S (plus (plus (plus k k) (plus k k)) (plus k k)))
  lte18x3 Z = LTESucc LTEZero
  lte18x3 (S k) = rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (plus k k))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) (lte18x3 k)


module BigStep

-- Relation 'BigStep' for fully reducing terms
-- in the simply-typed lambda calculus to values.

import Term
import Subst

%default total
%access public export

-----------------------------------------------------------------------
-- Begin: BIG-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS

-- The relation 'BigStep' defines evaluation of terms in the lambda
-- calculus following big-step semantics.
--
-- Big-step semantics fully evaluates terms to values.
-- (A proof of this statement appears below.)
data BigStep : Term [] t -> (y: Term [] t) -> Type where
  BStValue    : (v : Value e) -> BigStep e e
  --
  BStApp      : BigStep e1 (TAbs e1') ->
                BigStep e2 e2' ->
                BigStep (subst e2' First e1') e ->
                BigStep (TApp e1 e2) e
  --
  BStFix      : BigStep e (TAbs e') ->
                BigStep (subst (TFix (TAbs e')) First e') e'' ->
                BigStep (TFix e) e''
  --
  BStSucc     : BigStep e e' ->
                BigStep (TSucc e) (TSucc e')
  --
  BStPredZero : BigStep e TZero ->
                BigStep (TPred e) TZero
  --
  BStPredSucc : BigStep e (TSucc e') ->
                BigStep (TPred e) e'
  --
  BStIfzZero  : BigStep e1 TZero ->
                BigStep e2 e ->
                BigStep (TIfz e1 e2 _) e
  --
  BStIfzSucc  : BigStep e1 (TSucc _) ->
                BigStep e3 e ->
                BigStep (TIfz e1 _ e3) e

bigStepFst : {e : Term [] t} -> BigStep e _ -> Term [] t
bigStepFst {e = e} _ = e

bigStepSnd : {e : Term [] t} -> BigStep _ e -> Term [] t
bigStepSnd {e = e} _ = e

bigStepValue : BigStep _ e -> Value e
bigStepValue (BStValue v)     = v
bigStepValue (BStApp _ _ z)   = bigStepValue z
bigStepValue (BStFix _ z)     = bigStepValue z
bigStepValue (BStSucc z)      = VSucc (bigStepValue z)
bigStepValue (BStPredZero _)  = VZero
bigStepValue (BStPredSucc z)  = case bigStepValue z of
                                    VZero impossible
                                    VSucc v => v
bigStepValue (BStIfzZero _ z) = bigStepValue z
bigStepValue (BStIfzSucc _ z) = bigStepValue z

bigStepValueIrreducible : BigStep e1 e2 -> Value e1 -> e1 = e2
bigStepValueIrreducible (BStValue VZero) VZero   = Refl
bigStepValueIrreducible (BStValue v1) (VSucc v2) = Refl
bigStepValueIrreducible (BStSucc bst) (VSucc v)  =
  cong $ bigStepValueIrreducible bst v
bigStepValueIrreducible (BStValue v)  VAbs       = Refl

bigStepTransitive : BigStep e1 e2 -> BigStep e2 e3 -> BigStep e1 e3
bigStepTransitive (BStValue v) bst = bst
bigStepTransitive (BStApp x w t) y = BStApp x w $ bigStepTransitive t y
bigStepTransitive (BStFix x w) y = BStFix x $ bigStepTransitive w y
bigStepTransitive (BStSucc x) (BStValue v) = BStSucc x
bigStepTransitive (BStSucc x) (BStSucc y)  = BStSucc $ bigStepTransitive x y
bigStepTransitive (BStPredZero x) (BStValue v) = BStPredZero x
bigStepTransitive (BStPredSucc x) y = let bst1 = BStSucc y
                                          bst2 = bigStepTransitive x bst1
                                      in BStPredSucc bst2
bigStepTransitive (BStIfzZero w s) y = BStIfzZero w (bigStepTransitive s y)
bigStepTransitive (BStIfzSucc w s) y = BStIfzSucc w (bigStepTransitive s y)

-- End: BIG-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------

-------------------------------------------------------
-- Begin: CO-INDUCTIVE RELATION FOR BIG-STEP EVALUATION

codata CoBigStep : Term [] t -> (y: Term [] t) -> Type where
  CoBStValue    : (v : Value e) -> CoBigStep e e
  --
  CoBStApp      : CoBigStep e1 (TAbs e1') ->
                  CoBigStep e2 e2' ->
                  CoBigStep (subst e2' First e1') e ->
                  CoBigStep (TApp e1 e2) e
  --
  CoBStFix      : CoBigStep e (TAbs e') ->
                  CoBigStep (subst (TFix (TAbs e')) First e') e'' ->
                  CoBigStep (TFix e) e''
  --
  CoBStSucc     : CoBigStep e e' ->
                  CoBigStep (TSucc e) (TSucc e')
  --
  CoBStPredZero : CoBigStep e TZero ->
                  CoBigStep (TPred e) TZero
  --
  CoBStPredSucc : CoBigStep e (TSucc e') ->
                  CoBigStep (TPred e) e'
  --
  CoBStIfzZero  : CoBigStep e1 TZero ->
                  CoBigStep e2 e ->
                  CoBigStep (TIfz e1 e2 _) e
  --
  CoBStIfzSucc  : CoBigStep e1 (TSucc _) ->
                  CoBigStep e3 e ->
                  CoBigStep (TIfz e1 _ e3) e

coBigStepValueIrreducible : CoBigStep e1 e2 -> Value e1 -> e1 = e2
coBigStepValueIrreducible (CoBStValue VZero) VZero      = Refl
coBigStepValueIrreducible (CoBStValue v1)    (VSucc v2) = Refl
coBigStepValueIrreducible (CoBStSucc cbst)   (VSucc v)  =
  cong $ coBigStepValueIrreducible cbst v
coBigStepValueIrreducible (CoBStValue v)     VAbs       = Refl

coBigStepTransitive : CoBigStep e1 e2 -> CoBigStep e2 e3 -> CoBigStep e1 e3
coBigStepTransitive (CoBStValue v) y = y
coBigStepTransitive (CoBStApp x z w) y = CoBStApp x z $ coBigStepTransitive w y
coBigStepTransitive (CoBStFix x z) y = CoBStFix x $ coBigStepTransitive z y
coBigStepTransitive (CoBStSucc x) (CoBStValue v) = CoBStSucc x
coBigStepTransitive (CoBStSucc x) (CoBStSucc y) = CoBStSucc $ coBigStepTransitive x y
coBigStepTransitive (CoBStPredZero x) (CoBStValue v) = CoBStPredZero x
coBigStepTransitive (CoBStPredSucc x) y = let cbst1 = CoBStSucc y
                                          in CoBStPredSucc $ coBigStepTransitive x cbst1
coBigStepTransitive (CoBStIfzZero z w) y = CoBStIfzZero z $ coBigStepTransitive w y
coBigStepTransitive (CoBStIfzSucc w s) y = CoBStIfzSucc w $ coBigStepTransitive s y

bigStepToCoBigStep : BigStep e1 e2 -> CoBigStep e1 e2
bigStepToCoBigStep (BStValue v) = CoBStValue v
bigStepToCoBigStep (BStApp bst1 bst2 bst3) = CoBStApp (bigStepToCoBigStep bst1)
                                                      (bigStepToCoBigStep bst2)
                                                      (bigStepToCoBigStep bst3)
bigStepToCoBigStep (BStFix bst1 bst2) = CoBStFix (bigStepToCoBigStep bst1)
                                                 (bigStepToCoBigStep bst2)
bigStepToCoBigStep (BStSucc bst) = CoBStSucc $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStPredZero bst) = CoBStPredZero $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStPredSucc bst) = CoBStPredSucc $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStIfzZero bst1 bst2) = CoBStIfzZero (bigStepToCoBigStep bst1)
                                                         (bigStepToCoBigStep bst2)
bigStepToCoBigStep (BStIfzSucc bst1 bst2) = CoBStIfzSucc (bigStepToCoBigStep bst1)
                                                         (bigStepToCoBigStep bst2)

-- End: CO-INDUCTIVE RELATION FOR BIG-STEP EVALUATION
-----------------------------------------------------


import Syntax.PreorderReasoning

-------- some notation ----------
infixr 6 .+.,:+:
infixr 7 .*.,:*:

interface Additive a where
  constructor MkAdditive
  (.+.) : a -> a -> a
  O   : a

interface Additive2 a where
  constructor MkAdditive2
  (:+:) : a -> a -> a
  O2   : a

interface Multiplicative a where
  constructor MkMultiplicative
  (.*.) : a -> a -> a
  I     : a

record MonoidOver U where
  constructor WithStruct
  Unit    : U
  Mult    : U -> U -> U
  lftUnit : (x : U) -> Unit `Mult` x    = x
  rgtUnit : (x : U) -> x    `Mult` Unit = x
  assoc   : (x,y,z : U)
                    -> x `Mult` (y `Mult` z) = (x `Mult` y) `Mult` z

record Monoid where
  constructor MkMonoid
  U : Type
  Struct : MonoidOver U

AdditiveStruct : (m : MonoidOver a) -> Additive a
AdditiveStruct m = MkAdditive (Mult $ m)
                              (Unit $ m)
AdditiveStruct2 : (m : MonoidOver a) -> Additive2 a
AdditiveStruct2 m = MkAdditive2 (Mult $ m)
                                (Unit $ m)
AdditiveStructs : (ma : MonoidOver a) -> (mb : MonoidOver b)
              -> (Additive a, Additive2 b)
AdditiveStructs ma mb = (AdditiveStruct ma, AdditiveStruct2 mb)

getAdditive : (m : Monoid) -> Additive (U m)
getAdditive m = AdditiveStruct (Struct m)

MultiplicativeStruct : (m : Monoid) -> Multiplicative (U m)
MultiplicativeStruct m = MkMultiplicative (Mult $ Struct m)
                                          (Unit $ Struct m)
-----------------------------------------------------

0 Commutative : MonoidOver a -> Type
Commutative m = (x,y : a) -> let _ = AdditiveStruct m in
                x .+. y = y .+. x

0 Commute : (Additive a, Additive2 a) => Type
Commute =
          (x11,x12,x21,x22 : a) ->
          ((x11 :+: x12) .+. (x21 :+: x22))
          =
          ((x11 .+. x21) :+: (x12 .+. x22))

product : (ma, mb : Monoid) -> Monoid
product ma mb =
  let
      %hint aStruct : Additive (U ma)
      aStruct = getAdditive ma
      %hint bStruct : Additive (U mb)
      bStruct = getAdditive mb

  in MkMonoid (U ma, U mb) $ WithStruct
     (O, O)
     (\(x1,y1), (x2, y2)  => (x1 .+. x2, y1 .+. y2))
     (\(x,y) => rewrite lftUnit (Struct ma) x in
                rewrite lftUnit (Struct mb) y in
                Refl)
     (\(x,y) => rewrite rgtUnit (Struct ma) x in
                rewrite rgtUnit (Struct mb) y in
                Refl)
     (\(x1,y1),(x2,y2),(x3,y3) =>
                rewrite assoc (Struct ma) x1 x2 x3 in
                rewrite assoc (Struct mb) y1 y2 y3 in
                Refl)

EckmannHilton : forall a . (ma,mb : MonoidOver a)
             -> let ops = AdditiveStructs ma mb in
                Commute @{ops}
             -> (Commutative ma, (x,y : a) -> x .+. y = x :+: y)
EckmannHilton ma mb prf =
  let %hint first : Additive a
      first = AdditiveStruct ma
      %hint second : Additive2 a
      second = AdditiveStruct2 mb in
  let SameUnits : (the a O === O2)
      SameUnits = Calc $
        |~ O
        ~~  O         .+.         O  ...(sym $ lftUnit ma O)
        ~~ (O :+: O2) .+. (O2 :+: O) ...(sym $ cong2 (.+.)
                                             (rgtUnit mb O)
                                             (lftUnit mb O))
        ~~ (O .+. O2) :+: (O2 .+. O) ...(prf O O2 O2 O)
        ~~        O2  :+:  O2        ...(cong2 (:+:)
                                             (lftUnit ma O2)
                                             (rgtUnit ma O2))
        ~~ O2                        ...(lftUnit mb O2)

      SameMults : (x,y : a) -> (x .+. y) === (x :+: y)
      SameMults x y = Calc $
        |~ x .+. y
        ~~ (x :+: O2) .+. (O2 :+: y) ...(sym $ cong2 (.+.)
                                             (rgtUnit mb x)
                                             (lftUnit mb y))
        ~~ (x .+. O2) :+: (O2 .+. y) ...(prf x O2 O2 y)
        ~~ (x .+. O ) :+: (O  .+. y) ...(cong (\u =>
                                              (x .+. u) :+: (u .+. y))
                                              (sym SameUnits))
        ~~ x :+: y                   ...(cong2 (:+:)
                                              (rgtUnit ma x)
                                              (lftUnit ma y))

      Commutativity : Commutative ma
      Commutativity x y = Calc $
        |~ x .+. y
        ~~ (O2 :+: x) .+. (y :+: O2) ...(sym $ cong2 (.+.)
                                             (lftUnit mb x)
                                             (rgtUnit mb y))
        ~~ (O2 .+. y) :+: (x .+. O2) ...(prf O2 x y O2)
        ~~ (O  .+. y) :+: (x .+. O ) ...(cong (\u =>
                                              (u .+. y) :+: (x .+. u))
                                              (sym SameUnits))
        ~~ y :+: x                   ...(cong2 (:+:)
                                              (lftUnit ma y)
                                              (rgtUnit ma x))
        ~~ y .+. x                   ...(sym $ SameMults y x)
  in (Commutativity, SameMults)