-- ----------------------------------------------------------- [ Chapter10.idr ]
-- Module      : Exercises.Chapter10
-- Description : Solutions to the Chapter 10 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.Chapter10

import Data.List.Views
import Data.Nat.Views
import Data.Vect
import Data.Vect.Views
import Test

%access  export
%default total

---------------------------------------------------------- [ Exercise 10.1.6.1 ]

public export
data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN _ [] = Fewer
takeN Z _  = Exact []
takeN (S Z) (x :: xs) = Exact [x]
takeN (S k) (x :: xs) with (takeN k xs)
  takeN (S k) (x :: xs) | Fewer = Fewer
  takeN (S k) (x :: (n_xs ++ rest)) | (Exact n_xs) = Exact (x :: n_xs)

-- partial
groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN Z _ = [[]]           -- Provide a sensible base case.
groupByN n xs with (takeN n xs)
 groupByN n  xs            | Fewer      = [xs]
 -- HACK: Assert to the totality checker that groupByN will always terminate.
 groupByN n (n_xs ++ rest) | Exact n_xs = n_xs :: assert_total (groupByN n rest)
 -- groupByN n (n_xs ++ rest) | Exact n_xs = n_xs :: groupByN n rest

---------------------------------------------------------- [ Exercise 10.1.6.2 ]

partial
halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = ([],xs)
  halves (n_xs ++ rest) | (Exact n_xs) {rest} = (n_xs,rest)

---------------------------------------------------------- [ Exercise 10.2.5.1 ]

{- NOTE: Here's isSuffix for reference. It's quite similar to equalSuffix.
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
  isSuffix [] input2 | Empty = True
  isSuffix (xs ++ [x]) input2 | (Snoc rec) with (snocList input2)
    isSuffix (xs ++ [x]) [] | (Snoc rec) | Empty = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      x == y && isSuffix xs ys | xsrec | ysrec
-}

-- FIXME: I don't love this. It would be great to accumulate a SnocList then
-- convert it to a list at the end, though maybe that's no different from
-- accumulating a singly linked list and then reversing it.
equalSuffixHelp : Eq a => (acc, input1, input2 : List a) -> List a
equalSuffixHelp acc input1 input2 with (snocList input1)
  equalSuffixHelp acc [] input2 | Empty = []
  equalSuffixHelp acc (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    equalSuffixHelp acc (xs ++ [x]) [] | (Snoc xsrec) | Empty = []
    equalSuffixHelp acc (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      if x /= y then [] else x :: equalSuffixHelp acc xs ys | xsrec | ysrec

equalSuffix : Eq a => (input1, input2 : List a) -> List a
equalSuffix input1 input2 = reverse $ equalSuffixHelp [] input1 input2

---------------------------------------------------------- [ Exercise 10.2.5.2 ]

mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort []                | SplitRecNil = []
  mergeSort [x]               | SplitRecOne = [x]
  mergeSort (lefts ++ rights) | (SplitRecPair lrec rrec) =
    merge (mergeSort lefts  | lrec)
          (mergeSort rights | rrec)

---------------------------------------------------------- [ Exercise 10.2.5.3 ]

-- FIXME: This is ineffecient due to the string appending, at least.
toBinary : (n : Nat) -> String
toBinary n with (halfRec n)
  toBinary  Z          |  HalfRecZ         = ""
  toBinary (x + x)     | (HalfRecEven rec) = (toBinary x | rec) ++ "0"
  toBinary (S (x + x)) | (HalfRecOdd  rec) = (toBinary x | rec) ++ "1"

---------------------------------------------------------- [ Exercise 10.2.5.4 ]

palindrome : Eq a => (xs : List a) -> Bool
palindrome xs with (vList xs)
  palindrome []  | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec) = x == y && palindrome ys | rec

---------------------------------------------------------------------- [ Tests ]

-- partial
testGroupByN : IO ()
testGroupByN = assertEq [[1,2,3],[4,5,6],[7,8,9],[10]] $
                        the (List (List Integer)) (groupByN 3 [1..10])

partial
testHalves10 : IO ()
testHalves10 = assertEq ([1..5], [6..10]) $ halves [1..10]

partial
testHalves1 : IO ()
testHalves1 = assertEq ([], [1]) $ the (List Integer, List Integer) (halves [1])

testEqualSuffix1 : IO ()
testEqualSuffix1 = assertEq (the (List Integer) [4,5])
                            (equalSuffix [1,2,4,5] [1..5])

testEqualSuffix2 : IO ()
testEqualSuffix2 = assertEq [] $ equalSuffix [1,2,4,5,6] [1..5]

testEqualSuffix3 : IO ()
testEqualSuffix3 = assertEq (the (List Integer) [4,5,6])
                            (equalSuffix [1,2,4,5,6] [1..6])

testMergeSort1 : IO ()
testMergeSort1 = assertEq (fromList [1,2,3]) (mergeSort [3,2,1])

testMergeSort2 : IO ()
testMergeSort2 = assertEq (fromList [1..9]) (mergeSort [5,1,4,3,2,6,8,7,9])

testToBinary42 : IO ()
testToBinary42 = assertEq "101010" $ toBinary 42

testToBinary94 : IO ()
testToBinary94 = assertEq "1011110" $ toBinary 94

testToBinaryExercism : IO ()
testToBinaryExercism =
  assertEq (the (List String) ["1", "10", "11", "100", "1001", "11010"])
           (map toBinary [1,2,3,4,9,26])

testPalindrome1 : IO ()
testPalindrome1 = assertEq True $ palindrome (unpack "abccba")

testPalindrome2 : IO ()
testPalindrome2 = assertEq True $ palindrome (unpack "abcba")

testPalindrome3 : IO ()
testPalindrome3 = assertEq False $ palindrome (unpack "abcb")

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


module Sub06Apply36x9

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(12x+3) --E[2,-4]--> 3x
export
apply36x9 : (Not . P) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l))))))
  -> (m : Nat ** (LTE (S m) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l)))))), (Not . P) m))
apply36x9 {l} col = (l ** (lte36x9 l, e36x9To3x l col)) where
  lte36x9 : (l:Nat) -> LTE (S l) (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l))))))
  lte36x9 Z = (lteSuccRight . lteSuccRight . LTESucc) LTEZero
  lte36x9 (S l) = let lemma = lte36x9 l in
    rewrite (sym (plusSuccRightSucc l l)) in
    rewrite (sym (plusSuccRightSucc (plus l l) (S (plus l l)))) in
    rewrite (sym (plusSuccRightSucc (plus l l) (plus l l))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (S (S (plus (plus l l) (plus l l))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (S (plus (plus l l) (plus l l)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (S (plus (plus l l) (plus l l))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus l l) (plus l l))  (plus (plus l l) (plus l l)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (S (S (plus (plus l l) (plus l l))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (S (plus (plus l l) (plus l l)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (S (plus (plus l l) (plus l l))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))  (plus (plus l l) (plus l l)))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) lemma


= Rel : Properties of Relations

> module Rel
>

\todo[inline]{Add hyperlinks}

This short (and optional) chapter develops some basic definitions and a few
theorems about binary relations in Idris. The key definitions are repeated where
they are actually used (in the `Smallstep` chapter), so readers who are already
comfortable with these ideas can safely skim or skip this chapter. However,
relations are also a good source of exercises for developing facility with
Idris's basic reasoning facilities, so it may be useful to look at this material
just after the `IndProp` chapter.

> import Logic
> import IndProp
>

A binary _relation_ on a set \idr{t} is a family of propositions parameterized
by two elements of \idr{t} — i.e., a proposition about pairs of elements of
\idr{t}.

> Relation : Type -> Type
> Relation t = t -> t -> Type

\todo[inline]{Edit, there's n-relation \idr{Data.Rel} in \idr{contrib}, but no
\idr{Relation}}

Confusingly, the Idris standard library hijacks the generic term "relation" for
this specific instance of the idea. To maintain consistency with the library, we
will do the same. So, henceforth the Idris identifier `relation` will always
refer to a binary relation between some set and itself, whereas the English word
"relation" can refer either to the specific Idris concept or the more general
concept of a relation between any number of possibly different sets. The context
of the discussion should always make clear which is meant.

\todo[inline]{There's a similar concept called \idr{LTE} in \idr{Prelude.Nat},
but it's defined by induction from zero}

An example relation on \idr{Nat} is \idr{Le}, the less-than-or-equal-to
relation, which we usually write \idr{n1 <= n2}.

```idris
λΠ> the (Relation Nat) Le
Le : Nat -> Nat -> Type
```

\todo[inline]{Edit to show it (probably) doesn't matter in Idris}

(Why did we write it this way instead of starting with \idr{data Le : Relation
Nat ...}? Because we wanted to put the first \idr{Nat} to the left of the
\idr{:}, which makes Idris generate a somewhat nicer induction principle for
reasoning about \idr{<='}.)

== Basic Properties

As anyone knows who has taken an undergraduate discrete math course, there is a
lot to be said about relations in general, including ways of classifying
relations (as reflexive, transitive, etc.), theorems that can be proved
generically about certain sorts of relations, constructions that build one
relation from another, etc. For example...

=== Partial Functions

A relation \idr{r} on a set \idr{t} is a _partial function_ if, for every
\idr{x}, there is at most one \idr{y} such that \idr{r x y} — i.e., \idr{r x y1}
and \idr{r x y2} together imply \idr{y1 = y2}.

> Partial_function : (r : Relation t) -> Type
> Partial_function {t} r = (x, y1, y2 : t) -> r x y1 -> r x y2 -> y1 = y2

\todo[inline]{"Earlier" = in \idr{IndProp}, add hyperlink?}

For example, the \idr{Next_nat} relation defined earlier is a partial function.

```idris
λΠ> the (Relation Nat) Next_nat
Next_nat : Nat -> Nat -> Type
```

> next_nat_partial_function : Partial_function Next_nat
> next_nat_partial_function x (S x) (S x) Nn Nn = Refl

However, the \idr{<='} relation on numbers is not a partial function. (Assume,
for a contradiction, that \idr{<='} is a partial function. But then, since
\idr{0 <=' 0} and \idr{0 <=' 1}, it follows that \idr{0 = 1}. This is nonsense,
so our assumption was contradictory.)

> le_not_a_partial_function : Not (Partial_function Le)
> le_not_a_partial_function f = absurd $ f 0 0 1 Le_n (Le_S Le_n)

==== Exercise: 2 stars, optional

\ \todo[inline]{Again, "earlier" = \idr{IndProp}}

Show that the \idr{Total_relation} defined in earlier is not a partial function.

> -- FILL IN HERE

$\square$

==== Exercise: 2 stars, optional

Show that the \idr{Empty_relation} that we defined earlier is a partial
function.

> --FILL IN HERE

$\square$

=== Reflexive Relations

A _reflexive_ relation on a set \idr{t} is one for which every element of
\idr{t} is related to itself.

> Reflexive : (r : Relation t) -> Type
> Reflexive {t} r = (a : t) -> r a a

> le_reflexive : Reflexive Le
> le_reflexive n = Le_n {n}

=== Transitive Relations

A relation \idr{r} is _transitive_ if \idr{r a c} holds whenever \idr{r a b} and
\idr{r b c} do.

> Transitive : (r : Relation t) -> Type
> Transitive {t} r = (a, b, c : t) -> r a b -> r b c -> r a c

> le_trans : Transitive Le
> le_trans _ _ _ lab Le_n = lab
> le_trans a b (S c) lab (Le_S lbc) = Le_S $ le_trans a b c lab lbc

> lt_trans : Transitive Lt
> lt_trans a b c lab lbc = le_trans (S a) (S b) c (Le_S lab) lbc

==== Exercise: 2 stars, optional

We can also prove \idr{lt_trans} more laboriously by induction, without using
\idr{le_trans}. Do this.

> lt_trans' : Transitive Lt
> -- Prove this by induction on evidence that a is less than c.
> lt_trans' a b c lab lbc = ?lt_trans__rhs

$\square$

==== Exercise: 2 stars, optional

\ \todo[inline]{Not sure how is this different from \idr{lt_trans'}?}

Prove the same thing again by induction on \idr{c}.

> lt_trans'' : Transitive Lt
> lt_trans'' a b c lab lbc = ?lt_trans___rhs

$\square$

The transitivity of \idr{Le}, in turn, can be used to prove some facts that will
be useful later (e.g., for the proof of antisymmetry below)...

> le_Sn_le : ((S n) <=' m) -> (n <=' m)
> le_Sn_le {n} {m} = le_trans n (S n) m (Le_S Le_n)

==== Exercise: 1 star, optional

> le_S_n : ((S n) <=' (S m)) -> (n <=' m)
> le_S_n less = ?le_S_n_rhs

$\square$

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

Provide an informal proof of the following theorem:

Theorem: For every \idr{n}, \idr{Not ((S n) <=' n)}

A formal proof of this is an optional exercise below, but try writing an
informal proof without doing the formal proof first.

Proof:

> -- FILL IN HERE

$\square$

==== Exercise: 1 star, optional

> le_Sn_n : Not ((S n) <=' n)
> le_Sn_n = ?le_Sn_n_rhs

$\square$

Reflexivity and transitivity are the main concepts we'll need for later
chapters, but, for a bit of additional practice working with relations in Idris,
let's look at a few other common ones...

=== Symmetric and Antisymmetric Relations

A relation \idr{r} is _symmetric_ if \idr{r a b} implies \idr{r b a}.

> Symmetric : (r : Relation t) -> Type
> Symmetric {t} r = (a, b : t) -> r a b -> r b a

==== Exercise: 2 stars, optional

> le_not_symmetric : Not (Symmetric Le)
> le_not_symmetric = ?le_not_symmetric_rhs

$\square$

A relation \idr{r} is _antisymmetric_ if \idr{r a b} and \idr{r b a} together
imply \idr{a = b} — that is, if the only "cycles" in \idr{r} are trivial ones.

> Antisymmetric : (r : Relation t) -> Type
> Antisymmetric {t} r = (a, b : t) -> r a b -> r b a -> a = b

==== Exercise: 2 stars, optional

> le_antisymmetric : Antisymmetric Le
> le_antisymmetric = ?le_antisymmetric_rhs

$\square$

==== Exercise: 2 stars, optional

> le_step : (n <' m) -> (m <=' (S p)) -> (n <=' p)
> le_step ltnm lemsp = ?le_step_rhs

$\square$

=== Equivalence Relations

A relation is an _equivalence_ if it's reflexive, symmetric, and transitive.

> Equivalence : (r : Relation t) -> Type
> Equivalence r = (Reflexive r, Symmetric r, Transitive r)

=== Partial Orders and Preorders

\ \todo[inline]{Edit}

A relation is a _partial order_ when it's reflexive, _anti_-symmetric, and
transitive. In the Idris standard library it's called just "order" for short.

> Order : (r : Relation t) -> Type
> Order r = (Reflexive r, Antisymmetric r, Transitive r)

A preorder is almost like a partial order, but doesn't have to be antisymmetric.

> Preorder : (r : Relation t) -> Type
> Preorder r = (Reflexive r, Transitive r)

> le_order : Order Le
> le_order = (le_reflexive, le_antisymmetric, le_trans)

== Reflexive, Transitive Closure

\ \todo[inline]{Edit}

The _reflexive, transitive closure_ of a relation \idr{r} is the smallest
relation that contains \idr{r} and that is both reflexive and transitive.
Formally, it is defined like this in the Relations module of the Idris standard
library:

> data Clos_refl_trans : (r : Relation t) -> Relation t where
>   Rt_step : r x y -> Clos_refl_trans r x y
>   Rt_refl : Clos_refl_trans r x x
>   Rt_trans : Clos_refl_trans r x y -> Clos_refl_trans r y z ->
>              Clos_refl_trans r x z

For example, the reflexive and transitive closure of the \idr{Next_nat} relation
coincides with the \idr{Le} relation.

> next_nat_closure_is_le : (n <=' m) <-> (Clos_refl_trans Next_nat n m)
> next_nat_closure_is_le = (to, fro)
>   where
>     to : Le n m -> Clos_refl_trans Next_nat n m
>     to Le_n = Rt_refl
>     to (Le_S {m} le) = Rt_trans {y=m} (to le) (Rt_step Nn)
>     fro : Clos_refl_trans Next_nat n m -> Le n m
>     fro (Rt_step Nn) = Le_S Le_n
>     fro Rt_refl = Le_n
>     fro (Rt_trans {x=n} {y} {z=m} ny ym) =
>       le_trans n y m (fro ny) (fro ym)

The above definition of reflexive, transitive closure is natural: it says,
explicitly, that the reflexive and transitive closure of \idr{r} is the least
relation that includes \idr{r} and that is closed under rules of reflexivity and
transitivity. But it turns out that this definition is not very convenient for
doing proofs, since the "nondeterminism" of the \idr{Rt_trans} rule can
sometimes lead to tricky inductions. Here is a more useful definition:

> data Clos_refl_trans_1n : (r : Relation t) -> (x : t) -> t -> Type where
>   Rt1n_refl : Clos_refl_trans_1n r x x
>   Rt1n_trans : r x y -> Clos_refl_trans_1n r y z -> Clos_refl_trans_1n r x z

\todo[inline]{Edit}

Our new definition of reflexive, transitive closure "bundles" the \idr{Rt_step}
and \idr{Rt_trans} rules into the single rule step. The left-hand premise of
this step is a single use of \idr{r}, leading to a much simpler induction
principle.

Before we go on, we should check that the two definitions do indeed define the
same relation...

First, we prove two lemmas showing that \idr{Clos_refl_trans_1n} mimics the
behavior of the two "missing" \idr{Clos_refl_trans} constructors.

> rsc_R : r x y -> Clos_refl_trans_1n r x y
> rsc_R rxy = Rt1n_trans rxy Rt1n_refl

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

> rsc_trans : Clos_refl_trans_1n r x y -> Clos_refl_trans_1n r y z ->
>             Clos_refl_trans_1n r x z
> rsc_trans crxy cryz = ?rsc_trans_rhs

$\square$

Then we use these facts to prove that the two definitions of reflexive,
transitive closure do indeed define the same relation.

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

> rtc_rsc_coincide : (Clos_refl_trans r x y) <-> (Clos_refl_trans_1n r x y)
> rtc_rsc_coincide = ?rtc_rsc_coincide_rhs

$\square$


module Functions

data Nat' = Z' | S' Nat'

plus : Nat' -> Nat' -> Nat'
plus Z' y = y
plus (S' k) y = S' (plus k y)

mult : Nat' -> Nat' -> Nat'
mult Z' y = Z'
mult (S' k) y = plus y (mult k y)


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

%name Vect xs, ys, zs

{- 1 -}

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

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

{- 2 -}

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


module Term

-- Simply-typed lambda calculus with
--   (1) natural numbers as the only base type, and
--   (2) primitive recursion.
--
-- Terms in the lambda calculus are initially untyped.
-- The usual typing judgement is defined as a separate
-- data type in a separate module.
-- Note that meta-theory developed in yet other modules
-- will rely on the typing judgement.
--
-- Note that variables in the lambda calculus are not
-- named but identified by their de Bruijn index.
-- Since terms in our lambda calculus are initially
-- untyped, they may therefore also be ill-scoped.
-- Hence, de Bruijn indices are represented simply
-- by natural numbers (since they will only be
-- required to be valid in a context that is chosen
-- later, during typing of a term).

%default total
%access public export

------------------------------------------------
-- Begin: (UNTYPED) TERMS OF THE LAMBDA CALCULUS

data Term : Type where
  TVar  : (i : Nat) -> Term
  TAbs  : Term -> Term
  TApp  : Term -> Term -> Term
  TRec  : Term -> Term -> Term ->
          Term
  TZero : Term
  TSucc : Term -> Term
  TPred : Term -> Term
  TIfz  : Term -> Term -> Term ->
          Term

-- Construction of terms is a congruence for equality.
-- The following straightforward lemmas are often useful
-- for writing shorter proofs.

congVar : i = j -> TVar i = TVar j
congVar Refl = Refl

congAbs : e = e' -> TAbs e = TAbs e'
congAbs Refl = Refl

congApp : e1 = e1' -> e2 = e2' -> TApp e1 e2 = TApp e1' e2'
congApp Refl Refl = Refl

congRec : e1 = e1' -> e2 = e2' -> e3 = e3' ->
          TRec e1 e2 e3 = TRec e1' e2' e3'
congRec Refl Refl Refl = Refl

congZero : TZero = TZero
congZero = Refl

congSucc : e = e' -> TSucc e = TSucc e'
congSucc Refl = Refl

congPred : e = e' -> TPred e = TPred e'
congPred Refl = Refl

congIfz : e1 = e1' -> e2 = e2' -> e3 = e3' ->
          TIfz e1 e2 e3 = TIfz e1' e2' e3'
congIfz Refl Refl Refl = Refl

-- End: (UNTYPED) TERMS OF THE LAMBDA CALCULUS
----------------------------------------------

---------------------------------------
-- Begin: VALUES IN THE LAMBDA CALCULUS

-- The following lambda calculus terms
-- are values (i.e. normal forms for
-- reduction under the "Step" relation):
--   (1) lambda abstractions (that are
--       not applied),
--   (2) the constant 'Zero',
--   (3) the natural number constants
--       (formed by applying 'Succ' to
--       another value).
data Value : Term -> Type where
  VZero : Value TZero
  VSucc : Value e -> Value (TSucc e)
  VAbs  : Value (TAbs e)

-- End: VALUES IN THE LAMBDA CALCULUS
-------------------------------------


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

%builtin Natural Fin


import Data.List

ack : Nat -> Nat -> Nat
ack 0 n = S n
ack (S k) 0 = ack k 1
ack (S j) (S k) = ack j (ack (S j) k)

foo : Nat -> Nat
foo Z = Z
foo (S Z) = (S Z)
foo (S (S k)) = foo (S k)

data Ord = Zero | Suc Ord | Sup (Nat -> Ord)

ordElim : (x : Ord) ->
          (p : Ord -> Type) ->
          (p Zero) ->
          ((x : Ord) -> p x -> p (Suc x)) ->
          ((f : Nat -> Ord) -> ((n : Nat) -> p (f n)) ->
             p (Sup f)) -> p x
ordElim Zero p mZ mSuc mSup = mZ
ordElim (Suc o) p mZ mSuc mSup = mSuc o (ordElim o p mZ mSuc mSup)
ordElim (Sup f) p mZ mSuc mSup =
   mSup f (\n => ordElim (f n) p mZ mSuc mSup)

mutual
  bar : Nat -> Lazy Nat -> Nat
  bar x y = mp x y

  mp : Nat -> Nat -> Nat
  mp Z y = y
  mp (S k) y = S (bar k y)

mutual
    swapR : Nat -> Nat -> Nat
    swapR x (S y) = swapL y x
    swapR x Z = x

    swapL : Nat -> Nat -> Nat
    swapL (S x) y = swapR y (S x)
    swapL Z y = y

loopy : a
loopy = loopy

data Bin = EPS | C0 Bin | C1 Bin

foom : Bin -> Nat
foom EPS = Z
foom (C0 EPS) = Z
foom (C0 (C1 x)) = S (foom (C1 x))
foom (C0 (C0 x)) = foom (C0 x)
foom (C1 x) = S (foom x)

pfoom : Bin -> Nat
pfoom EPS = Z
pfoom (C0 EPS) = Z
pfoom (C0 (C1 x)) = S (pfoom (C0 x))
pfoom (C0 (C0 x)) = pfoom (C0 x)
pfoom (C1 x) = S (foom x)

even : Nat -> Bool
even Z = True
even (S k) = odd k
  where
    odd : Nat -> Bool
    odd Z = False
    odd (S k) = even k

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

vtrans : Vect n a -> Vect n a -> List a
vtrans [] _         = []
vtrans (x :: xs) ys = x :: vtrans ys ys

data GTree : Type -> Type where
     MkGTree : List (GTree a) -> GTree a

size : GTree a -> Nat
size (MkGTree []) = Z
size (MkGTree xs) = sizeAll xs
  where
    plus : Nat -> Nat -> Nat
    plus Z y = y
    plus (S k) y = S (plus k y)

    sizeAll : List (GTree a) -> Nat
    sizeAll [] = Z
    sizeAll (x :: xs) = plus (size x) (sizeAll xs)

qsortBad : Ord a => List a -> List a
qsortBad [] = []
qsortBad (x :: xs)
   = qsortBad (filter (< x) xs) ++ x :: qsortBad (filter (> x) xs)

qsort : Ord a => List a -> List a
qsort [] = []
qsort (x :: xs)
   = qsort (assert_smaller (x :: xs) (filter (< x) xs)) ++
         x :: qsort (assert_smaller (x :: xs) (filter (> x) xs))

qsort' : Ord a => List a -> List a
qsort' [] = []
qsort' (x :: xs)
   = let (xs_low, xs_high) = partition x xs in
         qsort' (assert_smaller (x :: xs) xs_low) ++
         x :: qsort' (assert_smaller (x :: xs) xs_high)
  where
    partition : a -> List a -> (List a, List a)
    partition x xs = (filter (< x) xs, filter (>= x) xs)

mySorted : Ord a => List a -> Bool
mySorted []      = True
mySorted (x::xs) =
  case xs of
    Nil     => True
    (y::ys) => x <= y && mySorted (y::ys)

myMergeBy : (a -> a -> Ordering) -> List a -> List a -> List a
myMergeBy order []      right   = right
myMergeBy order left    []      = left
myMergeBy order (x::xs) (y::ys) =
  case order x y of
       LT => x :: myMergeBy order xs (y::ys)
       _  => y :: myMergeBy order (x::xs) ys


module Main

import Data.Fin
import Effects
import Effect.StdIO
import Data.Complex
import Graphics.Color
import Graphics.SDL2.SDL
import Graphics.SDL2.Effect
import Graphics.Cairo.Effect
import Graphics.Shape

-- ================================================================
-- Interactive Penrose Tiling
-- ================================================================

%default total

-- ----------------------------------------------------------------
-- a bit of infrastructure
-- ----------------------------------------------------------------

||| Type alias for convenience
C : Type
C = Complex Double

||| Division of Complex Numbers
divC : C -> C -> C
divC (a:+b) (c:+d) = let real = (a*c+b*d) / (c*c+d*d)
                         imag = (b*c-a*d) / (c*c+d*d)
                     in
                        (real:+imag)

||| the golden ratio constant
goldenRatio : Double
goldenRatio = 0.5 * (1 + (sqrt 5))

||| we model a triangle using a triple of complex numbers
Tri : Type
Tri = (C, C, C)

-- ----------------------------------------------------------------
-- Calculate the penrose tiling
-- ----------------------------------------------------------------

data Penrose = Red Tri | Blue Tri

implementation Show Penrose where
    show (Red x)  = "Red " ++ show x
    show (Blue x) = "Blue " ++ show x

||| Penrose subdivide
||| This computes a single step in the tiling
||| see also: http://preshing.com/20110831/penrose-tiling-explained/
penroseSubdivide : Penrose -> List Penrose
penroseSubdivide (Blue (a, b, c)) = let q = b + ((a-b) `divC` (goldenRatio :+ 0))
                                        r = b + ((c-b) `divC` (goldenRatio :+ 0))
                                    in [Blue (r, c, a), Blue (q, r, b), Red (r, q, a)]
penroseSubdivide (Red (a, b, c))  = let p = a + ((b-a) `divC` (goldenRatio :+ 0))
                                    in [Red (c, p, b), Blue (p, c, a)]

||| A Stream of all Tilings for a given initial triangle
||| a single tiliing consists of a list of triangles
penroseTiling : Tri -> Stream (List Penrose)
penroseTiling triangle = penroseTiling' [(Red triangle)]
                         where penroseTiling' : (List Penrose) -> Stream (List Penrose)
                               penroseTiling' triangles = iterate (\tris => tris >>= penroseSubdivide) triangles

||| Creates an initial upside down triangle
initialTriangle : (height: Int) -> (angle: Double) -> Tri
initialTriangle height angle = let rad = 2 * pi * angle / 360
                                   y = (tan (rad / 2)) * (cast height)
                               in ( 0:+0,  (-1) * y :+ (-1) * (cast height), y :+ (-1) * (cast height))

||| computes the full tiling
||| @level number of subdivide iterations
||| @numTriangles the number of symetric triangles
penroseTriangles : (level: Nat) -> (numTriangles: Int) -> List Penrose
penroseTriangles level numTriangles = let angle = 360.0 / (cast numTriangles)
                                          tilings = penroseTiling $ initialTriangle 200 angle
                                      in head (drop level tilings)

-- ----------------------------------------------------------------
-- Cairo Rendering
-- ----------------------------------------------------------------

red : Color
red = RGBA 250 140 89 255

green : Color
green = RGBA 143 206 94 255

||| get the color for drawing each individual triangle
getColor : Penrose -> Color
getColor (Red  _) = red
getColor (Blue _) = green

getTriangle : Penrose -> Tri
getTriangle (Red triangle) = triangle
getTriangle (Blue triangle) = triangle

||| draws a single penrose triangle using the cairo effect
renderTriangle : Penrose -> { [CAIRO_ON] } Eff ()
renderTriangle penrose = with Effects do
  setSourceRGBA $ getColor penrose
  setLineWidth 6
  let (x1:+y1, x2:+y2, x3:+y3) = getTriangle penrose
  triangle (x1, y1) (x2, y2) (x3, y3)
  fill

renderTriangles : List Penrose -> Double -> Nat -> { [CAIRO_ON] } Eff ()
renderTriangles triangles angle Z = pure ()
renderTriangles triangles angle (S k) = with Effects do renderTriangle' triangles
                                                        rotate angle
                                                        renderTriangles triangles angle k
                                                     where
    renderTriangle' : List Penrose -> { [CAIRO_ON] } Eff ()
    renderTriangle' [] = pure ()
    renderTriangle' (t :: ts) = with Effects do
          renderTriangle t
          renderTriangle' ts

-- ----------------------------------------------------------------
-- Setup and Main Loop
-- ----------------------------------------------------------------

||| type synonym for the effectful programm
||| we need at least the SDL and CAIRO effects
||| STDIO is only needed for optional logging
Prog : (sdl: Type) -> (cairo: Type) -> (result : Type) -> Type
Prog sdl cairo t = { [SDL sdl,      -- the SDL effect
                      CAIRO cairo,  -- Cairo effect
                      STDIO]        -- a std io effect
                     } Eff t

||| convenvience shorthand for a running program
Running : Type -> Type
Running t = Prog SDLCtx () t

||| the application state containing the current subdivision level
||| and number of initial triangles
data AppState = MkState Nat Nat

||| draw the current application state
draw : AppState -> Running ()
draw (MkState angles level) =  with Effects do
  renderClear white
  ctx <- getSdlCtx
  getCanvas ctx
  center

  let numTriangles = cast angles + 4
  let solution = penroseTriangles level numTriangles
  let angle = (2 * pi / (cast numTriangles))

  renderTriangles solution angle (cast numTriangles)

  closeCanvas
  render

||| process sdl input events
process : AppState -> Maybe Event -> Maybe AppState
process _                       (Just (KeyDown KeyEsc))        = Nothing
process _                       (Just (AppQuit))               = Nothing
process (MkState angles level)  (Just (KeyDown KeyUpArrow))    = Just (MkState (S angles) level)
process (MkState Z level)       (Just (KeyDown KeyDownArrow))  = Just (MkState Z level)
process (MkState (S k) level)   (Just (KeyDown KeyDownArrow))  = Just (MkState k level)
process (MkState angles level)  (Just (KeyDown KeyRightArrow)) = Just (MkState angles (S level))
process (MkState angles Z)      (Just (KeyDown KeyLeftArrow))  = Just (MkState angles Z)
process (MkState angles (S k))  (Just (KeyDown KeyLeftArrow))  = Just (MkState angles k)
process state                   _                              = Just state

%default partial

||| the effectful main application and loop
emain : Prog () () ()
emain = do putStrLn "Initialising"
           initialise "Penrose" 800 600
           putStrLn "Initialised"
           eventLoop (MkState Z Z)
           quit
           pure ()
        where
          eventLoop : AppState -> Running ()
          eventLoop state = do draw state
                               ev <- poll
                               let res = process state ev
                               case res of
                                 (Just newState) => eventLoop newState
                                 _               => pure ()

main : IO ()
main = runInit [(), -- initial state for the SDL2 effect (nothing needs to go in here)
                (),
                ()  -- initial state for the StdIO effect
                ]
       emain


%default partial

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

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

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

lookup : Fin n -> Vect n a -> a
lookup FZ (x :: xs) = x
lookup (FS k) (x :: xs) = lookup k xs

zip : Vect n a -> Vect n b -> Vect n (a, b)
zip [] [] = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys


data Expr = Val Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

evaluate : Expr -> Int
evaluate (Val x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y


module HetTree

import Semiring

%default total
%access public export

data Tree a = Nil | End a | (::) (Tree a) (Tree a)

data BiVect : Tree Type -> Type where
  Leaf : BiVect Nil
  Node : a -> BiVect (End a)
  Branch : BiVect ls -> BiVect rs -> BiVect (ls::rs)

using (x : a, ls : Tree a, rs : Tree a)
  data Elem : a -> Tree a -> Type where
    Here  : Elem x (End x)
    Left  : Elem x ls -> Elem x (ls::rs)
    Right : Elem x rs -> Elem x (ls::rs)

remove : (x : a) -> (xs : Tree a) -> Elem x xs -> Tree a
remove x (End x) Here = Nil
remove x (ls :: rs) (Left  p) = remove x ls p :: rs
remove x (ls :: rs) (Right p) = ls :: remove x rs p

addBack
  : {xs : Tree Type}
  -> {x : Type}
  -> {auto elem : Elem x xs}
  -> (val : x)
  -> (vec : BiVect (remove x xs elem))
  -> BiVect xs
addBack {elem = Here} val vec = Node val
addBack {elem = (Left  x)} val (Branch ls rs) = Branch (addBack val ls) rs
addBack {elem = (Right x)} val (Branch ls rs) = Branch ls (addBack val rs)

data AllFinite : Tree Type -> Type where
  Empty : AllFinite Nil
  Both
    : (lhs : AllFinite ls)
    -> (rhs : AllFinite rs)
    -> AllFinite (ls::rs)
  Extra
    : (MinBound x, MaxBound x, Enum x)
    => AllFinite (End x)

marg : (Semiring n, MinBound a, MaxBound a, Enum a) => (a -> n) -> n
marg f = sum (map f [minBound .. maxBound])

margBiVec
: Semiring n
=> {xs : Tree Type}
-> {auto prf : AllFinite xs}
-> (BiVect xs -> n) -> n
margBiVec {xs=Nil} f = f Leaf
margBiVec {xs=End x} {prf=Extra} f = marg (\y => f (Node y))
margBiVec {xs=ls::rs} {prf=Both lp rp} f = margBiVec (\lhs => margBiVec (\rhs => f (Branch lhs rhs)))

margOnce : (Semiring n, Enum x, MinBound x, MaxBound x) => {xs : Tree Type} -> {auto elem : Elem x xs} -> (BiVect xs -> n) -> BiVect (remove x xs elem) -> n
margOnce {elem} f tr = marg (\x => f (addBack x tr))

split : {auto elem : Elem x xs} -> BiVect xs -> (x, BiVect (remove x xs elem))
split {elem = Here} (Node x) = (x, Leaf)
split {elem = (Left  p)} (Branch ls rs) = let (el,rm) = split {elem=p} ls in (el, Branch rm rs)
split {elem = (Right p)} (Branch ls rs) = let (el,rm) = split {elem=p} rs in (el, Branch ls rm)

pop : {auto elem : Elem x xs} -> BiVect xs -> BiVect (remove x xs elem)
pop {elem = Here} (Node x) = Leaf
pop {elem = (Left  p)} (Branch ls rs) = Branch (pop ls) rs
pop {elem = (Right p)} (Branch ls rs) = Branch ls (pop rs)


module Ch04.NaturalInduction

-- TODO: Figure out how to implement the function below (if it's at all possible).

--natural_induction_principle : {a,b : Type} ->
--                              (size : a -> Nat) ->
--                              (f : (x : a) -> Either b (x' : a ** LT (size x') (size x))) ->
--                              (g : (a -> b) ** (x : a) -> (case f x of
--                                                                Left y => (g x = y)
--                                                                Right (y ** _) => (g x = g y)))

lemma : {x : Nat} ->
        LTE x 0 ->
        (x = 0)
lemma {x = Z} pf = Refl
lemma {x = (S k)} pf = absurd (succNotLTEzero pf)

public export
inductive_construction : {a,b : Type} ->
                         (size : a -> Nat) ->
                         (f : (x : a) -> Either b (x' : a ** LT (size x') (size x))) ->
                         a -> b
inductive_construction {a} {b} size f x = helper x (size x) lteRefl where
  helper : (x : a) -> (k : Nat) -> LTE (size x) k -> b
  helper x k bound = case f x of
                          Left y => y
                          Right (x' ** pf) => case k of
                                                    Z => let temp = replace (lemma bound) pf in
                                                             absurd (succNotLTEzero temp)
                                                    (S j) => helper x' j (fromLteSucc (lteTransitive pf bound))


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

adder : Num numType =>
  (argc : Nat) -> (acc : numType) -> AdderType numType argc
adder Z acc = acc
adder (S k) acc = \next => adder k (acc + next)


module Data.Bool

%default total

export
notInvolutive : (x : Bool) -> not (not x) = x
notInvolutive True  = Refl
notInvolutive False = Refl

-- AND

export
andSameNeutral : (x : Bool) -> x && x = x
andSameNeutral False = Refl
andSameNeutral True = Refl

export
andFalseFalse : (x : Bool) -> x && False = False
andFalseFalse False = Refl
andFalseFalse True = Refl

export
andTrueNeutral : (x : Bool) -> x && True = x
andTrueNeutral False = Refl
andTrueNeutral True = Refl

export
andAssociative : (x, y, z : Bool) -> x && (y && z) = (x && y) && z
andAssociative True  _ _ = Refl
andAssociative False _ _ = Refl

export
andCommutative : (x, y : Bool) -> x && y = y && x
andCommutative x True  = andTrueNeutral x
andCommutative x False = andFalseFalse x

export
andNotFalse : (x : Bool) -> x && not x = False
andNotFalse False = Refl
andNotFalse True = Refl

-- OR

export
orSameNeutral : (x : Bool) -> x || x = x
orSameNeutral False = Refl
orSameNeutral True = Refl

export
orFalseNeutral : (x : Bool) -> x || False = x
orFalseNeutral False = Refl
orFalseNeutral True = Refl

export
orTrueTrue : (x : Bool) -> x || True = True
orTrueTrue False = Refl
orTrueTrue True = Refl

export
orAssociative : (x, y, z : Bool) -> x || (y || z) = (x || y) || z
orAssociative True  _ _ = Refl
orAssociative False _ _ = Refl

export
orCommutative : (x, y : Bool) -> x || y = y || x
orCommutative x True  = orTrueTrue x
orCommutative x False = orFalseNeutral x

export
orNotTrue : (x : Bool) -> x || not x = True
orNotTrue False = Refl
orNotTrue True = Refl

-- interaction & De Morgan's laws

export
orSameAndRightNeutral : (x, y : Bool) -> x || (x && y) = x
orSameAndRightNeutral False _ = Refl
orSameAndRightNeutral True  _ = Refl

export
andDistribOrR : (x, y, z : Bool) -> x && (y || z) = (x && y) || (x && z)
andDistribOrR False _ _ = Refl
andDistribOrR True  _ _ = Refl

export
orDistribAndR : (x, y, z : Bool) -> x || (y && z) = (x || y) && (x || z)
orDistribAndR False _ _ = Refl
orDistribAndR True  _ _ = Refl

export
notAndIsOr : (x, y : Bool) -> not (x && y) = not x || not y
notAndIsOr False _ = Refl
notAndIsOr True  _ = Refl

export
notOrIsAnd : (x, y : Bool) -> not (x || y) = not x && not y
notOrIsAnd False _ = Refl
notOrIsAnd True  _ = Refl

-- Interaction with typelevel `Not`

export
notTrueIsFalse : {1 x : Bool} -> Not (x = True) -> x = False
notTrueIsFalse {x=False} _ = Refl
notTrueIsFalse {x=True}  f = absurd $ f Refl

export
notFalseIsTrue : {1 x : Bool} -> Not (x = False) -> x = True
notFalseIsTrue {x=True} _  = Refl
notFalseIsTrue {x=False} f = absurd $ f Refl


module AppendInjective

%access export
%default total

appendInjectiveRight : (a, b, c : List x) -> a ++ b = a ++ c -> b = c
appendInjectiveRight []      _ _ = id
appendInjectiveRight (y::ys) b c = appendInjectiveRight ys b c . snd . consInjective

lemma_bad_nat : (a, b : Nat) -> S a + b = b -> Void
lemma_bad_nat a Z     = rewrite plusZeroRightNeutral a in SIsNotZ
lemma_bad_nat a (S k) = rewrite sym $ plusSuccRightSucc a k in
                        lemma_bad_nat a k . succInjective (S (a + k)) k

lemma_bad_append : (x : a) -> (xs, ys : List a) -> (x::xs) ++ ys = ys -> Void
lemma_bad_append x xs ys = lemma_bad_nat (length xs) (length ys) . rewrite sym $ lengthAppend xs ys in cong {f=length}

appendInjectiveLeft : (a, b, c : List x) -> a ++ c = b ++ c -> a = b
appendInjectiveLeft [] [] _ _ = Refl
appendInjectiveLeft (y::ys) (z::zs) c prf with (consInjective prf)
  | (p1, p2) = rewrite p1 in cong $ appendInjectiveLeft ys zs c p2
appendInjectiveLeft [] (z::zs) c prf = absurd $ lemma_bad_append z zs c $ sym prf
appendInjectiveLeft (y::ys) [] c prf = absurd $ lemma_bad_append y ys c prf


module BiNat.Properties.Mult

import BiNat
import BiNat.Properties.Plus
import BiNat.Properties.Induction
import BiNat.Properties.LT

%access public export
%default total

multDashAddsAccMinusJ : (m, n : BiNat) -> (acc : BiNat) ->
  mult' m n acc = pred $ plus (mult' m n J) acc
multDashAddsAccMinusJ J         ns acc = rewrite plusJIsSucc ns in rewrite predOfSucc ns in Refl
multDashAddsAccMinusJ (ms -: O) ns acc = multDashAddsAccMinusJ ms (ns -: O) acc
multDashAddsAccMinusJ (ms -: I) ns acc =
  rewrite multDashAddsAccMinusJ ms (ns -: O) (plus' ns acc O []) in
  rewrite multDashAddsAccMinusJ ms (ns -: O) (plus' ns J O []) in
  rewrite plusAssociative (mult' ms (ns -: O) J) ns J in
  rewrite plusJIsSucc (plus' (mult' ms (ns -: O) J) ns O []) in
  rewrite predOfSucc (plus' (mult' ms (ns -: O) J) ns O []) in
  rewrite plusAssociative (mult' ms (ns -: O) J) ns acc in Refl

multDistributesPlusRight : (l, m, n : BiNat) -> mult l (plus m n) = plus (mult l m) (mult l n)
multDistributesPlusRight J m n =
  rewrite plusJIsSucc (plus' m n O []) in
  rewrite predOfSucc (plus' m n O []) in
  rewrite plusJIsSucc m in
  rewrite predOfSucc m in
  rewrite plusJIsSucc n in
  rewrite predOfSucc n in Refl
multDistributesPlusRight (ls -: O) m n =
  rewrite sym $ plusDashAppendsAcc m n O [O] in
  multDistributesPlusRight ls (m -: O) (n -: O)
multDistributesPlusRight (ls -: I) m n =
  rewrite plusJIsSucc (plus' m n O []) in
  rewrite multDashAddsAccMinusJ ls (plus' m n O [] -: O) (succ (plus' m n O [])) in
  rewrite predCommutesToPlusSnd (mult ls (plus m n -: O)) (succ (plus m n)) (succIsNotJ (plus m n)) in
  rewrite predOfSucc (plus m n) in
  rewrite sym $ plusDashAppendsAcc m n O [O] in
  rewrite plusJIsSucc m in
  rewrite plusJIsSucc n in
  rewrite multDashAddsAccMinusJ ls (m -: O) (succ m) in
  rewrite multDashAddsAccMinusJ ls (n -: O) (succ n) in
  rewrite predCommutesToPlusSnd (mult ls (m -: O)) (succ m) (succIsNotJ m) in
  rewrite predCommutesToPlusSnd (mult ls (n -: O)) (succ n) (succIsNotJ n) in
  rewrite predOfSucc m in
  rewrite predOfSucc n in
  rewrite sym $ plusAssociative (mult ls (m -: O)) m (plus (mult ls (n -: O)) n) in
  rewrite plusSymmetric m (plus (mult ls (n -: O)) n) in
  rewrite sym $ plusAssociative (mult ls (n -: O)) n m in
  rewrite plusSymmetric n m in
  rewrite plusAssociative (mult ls (m -: O)) (mult ls (n -: O)) (plus' m n O []) in
  rewrite multDistributesPlusRight ls (m -: O) (n -: O) in Refl

multJIsId : (n : BiNat) -> mult n J = n
multJIsId J = Refl
multJIsId (ns -: O) =
  rewrite multDistributesPlusRight ns J J in
  rewrite multJIsId ns in
  rewrite shiftLeftDoubles ns in Refl
multJIsId (ns -: I) =
  rewrite multDashAddsAccMinusJ ns (J -: O) (J -: O) in
  rewrite multDistributesPlusRight ns J J in
  rewrite multJIsId ns in
  rewrite sym $ shiftLeftDoubles ns in
  rewrite plusDashAppendsAcc ns J O [O] in
  rewrite plusJIsSucc ns in
  rewrite predOfDoubled (succ ns) (succIsNotJ ns) in
  rewrite predOfSucc ns in Refl

jMultIsId : (n : BiNat) -> mult J n = n
jMultIsId J = Refl
jMultIsId (ns -: O) = Refl
jMultIsId (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite predOfDoubled (succ ns) (succIsNotJ ns) in
  rewrite predOfSucc ns in Refl

multDistributesPlusLeft : (l, m, n : BiNat) -> mult (plus l m) n = plus (mult l n) (mult m n)
multDistributesPlusLeft l m n =
  induction
    (\k => mult (plus l m) k = plus (mult l k) (mult m k))
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite multDistributesPlusRight (plus' l m O []) k J in
      rewrite pk in
      rewrite multJIsId (plus' l m O []) in
      rewrite multDistributesPlusRight l k J in
      rewrite multDistributesPlusRight m k J in
      rewrite multJIsId l in
      rewrite multJIsId m in
      rewrite sym $ plusAssociative (mult l k) l (plus (mult m k) m) in
      rewrite plusSymmetric l (plus (mult m k) m) in
      rewrite sym $ plusAssociative (mult m k) m l in
      rewrite plusSymmetric m l in
      sym $ plusAssociative (mult l k) (mult m k) (plus l m)
    )
    (rewrite multJIsId (plus l m) in rewrite multJIsId l in rewrite multJIsId m in Refl)
    n

multOfSuccLeft : (m, n : BiNat) -> mult (succ m) n = plus n (mult m n)
multOfSuccLeft m n =
  rewrite sym $ jPlusIsSucc m in
  rewrite multDistributesPlusLeft J m n in
  rewrite plusJIsSucc n in
  rewrite predOfSucc n in Refl

multOfSuccRight : (m, n : BiNat) -> mult m (succ n) = plus (mult m n) m
multOfSuccRight m n =
  rewrite sym $ plusJIsSucc n in
  rewrite multDistributesPlusRight m n J in
  rewrite multJIsId m in Refl

multSymmetric : (m, n : BiNat) -> mult m n = mult n m
multSymmetric m n =
  induction
    (\k => mult k n = mult n k)
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite multDistributesPlusLeft k J n in
      rewrite multDistributesPlusRight n k J in
      rewrite plusJIsSucc n in
      rewrite predOfSucc n in
      rewrite multJIsId n in
      rewrite pk in Refl
    )
    (
      rewrite plusJIsSucc n in
      rewrite predOfSucc n in
      rewrite multJIsId n in Refl
    )
    m

multAssociative : (l, m, n : BiNat) -> mult l (mult m n) = mult (mult l m) n
multAssociative l m n =
  induction
    (\k => mult k (mult m n) = mult (mult k m) n)
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite multDistributesPlusLeft k J (mult m n) in
      rewrite jMultIsId (mult m n) in
      rewrite multDistributesPlusLeft k J m in
      rewrite jMultIsId m in
      rewrite multDistributesPlusLeft (mult k m) m n in
      rewrite pk in Refl
    )
    (
      rewrite jMultIsId (mult m n) in
      rewrite jMultIsId m in Refl
    )
    l

appendOIsTwice : (n : BiNat) -> n -: O = mult n (J -: O)
appendOIsTwice n =
  induction
    (\k => k -: O = mult k (J -: O))
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite multDistributesPlusLeft k J (J -: O) in
      rewrite sym pk in
      sym $ plusDashAppendsAcc k J O [O]
    )
    Refl
    n

appendIIsTwicePlusJ : (n : BiNat) -> n -: I = plus (mult n (J -: O)) J
appendIIsTwicePlusJ n = rewrite sym $ appendOIsTwice n in Refl

multNKeepsLT : (l, m : BiNat) -> LT l m -> (n : BiNat) -> LT (mult l n) (mult m n)
multNKeepsLT l m lt n =
  induction
    (\k => LT (mult l k) (mult m k))
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite multDistributesPlusRight l k J in
      rewrite multDistributesPlusRight m k J in
      rewrite multJIsId l in
      rewrite multJIsId m in
      lessThanTransitive
        (plusNKeepsLessThan (mult l k) (mult m k) pk l)
        (
          rewrite plusSymmetric (mult m k) l in
          rewrite plusSymmetric (mult m k) m in
          plusNKeepsLessThan l m lt (mult m k)
        )
    )
    (rewrite multJIsId l in rewrite multJIsId m in lt)
    n


> module Tuple.Properties

> import Control.Isomorphism

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

> |||
> tuplePairIso3 : {A, B, C : Type} -> Iso (A, B, C) ((A, B), C)
> tuplePairIso3 {A} {B} {C} = MkIso to from ok1 ok2
>   where to : (A, B, C) -> ((A, B), C)
>         to (x, y, z) = ((x, y), z)
>         from : ((A, B), C) -> (A, B, C)
>         from ((x, y), z) = (x, y, z)
>         ok1 : (x : ((A, B), C)) -> to (from x) = x
>         ok1 ((x, y), z) = Refl
>         ok2 : (x : (A, B, C)) -> from (to x) = x
>         ok2 (x, y, z) = Refl

> |||
> tuplePairIso4 : {A, B, C, D : Type} -> Iso (A, B, C, D) ((A, B, C), D)
> tuplePairIso4 {A} {B} {C} {D} = MkIso to from ok1 ok2
>   where to : (A, B, C, D) -> ((A, B, C), D)
>         to (a, b, c, d) = ((a, b, c), d)
>         from : ((A, B, C), D) -> (A, B, C, D)
>         from ((a, b, c), d) = (a, b, c, d)
>         ok1 : (x : ((A, B, C), D)) -> to (from x) = x
>         ok1 ((a, b, c), d) = Refl
>         ok2 : (x : (A, B, C, D)) -> from (to x) = x
>         ok2 (a, b, c, d) = Refl


module Interpreter

import Data.Fin
import Data.Vect

data Ty = TyInt | TyBool | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyInt = Integer
interpTy TyBool = Bool
interpTy (TyFun x y) = interpTy x -> interpTy y

using (G : Vect n Ty)
  -- See 'De Bruijn index'

  -- HasType i G t means variable i in context G has type t
  -- This type acts like a Nat, like an index to variables
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
    Stop : HasType FZ (t :: G) t
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Integer) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) ->
          Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i) = lookup i env
  interp env (Val x) = x
  interp env (Lam f) = \x => interp (x :: env) f
  interp env (App f x) = (interp env f) (interp env x)
  interp env (Op f x y) = f (interp env x) (interp env y)
  interp env (If b x y) = if interp env b
                          then interp env x
                          else interp env y


> module Fraction.NormalizeProperties

> import Syntax.PreorderReasoning

> import Fraction.Fraction
> import Fraction.BasicOperations
> import Fraction.Normalize
> import Fraction.Predicates
> import Fraction.Normal
> import Fraction.BasicProperties
> import Fraction.EqProperties
> import Fraction.LTEProperties
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Nat.Positive
> import Basic.Operations
> import Nat.LTEProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import Nat.GCD
> import Nat.GCDOperations
> import Nat.GCDProperties
> import Nat.Divisor
> import Nat.DivisorOperations
> import Nat.DivisorProperties
> import Nat.Coprime
> import Nat.CoprimeProperties
> import Nat.GCDAlgorithm
> import Nat.GCDEuclid
> import Pairs.Operations
> import Sigma.Sigma

> %default total
> %access public export
> -- %access export

Basic properties of |normalize|:

> |||
> normalNormalize : (x : Fraction) -> Normal (normalize x)
> normalNormalize (m, n') =
>   let n       :  Nat
>               =  toNat n' in
>   let zLTn    :  (Z `LT` n)
>               =  toNatLTLemma n' in
>   let d       :  Nat
>               =  gcdAlg m n in
>   let dGCDmn  :  (GCD d m n)
>               =  gcdAlgLemma m n in
>   let dDm     :  (d `Divisor` m)
>               =  gcdDivisorFst dGCDmn in
>   let dDn     :  (d `Divisor` n)
>               =  gcdDivisorSnd dGCDmn in
>   let zLTd    :  (Z `LT` d)
>               =  gcdPreservesPositivity2 zLTn (MkSigma d dGCDmn) in
>   MkNormal (gcdCoprimeLemma d m n dDm dDn zLTd dGCDmn)
> %freeze normalNormalize

> ||| Normalization of normal fraction is identity
> normalizePreservesNormal : (x : Fraction) -> Normal x -> normalize x = x
> normalizePreservesNormal (m, n') (MkNormal (MkCoprime prf)) =
>   let n       :  Nat
>               =  toNat n' in
>   let d       :  Nat
>               =  gcdAlg m n in
>   let dGCDmn  :  (GCD d m n)
>               =  gcdAlgLemma m n in
>   let dDm     :  (d `Divisor` m)
>               =  gcdDivisorFst dGCDmn in
>   let dDn     :  (d `Divisor` n)
>               =  gcdDivisorSnd dGCDmn in
>   let o       :  Nat
>               =  quotient m d dDm in
>   let p       :  Nat
>               =  quotient n d dDn in
>   let zLTn    :  (Z `LT` n)
>               =  toNatLTLemma n' in
>   let zLTp    :  (Z `LT` p)
>               =  quotientPreservesPositivity n d dDn zLTn in
>   let dEQ1    :  (d = S Z)
>               =  prf in
>
>     ( normalize (m, n') )
>   ={ Refl }=
>     ( (o, fromNat p zLTp) )
>   ={ cong2 (quotientAnyOneAny m d dDm dEQ1) (toNatEqLemma (quotientAnyOneAny n d dDn dEQ1)) }=
>     ( (m, n') )
>   QED
> %freeze normalizePreservesNormal

> ||| normalize is idempotent
> normalizeIdempotent : (x : Fraction) -> normalize (normalize x) = normalize x
> normalizeIdempotent x =
>     ( normalize (normalize x) )
>   ={ normalizePreservesNormal (normalize x) (normalNormalize x) }=
>     ( normalize x )
>   QED
> %freeze normalizeIdempotent

> |||
> normalizeUpscaleLemma : (x : Fraction) -> (e : PNat) -> normalize (upscale x e) = normalize x
> normalizeUpscaleLemma (m, d') e' =
>   let d              :  Nat
>                      =  toNat d' in
>   let g              :  Nat
>                      =  gcdAlg m d in
>   let gmd            :  (GCD g m d)
>                      =  gcdAlgLemma m d in
>   let gDm            :  (g `Divisor` m)
>                      =  gcdDivisorFst gmd in
>   let gDd            :  (g `Divisor` d)
>                      =  gcdDivisorSnd gmd in
>   let qmg            :  Nat
>                      =  quotient m g gDm in
>   let qdg            :  Nat
>                      =  quotient d g gDd in
>   let zLTd           :  (Z `LT` d)
>                      =  toNatLTLemma d' in
>   let zLTg           :  (Z `LT` g)
>                      =  gcdPreservesPositivity2 zLTd (MkSigma g gmd) in
>   let zLTqdg         :  (Z `LT` qdg)
>                      =  quotientPreservesPositivity d g gDd zLTd in
>   let e              :  Nat
>                      =  toNat e' in
>   let zLTe           :  (Z `LT` e)
>                      =  toNatLTLemma e' in
>   let ed             :  Nat
>                      =  toNat (e' * d') in
>   let h              :  Nat
>                      =  gcdAlg (e * m) ed in
>   let hemed          :  (GCD h (e * m) ed)
>                      =  gcdAlgLemma (e * m) ed in
>   let hDem           :  (h `Divisor` (e * m))
>                      =  gcdDivisorFst hemed in
>   let hDed           :  (h `Divisor` ed)
>                      =  gcdDivisorSnd hemed in
>   let qemh           :  Nat
>                      =  quotient (e * m) h hDem in
>   let qedh           :  Nat
>                      =  quotient ed h hDed in
>   let zLTed          :  (Z `LT` ed)
>                      =  toNatLTLemma (e' * d') in
>   let zLTqedh        :  (Z `LT` qedh)
>                      =  quotientPreservesPositivity ed h hDed zLTed in

>   let edEQed         :  (toNat (e' * d') = e * d)
>                      =  toNatMultLemma in
>   let hemed'         :  (GCD h (e * m) (e * d))
>                      =  replace {P = \ ZUZU => GCD h (e * m) ZUZU} edEQed hemed in
>   let hEQeg          :  (h = e * g)
>                      =  gcdScaleInvariant g m d h e gmd hemed' in
>   let egemed         :  (GCD (e * g) (e * m) (e * d))
>                      =  replace {P = \ ZUZU => GCD ZUZU (e * m) (e * d)} hEQeg hemed' in
>   let egDem          :  ((e * g) `Divisor` (e * m))
>                      =  gcdDivisorFst egemed in
>   let egDed          :  ((e * g) `Divisor` (e * d))
>                      =  gcdDivisorSnd egemed in
>   let qemeg          :  Nat
>                      =  quotient (e * m) (e * g) egDem in
>   let qedeg          :  Nat
>                      =  quotient (e * d) (e * g) egDed in
>   let zLTed'         :  (Z `LT` (e * d))
>                      =  multZeroLTZeroLT e d zLTe zLTd in
>   let zLTqedeg       :  (Z `LT` qedeg)
>                      =  quotientPreservesPositivity (e * d) (e * g) egDed zLTed' in
>   let nhEQZ          :  (Not (h = Z))
>                      =  gtZisnotZ (gcdPreservesPositivity2 zLTed (MkSigma h hemed)) in
>   let negEQZ         :  (Not (e * g = Z))
>                      =  gtZisnotZ (multZeroLTZeroLT e g zLTe zLTg) in
>   let qemhEQqemeg    :  (qemh = qemeg)
>                      =  quotientEqLemma (e * m) h hDem (e * m) (e * g) egDem Refl hEQeg nhEQZ in
>   let qedhEQqedeg    :  (qedh = qedeg)
>                      =  quotientEqLemma ed h hDed (e * d) (e * g) egDed edEQed hEQeg nhEQZ in
>   let qemegEQqmg     :  (qemeg = qmg)
>                      =  sym (quotientScaleInvariant m g e negEQZ gDm egDem) in
>   let qedegEQqdg     :  (qedeg = qdg)
>                      =  sym (quotientScaleInvariant d g e negEQZ gDd egDed) in
>   let qedh'          :  PNat
>                      =  fromNat qedh zLTqedh in
>   let qedeg'         :  PNat
>                      =  fromNat qedeg zLTqedeg in
>   let qedh'EQqedeg'  :  (qedh' = qedeg')
>                      =  toNatEqLemma {x = fromNat qedh zLTqedh} {y = fromNat qedeg zLTqedeg} qedhEQqedeg in
>   let qdg'           :  PNat
>                      =  fromNat qdg zLTqdg in
>   let qedeg'EQqdg'   :  (qedeg' = qdg')
>                      =  toNatEqLemma {x = fromNat qedeg zLTqedeg} {y = fromNat qdg zLTqdg} qedegEQqdg in
>
>     ( normalize (upscale (m, d') e') )
>   ={ Refl }=
>     ( normalize (m * e, d' * e') )
>   ={ cong {f = \ ZUZU => normalize (ZUZU, d' * e')} (multCommutative m e) }=
>     ( normalize (e * m, d' * e') )
>   ={ cong {f = \ ZUZU => normalize (e * m, ZUZU)} (multCommutative d' e') }=
>     ( normalize (e * m, e' * d') )
>   ={ Refl }=
>     ( (qemh, qedh') )
>   ={ cong {f = \ ZUZU => (ZUZU, qedh')} qemhEQqemeg }=
>     ( (qemeg, qedh') )
>   ={ cong {f = \ ZUZU => (qemeg, ZUZU)} qedh'EQqedeg' }=
>     ( (qemeg, qedeg') )
>   ={ cong {f = \ ZUZU => (ZUZU, qedeg')} qemegEQqmg }=
>     ( (qmg, qedeg') )
>   ={ cong {f = \ ZUZU => (qmg, ZUZU)} qedeg'EQqdg' }=
>     ( (qmg, qdg') )
>   ={ Refl }=
>     ( normalize (m, d') )
>   QED
> %freeze normalizeUpscaleLemma

Properties of |normalize|, |Eq|:

> |||
> normalizeEqLemma1 : (x : Fraction) -> (normalize x) `Eq` x
> normalizeEqLemma1 (m, n') =
>   let n     :  Nat
>             =  toNat n' in
>   let d     :  Nat
>             =  gcdAlg m n in
>   let v     :  (GCD d m n)
>             =  gcdAlgLemma m n in
>   let dDm   :  (d `Divisor` m)
>             =  gcdDivisorFst v in
>   let dDn   :  (d `Divisor` n)
>             =  gcdDivisorSnd v in
>
>  flipQuotientLemma m n d dDm dDn
> %freeze normalizeEqLemma1

> |||
> normalizeEqLemma2 : (x : Fraction) -> (y : Fraction) ->
>                     x `Eq` y -> normalize x = normalize y
> normalizeEqLemma2 (m1, n1') (m2, n2') m1n2EQm2n1 =
>   let n1  =  toNat n1' in
>   let n2  =  toNat n2' in
>
>     ( normalize (m1, n1') )
>   ={ sym (normalizeUpscaleLemma (m1, n1') n2') }=
>     ( normalize (m1 * n2, n1' * n2') )
>   ={ cong {f = \ ZUZU => normalize (ZUZU, n1' * n2')} m1n2EQm2n1 }=
>     ( normalize (m2 * n1, n1' * n2') )
>   ={ cong {f = \ ZUZU => normalize (m2 * n1, ZUZU)} (multCommutative n1' n2') }=
>     ( normalize (m2 * n1, n2' * n1') )
>   ={ normalizeUpscaleLemma (m2, n2') n1' }=
>     ( normalize (m2, n2') )
>   QED
> %freeze normalizeEqLemma2

Further properties of |normalize|:

> |||
> normalizePlusElimLeft : (x : Fraction) -> (y : Fraction) ->
>                         normalize (normalize x + y) = normalize (x + y)
> normalizePlusElimLeft x y =
>   let nxEqx   = normalizeEqLemma1 x in
>   let nxyEqxy = plusPreservesEq (normalize x) x y y nxEqx EqReflexive in
>   normalizeEqLemma2 (normalize x + y) (x + y) nxyEqxy
> %freeze normalizePlusElimLeft

> |||
> normalizePlusElimRight : (x : Fraction) -> (y : Fraction) ->
>                          normalize (x + normalize y) = normalize (x + y)
> normalizePlusElimRight x y =
>   let nyEqy   = normalizeEqLemma1 y in
>   let xnyEqxy = plusPreservesEq x x (normalize y) y EqReflexive nyEqy in
>   normalizeEqLemma2 (x + normalize y) (x + y) xnyEqxy
> %freeze normalizePlusElimRight

> |||
> normalizePlusElim : (x : Fraction) -> (y : Fraction) ->
>                     normalize (normalize x + normalize y) = normalize (x + y)
> normalizePlusElim x y =
>   let nxEqx   = normalizeEqLemma1 x in
>   let nyEqy   = normalizeEqLemma1 y in
>   let nxnyEqxy = plusPreservesEq (normalize x) x (normalize y) y nxEqx nyEqy in
>   normalizeEqLemma2 (normalize x + normalize y) (x + y) nxnyEqxy
> %freeze normalizePlusElim

> |||
> normalizeMultElimLeft : (x : Fraction) -> (y : Fraction) ->
>                         normalize ((normalize x) * y) = normalize (x * y)
> normalizeMultElimLeft x y =
>   let nxEqx   = normalizeEqLemma1 x in
>   let nxyEqxy = multPreservesEq (normalize x) x y y nxEqx EqReflexive in
>   normalizeEqLemma2 ((normalize x) * y) (x * y) nxyEqxy
> %freeze normalizeMultElimLeft

> |||
> normalizeMultElimRight : (x : Fraction) -> (y : Fraction) ->
>                          normalize (x * (normalize y)) = normalize (x * y)
> normalizeMultElimRight x y =
>   let nyEqy   = normalizeEqLemma1 y in
>   let xnyEqxy = multPreservesEq x x (normalize y) y EqReflexive nyEqy in
>   normalizeEqLemma2 (x * (normalize y)) (x * y) xnyEqxy
> %freeze normalizeMultElimRight

> |||
> normalizeMultElim : (x : Fraction) -> (y : Fraction) ->
>                     normalize ((normalize x) * (normalize y)) = normalize (x * y)
> normalizeMultElim x y =
>   let nxEqx   = normalizeEqLemma1 x in
>   let nyEqy   = normalizeEqLemma1 y in
>   let nxnyEqxy = multPreservesEq (normalize x) x (normalize y) y nxEqx nyEqy in
>   normalizeEqLemma2 ((normalize x) * (normalize y)) (x * y) nxnyEqxy
> %freeze normalizeMultElim

> |||
> normalizeLTELemma : (x : Fraction) -> (y : Fraction) ->
>                     x `LTE` y -> normalize x `LTE` normalize y
> normalizeLTELemma (nx, dx') (ny, dy') xLTEy = s11 where
>
>   dx  : Nat
>   dx  = toNat dx'
>   zLTdx : Z `LT` dx
>   zLTdx = toNatLTLemma dx'
>
>   dy  : Nat
>   dy  = toNat dy'
>   zLTdy : Z `LT` dy
>   zLTdy = toNatLTLemma dy'
>
>   gx  : Nat
>   gx  = gcdAlg nx dx
>   pgx : GCD gx nx dx
>   pgx = gcdAlgLemma nx dx
>   gxDnx : gx `Divisor` nx
>   gxDnx = gcdDivisorFst pgx
>   gxDdx : gx `Divisor` dx
>   gxDdx = gcdDivisorSnd pgx
>   zLTgx : Z `LT` gx
>   zLTgx = gcdPreservesPositivity2 zLTdx (MkSigma gx pgx)
>
>   gy  : Nat
>   gy  = gcdAlg ny dy
>   pgy : GCD gy ny dy
>   pgy = gcdAlgLemma ny dy
>   gyDny : gy `Divisor` ny
>   gyDny = gcdDivisorFst pgy
>   gyDdy : gy `Divisor` dy
>   gyDdy = gcdDivisorSnd pgy
>   zLTgy : Z `LT` gy
>   zLTgy = gcdPreservesPositivity2 zLTdy (MkSigma gy pgy)
>
>   nnx : Nat
>   nnx = quotient nx gx gxDnx
>   dnx : Nat
>   dnx = quotient dx gx gxDdx
>   zLTdnx : Z `LT` dnx
>   zLTdnx = quotientPreservesPositivity dx gx gxDdx zLTdx
>   dnx' : PNat
>   dnx' = fromNat dnx zLTdnx
>
>   nny : Nat
>   nny = quotient ny gy gyDny
>   dny : Nat
>   dny = quotient dy gy gyDdy
>   zLTdny : Z `LT` dny
>   zLTdny = quotientPreservesPositivity dy gy gyDdy zLTdy
>   dny' : PNat
>   dny' = fromNat dny zLTdny
>
>   nxdy : Nat
>   nxdy = nx * dy
>   nydx : Nat
>   nydx = ny * dx
>   gxgy : Nat
>   gxgy = gx * gy
>   gygx : Nat
>   gygx = gy * gx
>   gxgyDnxdy : gxgy `Divisor` nxdy
>   gxgyDnxdy = divisorMultLemma1 nx gx gxDnx dy gy gyDdy
>   gygxDnydx : gygx `Divisor` nydx
>   gygxDnydx = divisorMultLemma1 ny gy gyDny dx gx gxDdx
>   ngxgyZ : Not (gxgy = Z)
>   ngxgyZ = multNotZeroNotZero gx gy (gtZisnotZ zLTgx) (gtZisnotZ zLTgy)

>   s01 : LTE nxdy nydx
>   s01 = xLTEy
>   s02 : LTE ((quotient nxdy gxgy gxgyDnxdy) * gxgy) nydx
>   s02 = replace {P = \ ZUZ => LTE ZUZ nydx}
>                 (sym (quotientLemma' nxdy gxgy gxgyDnxdy)) s01
>   s03 : LTE ((quotient nxdy gxgy gxgyDnxdy) * gxgy) ((quotient nydx gygx gygxDnydx) * gygx)
>   s03 = replace {P = \ ZUZ => LTE ((quotient nxdy gxgy gxgyDnxdy) * gxgy) ZUZ}
>                 (sym (quotientLemma' nydx gygx gygxDnydx)) s02
>   s04 : LTE (quotient nxdy gxgy gxgyDnxdy) (quotient nydx gygx gygxDnydx)
>   s04 = elimRightMultLTE s03 (multCommutative gx gy) ngxgyZ
>   s05 : LTE ((quotient nx gx gxDnx) * (quotient dy gy gyDdy)) (quotient nydx gygx gygxDnydx)
>   s05 = replace {P = \ ZUZ => LTE ZUZ (quotient nydx gygx gygxDnydx)}
>                 (sym (quotientMultLemma nx gx gxDnx dy gy gyDdy)) s04
>   s06 : LTE ((quotient nx gx gxDnx) * (quotient dy gy gyDdy)) ((quotient ny gy gyDny) * (quotient dx gx gxDdx))
>   s06 = replace {P = \ ZUZ => LTE ((quotient nx gx gxDnx) * (quotient dy gy gyDdy)) ZUZ}
>                 (sym (quotientMultLemma ny gy gyDny dx gx gxDdx)) s05
>   s07 : LTE (nnx * dny) (nny * dnx)
>   s07 = s06
>   s08 : LTE (nnx * (toNat dny')) (nny * dnx)
>   s08 = replace {P = \ ZUZ => LTE (nnx * ZUZ) (nny * dnx)} (sym (toNatfromNatLemma dny zLTdny)) s07
>   s09 : LTE (nnx * (toNat dny')) (nny * (toNat dnx'))
>   s09 = replace {P = \ ZUZ => LTE (nnx * (toNat dny')) (nny * ZUZ)} (sym (toNatfromNatLemma dnx zLTdnx)) s08
>   s10 : (nnx, dnx') `LTE` (nny, dny')
>   s10 = s09
>   s11 : normalize (nx, dx') `LTE` normalize (ny, dy')
>   s11 = s10
> %freeze normalizeLTELemma

> {-

> ---}


module Ordinals

data Ord : Type where
  Zero : Ord
  Suc  : (x : Ord) -> Ord
  Lim  : (f : Nat -> Ord) -> Ord

(+) : Ord -> Ord -> Ord
(+) Zero m = m
(+) (Suc n) m = Suc $ n + m
(+) (Lim f) m = Lim (\x => f x + m)

(*) : Ord -> Ord -> Ord
(*) Zero m = Zero
(*) (Suc n) m = n + m
(*) (Lim f) m = Lim (\x => f x * m)

exp : Ord -> Ord -> Ord
exp Zero m = Suc Zero
exp (Suc n) m = n * m
exp (Lim f) m = Lim (\x => exp (f x) m)

omega : Ord
omega = Lim rec
  where
    rec : Nat -> Ord
    rec Z = Zero
    rec (S n) = Suc $ rec n

epsilonNought : Ord
epsilonNought = Lim rec
  where
    rec : Nat -> Ord
    rec Z = omega
    rec (S n) = exp omega (rec n)


import Data.List.Views
import Data.List.Views.Extra
import Data.Nat.Views

||| Returns maximum equal suffix of two input lists
-- idris2 cannot check inside pairs so totality check fails
-- equalSuffix : Eq a => List a -> List a -> List a
-- equalSuffix input1 input2 with (snocList input1, snocList input2)
--   equalSuffix (xs ++ [x]) (ys ++ [y]) | ((Snoc x xs xsrec), (Snoc y ys ysrec))
--     = if x == y then equalSuffix xs ys ++ [x] else []
--   equalSuffix _ _ | (Empty, _) = []
--   equalSuffix _ _ | (_, Empty) = []

||| Returns maximum equal suffix of two input lists
equalSuffix : Eq a => List a -> List a -> List a
equalSuffix input1 input2 with (snocList input1)
  equalSuffix [] _ | Empty = []
  equalSuffix (xs ++ [x]) input2 | (Snoc x xs rec) with (snocList input2)
    equalSuffix (xs ++ [x]) [] | (Snoc x xs rec) | Empty = []
    equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc x xs rec) | (Snoc y ys z)
        = if x == y then equalSuffix xs ys ++ [x] else []

-- with recursion, but bug
-- equalSuffix : Eq a => List a -> List a -> List a
-- equalSuffix input1 input2 with (snocList input1)
--   equalSuffix [] _ | Empty = []
--   equalSuffix (xs ++ [x]) input2 | (Snoc x xs recxs) with (snocList input2)
--     equalSuffix (xs ++ [x]) [] | (Snoc x xs recxs) | Empty = []
--     equalSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc x xs recxs) | (Snoc y ys recys)
--         = if x == y then (equalSuffix xs ys | recxs | recys) ++ [x] else []

||| Turns Nat into binary string (slow)
toBinary : Nat -> String
toBinary n with (halfRec n)
  toBinary 0 | HalfRecZ = ""
  toBinary (k + k) | (HalfRecEven k rec) = (toBinary k | rec) ++ "0"
  toBinary (S (k + k)) | (HalfRecOdd k rec) = (toBinary k | rec) ++ "1"

||| Returns True if a List is traversed the same forwards and backwards
palindrome : Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (xs ++ [y])) | (VCons rec) =
    if x == y then (palindrome xs | rec) else False


module Toolkit.Data.List.Filter

import Toolkit.Data.DList
import Toolkit.Data.List.Interleaving

%default total

public export
data Filter : (holdsFor : type -> Type)
           -> (input : List type)
           -> Type
  where
    MkFilter : {thrown : List type}
            -> (kept : List type)
            -> (prfOrdering : Interleaving kept thrown input)
            -> (prfKept     : DList type holdsFor kept)
            -> (prfThrown   : DList type (Not . holdsFor) thrown)
            -> Filter holdsFor input

export
filter : (test   : (value : type) -> Dec (holds value))
      -> (input  : List type)
      -> Filter holds input
filter test [] = MkFilter [] Empty [] []
filter test (x :: xs) with (filter test xs)
  filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) with (test x)
    filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) | (Yes prf)
      = MkFilter (x::kept) (Left x prfOrdering) (prf :: prfKept) prfThrown
    filter test (x :: xs) | (MkFilter kept prfOrdering prfKept prfThrown) | (No contra)
      = MkFilter kept (Right x prfOrdering) prfKept (contra :: prfThrown)

export
extract : Filter p xs
       -> (ks ** DList type p ks)
extract (MkFilter kept prfOrdering prfKept prfThrown)
  = (kept ** prfKept)

-- [ EOF ]


-- a mini prelude

module Stuff

public export
data Bool = True | False

public export
not : Bool -> Bool
not True = False
not False = True

public export
data Maybe : Type -> Type where
     Nothing : Maybe a
     Just : (1 x : a) -> Maybe a

public export
data Either : Type -> Type -> Type where
     Left : (1 x : a) -> Either a b
     Right : (1 y : b) -> Either a b

public export
intToBool : Int -> Bool
intToBool 0 = False
intToBool x = True

public export
ifThenElse : Bool -> Lazy a -> Lazy a -> a
ifThenElse True t e = t
ifThenElse False t e = e

public export
data Nat : Type where
     Z : Nat
     S : (1 _ : Nat) -> Nat

public export
fromInteger : Integer -> Nat
fromInteger x = ifThenElse (intToBool (prim__eq_Integer x 0))
                      Z (S (fromInteger (prim__sub_Integer x 1)))

public export
plus : Nat -> Nat -> Nat
plus Z y = y
plus (S k) y = S (plus k y)

infixr 5 ::

public export
data List : Type -> Type where
     Nil : List a
     (::) : (1 _ : a) -> (1 _ : List a) -> List a

public export
data Eq : a -> b -> Type where
     Refl : (x : a) -> Eq x x

public export
data Unit = MkUnit

public export
data Pair : Type -> Type -> Type where
     MkPair : {a, b : Type} -> a -> b -> Pair a b

public export
the : (a : Type) -> a -> a
the _ x = x


> module SequentialDecisionProblems.TabBackwardsInduction2

> import Data.Vect
> import Control.Isomorphism
> -- import Debug.Trace

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

> import Nat.Operations
> import Nat.OperationsProperties
> import Nat.LTEProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Decidable.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Pairs.Operations
> import Vect.Operations
> import Vect.Properties
> import Decidable.Predicates
> import Fin.Operations

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

* Tabulation

If the state space is finite

> finiteState : (t : Nat) -> Finite (State t)

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

> cardState : (t : Nat) -> Nat
> cardState t = card (finiteState t)

> vectState : (t : Nat) -> Vect (cardState t) (State t)
> vectState t = toVect (finiteState t)

If |Reachable| and |Viable n| are also decidable

> decidableReachable : {t' : Nat} -> (x' : State t') -> Dec (Reachable x')

< decidableViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (Viable n x)

then their conjunction

> ReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Type
> ReachableAndViable n x = (Reachable x , Viable n x)

is decidable

> decidableReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (ReachableAndViable n x)
> decidableReachableAndViable n x = decPair (decidableReachable x) (decidableViable n x)

and we can collect all states which are reachable and viable in a vector:

> cardReachableAndViableState : (t : Nat) -> (n : Nat) -> Nat
> cardReachableAndViableState t n = outl (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

> vectReachableAndViableState : (t : Nat) -> (n : Nat) ->
>                               Vect (cardReachableAndViableState t n) (Sigma (State t) (ReachableAndViable n))
> vectReachableAndViableState t n = outr (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

--

If equality on values of type |State t| is decidable

> decidableEqState : (t : Nat) -> DecEq (State t)

we can store the result of looking up the index of a reachable and
viable state in |vectReachableAndViableState t n| into a table

> iat : {t, n : Nat} ->
>       Not (Z = cardReachableAndViableState t n) ->
>       Vect (cardState t) (Fin (cardReachableAndViableState t n))
> iat {t} {n} prf = toVect iatf where
>   iatf : (Fin (cardState t) -> Fin (cardReachableAndViableState t n))
>   iatf k with (lookup' (decidableEqState t)
>                        (from (iso (finiteState t)) k)
>                        (map outl (vectReachableAndViableState t n)))
>     | Nothing with (cardReachableAndViableState t n) proof contra
>         |   Z = void (prf Refl)
>         | S m = FZ {k = m}
>     | Just k' = k'

The table can then be used to replace lookups (like in |tabSval|, see
below) with |index| operations. The idea is that indexing can in
principle (Blodwin feature?) be done in constant time whereas lookups
(searcing) takes liner time.

--

In this case, we can implement a "tabulated" versions of |backwardsInduction|

< backwardsInduction : (t : Nat) -> (n : Nat) -> PolicySeq t n
< backwardsInduction t  Z     =  Nil
< backwardsInduction t (S n)  =  let ps = backwardsInduction (S t) n in
<                                optExt ps :: ps

The idea is to replace policies as functions from states to control with
policy tables. In analogy to policies as defined in the CoreTheory, the
type of a policy table that supports zero decision steps is just the
singleton type. A policy table that supports |S m| further decision
steps at decision step |t| is a vector with as many entries as there are
states in |State t| that are reachable and viable |S m| steps:

> |||
> PolicyTable : (t : Nat) -> (n : Nat) -> Type
> PolicyTable t  Z    = Unit
> PolicyTable t (S m) = Vect
>                       (cardReachableAndViableState t (S m))
>                       (Sigma (State t) (\x => (ReachableAndViable (S m) x, GoodCtrl t x m)))

Similarly, sequences of policy tables are either empty or made up of a
policy table consed with a tail sequence:

> |||
> data PolicyTableSeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} ->
>            PolicyTableSeq t Z
>   (::)  :  {t, n : Nat} ->
>            PolicyTable t (S n) -> PolicyTableSeq (S t) n -> PolicyTableSeq t (S n)

With these notions in place, a tabulated version of backwards induction
will be a function of type

< (t : Nat) -> (n : Nat) -> PolicyTableSeq t n

In order to implement this function, some additional notions are needed. ...

> |||
> ValueTable : Nat -> Nat -> Type
> ValueTable t n = Vect (cardReachableAndViableState t n) Val

> |||
> zeroVec : (n : Nat) -> Vect n Val
> zeroVec Z     = Nil
> zeroVec (S n) = zero :: zeroVec n

> |||
> tabSval : {t,n : Nat} ->
>           (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>           (gy  : GoodCtrl t x n) ->
>           (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>           PossibleNextState x (ctrl gy) -> Val
> tabSval {t} {n} x r v gy vt (MkSigma x' x'emx') =
>   let y    : Ctrl t x
>            = ctrl gy in
>   let mx'  : M (State (S t))
>            = nexts t x y in
>   let ar'  : All Reachable mx'
>            = reachableSpec1 x r y in
>   let av'  : All (Viable n) mx'
>            = allViable gy in
>   let r'   : Reachable x'
>            = allElemSpec0 x' mx' ar' x'emx' in
>   let v'   : Viable n x'
>            = allElemSpec0 x' mx' av' x'emx' in
>   let rvxs : Vect (cardReachableAndViableState (S t) n) (State (S t))
>            = map outl (vectReachableAndViableState (S t) n) in
>   let dRV  : ((x' : State (S t)) -> Dec (ReachableAndViable n x'))
>            = decidableReachableAndViable n in
>   let prf  : Elem x' (vectState (S t))
>            = toVectComplete (finiteState (S t)) x' in
>   let prf' : Elem x' rvxs
>            = filterTagSigmaLemma {P = ReachableAndViable n} dRV x' (vectState (S t)) prf (r',v') in
>   let k    : Fin (cardReachableAndViableState (S t) n)
>            -- = trace ("Lookup " ++ show n) (lookup x' rvxs prf') in
>            = lookup x' rvxs prf' in
>   reward t x y x' `plus` index k vt

> |||
> tabSval' : {t,n : Nat} ->
>            (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>            (gy  : GoodCtrl t x n) ->
>            (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>            Vect (cardState (S t)) (Fin (cardReachableAndViableState (S t) n)) ->
>            PossibleNextState x (ctrl gy) -> Val
> tabSval' {t} {n} x r v gy vt iat (MkSigma x' x'emx') =
>   let y    : Ctrl t x
>            = ctrl gy in
>   let k    : Fin (cardReachableAndViableState (S t) n)
>            = index (to (iso (finiteState (S t))) x') iat in
>   reward t x y x' `plus` index k vt

> |||
> tabCval : {t, n : Nat} ->
>           (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>           (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>           GoodCtrl t x n -> Val
> tabCval {t} x r v vt gy = let y    : Ctrl t x
>                                    = ctrl gy in
>                           let mx'  : M (State (S t))
>                                    = nexts t x y in
>                           meas (fmap (tabSval x r v gy vt) (tagElem mx'))

> {-
> tabCval' : {t, n : Nat} ->
>            (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>            (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>            Vect (cardState (S t)) (Fin (cardReachableAndViableState (S t) n)) ->
>            GoodCtrl t x n -> Val
> tabCval' {t} x r v vt iat gy = let y    : Ctrl t x
>                                         = ctrl gy in
>                                let mx'  : M (State (S t))
>                                         = nexts t x y in
>                                let tmp  : Vect (cardState (S t)) (Fin (cardReachableAndViableState (S t) n))
>                                         = iat in
>                                meas (fmap (tabSval' x r v gy vt iat) (tagElem mx'))
> -}

> |||
> tabCvalargmaxMax : {t, n : Nat} ->
>                    (x  : State t) -> .(r : Reachable x) -> .(v : Viable (S n) x) ->
>                    (vt : Vect (cardReachableAndViableState (S t) n) Val) -> (GoodCtrl t x n, Val)

> |||
> tabCvalargmax : {t, n : Nat} ->
>                 (x  : State t) -> .(r : Reachable x) -> .(v : Viable (S n) x) ->
>                 (vt : Vect (cardReachableAndViableState (S t) n) Val) -> GoodCtrl t x n

> |||
> tabOptExt : {t, n : Nat} -> (vt : ValueTable (S t) n) -> PolicyTable t (S n)
> tabOptExt {t} {n} vt =
>   let ptf  : ((k : Fin (cardReachableAndViableState t (S n))) ->
>               (Sigma (State t) (\ x => (ReachableAndViable {t = t} (S n) x, GoodCtrl t x n))))
>            = \ k => let xrvk : Sigma (State t) (ReachableAndViable {t = t} (S n))
>                              = index k (vectReachableAndViableState t (S n)) in
>                     let x    : State t
>                              = outl xrvk in
>                     let rv   : ReachableAndViable {t = t} (S n) x
>                              = outr xrvk in
>                     let gy   : GoodCtrl t x n
>                              = tabCvalargmax {t = t} {n = n} x (fst rv) (snd rv) vt in
>                     MkSigma x (rv, gy) in
>   let pt   : PolicyTable t (S n)
>            = toVect ptf in
>   pt

> |||
> tabOptExt' : {t, n : Nat} ->
>              (vt : ValueTable (S t) n) ->
>              (PolicyTable t (S n), ValueTable t (S n))
> tabOptExt' {t} {n} vt =
>   let pt    : PolicyTable t (S n)
>             = tabOptExt vt in
>   -- let tmp   = iat {t = S t} {n = n} (believe_me 42) in
>   let vtf'  : ((k : Fin (cardReachableAndViableState t (S n))) -> Val)
>             = \ k => let ptk : Sigma (State t) (\ x => (ReachableAndViable {t = t} (S n) x, GoodCtrl t x n))
>                              = index k pt in
>                      let x   : State t
>                              = outl ptk in
>                      let rv  : ReachableAndViable {t = t} (S n) x
>                              = fst (outr ptk) in
>                      let gy  : GoodCtrl t x n
>                              = snd (outr ptk) in
>                      tabCval x (fst rv) (snd rv) vt gy in
>                      -- tabCval' x (fst rv) (snd rv) vt tmp in
>   let vt'   : ValueTable t (S n)
>             = toVect vtf' in
>   (pt, vt')

... finally

> |||
> tabBackwardsInduction' : (t : Nat) -> (n : Nat) -> (PolicyTableSeq t n, ValueTable t n)
> tabBackwardsInduction' t  Z     =  (Nil, zeroVec (cardReachableAndViableState t Z))
> tabBackwardsInduction' t (S n)  =  let (pts, vt) = tabBackwardsInduction' (S t) n in
>                                    let (pt, vt') = tabOptExt' vt in
>                                    (pt :: pts, vt')

> |||
> tabBackwardsInduction : (t : Nat) -> (n : Nat) -> PolicyTableSeq t n
> tabBackwardsInduction t  Z     =  Nil
> tabBackwardsInduction t (S n)  =  let (pts, vt) = tabBackwardsInduction' (S t) n in
>                                   let pt        = tabOptExt vt in
>                                   pt :: pts

> {-

> ---}