module Sub04LTE216t153

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total

-- 6(36t+25)+3 --AE[6,-2,-4]--> 6(4t+1)+3
export
lte216t153 : (m : Nat) -> LTE (S (S ((m+m)+(m+m))))
  (S (((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m)))))) + ((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m)))))) + ((S (S ((S (m+m+m))+(S (m+m+m)))))+(S (S ((S (m+m+m))+(S (m+m+m))))))))
lte216t153 Z     = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc) LTEZero
lte216t153 (S m) =
  let lemma = lte216t153 m in

  rewrite (sym (plusSuccRightSucc m m)) in

  rewrite (sym (plusSuccRightSucc (plus m m) (S (plus m m)))) in
  rewrite (sym (plusSuccRightSucc (plus m m)    (plus m m))) in

  rewrite (sym (plusSuccRightSucc (plus m m) m)) in

  rewrite (sym (plusSuccRightSucc (plus (plus m m) m) (S (S (S (plus (plus m m) m)))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus m m) m)    (S (S (plus (plus m m) m))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus m m) m)       (S (plus (plus m m) m)))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                        (S (S (S (S (S (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                           (S (S (S (S (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                              (S (S (S (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                                 (S (S (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                                    (S (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                                       (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                        (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                           (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                              (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                 (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                       (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                          (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                             (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                                (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                                   (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                                      (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus m m) m) (S (plus (plus m m) m)))
                    (S (S (S (plus (plus (plus m m) m) (S (plus (plus m m) m)))))))
                                                         (S (S (S (plus (plus (plus (plus m m) m)
                                                                (S (plus (plus m m) m)))
                                                          (S (S (S (plus (plus (plus m m) m)
                                                                         (S (plus (plus m m)
                                                          m)))))))))))) in

  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                   (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                   (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                      (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                         (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                            (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                               (S (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                                  (S (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                                     (S (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                                        (S (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                                           (S (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m))))))))))))) in
  rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus m m) m)
                                                      (S (plus (plus m m) m)))
                                                (S (S (S (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))))))
                                          (S (S (S (plus (plus (plus (plus m m) m)
                                                               (S (plus (plus m m) m)))
                                                         (S (S (S (plus (plus (plus m m) m)
                                                                        (S (plus (plus m m) m)))))))))))
                                              (S (S (S (plus (plus (plus (plus m m) m)
                                                                     (S (plus (plus m m) m)))
                                                    (S (S (S (plus (plus (plus m m) m)
                                                          (S (plus (plus m m)
                              m)))))))))))) in

    (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module Desc
data Desc : (0 tI : Type) -> (0 tO : tI -> Type) -> Type where
  End : (i : tI) -> tO i -> Desc tI tO
  Rec : (i : tI) -> (b : tO i -> Desc tI tO) -> Desc tI tO
  Ref : (i : tA -> tI)
    -> ((o : (a : tA) -> tO (i a)) -> Desc tI tO)
    -> Desc tI tO
  Arg : (tA : Type) -> (tA -> Desc tI tO) -> Desc tI tO

el : (d : Desc tI tO)
  -> (tX : tI -> Type )
  -> (tY : {i : tI} -> tX i -> tO i)
  -> tI -> Type
el (End j o) tX tY i = i = j
el (Rec j b) tX tY i = (x : (tX j) ** el (b (tY x)) tX tY i )
el (Ref j b) tX tY i = ( f : ((a : _) -> tX (j a)) ** el (b (\a => tY (f a))) tX tY i)
el (Arg tA b) tX tY i = (a : _ ** el (b a) tX tY i)

mutual
  data Fix : (0 d : Desc tI tO) -> (i : tI) -> Type where
    init : el d (Fix d) (foldO {tI = tI} d) i  -> Fix d i

  foldO : {0 tO : tI -> Type} -> (d : Desc tI tO) -> (1 _ : Fix d i) -> tO i
  foldsO : {0 tO : tI -> Type} -> (1 d : Desc tI tO)
    -> (e : Desc tI tO) -> el d (Fix e) (foldO e) i
    -> tO i

  foldO d (init xs) = foldsO d d xs
  foldsO (End j o) e Refl = o
  foldsO (Rec j b) e (x ** xs) = foldsO (b (foldO e x)) e xs
  foldsO (Ref j b) e (f ** xs) = foldsO (b (\a => foldO e (f a))) e xs
  foldsO (Arg tA b) e (a ** xs) = foldsO (b a) e xs

tHyps : (1 d : Desc tI tO) -> (tX : tI -> Type) -> (tY : {i : tI} -> tX i -> tO i)
  -> (p : {0 i : tI} -> tX i -> Type) -> (i : tI) -> (xs : el d tX tY i) -> Type
tHyps (End j o) tX tY p i x = ()
tHyps (Rec j d) tX tY p i (x ** xs) = (p x , tHyps (d (tY x)) tX tY p i xs)
tHyps (Ref j d) tX tY p i (f ** xs) = ((a : _) -> p (f a) , tHyps (d (\a => tY (f a))) tX tY p i xs)
tHyps (Arg tA b) tX tY p i (a ** xs) = tHyps (b a) tX tY p i xs

mutual
  ind : (d : Desc tI tO)
        -> (0 p : {i : _} -> Fix d i -> Type )
        -> (alpha : {i : _}
              -> (xs : el d (Fix d) (foldO d) i)
              -> (ihs : tHyps d (Fix d) (foldO d) p i xs)
              -> (p (init {i = i} xs)))
        -> {i : tI} -> (x : Fix d i) -> (p x)

  hyps : (d : Desc tI tO) -> (e : Desc tI tO)
    -> (0 p : {i : _} -> Fix e i -> Type)
    -> (alpha : {i : _}
      -> (xs : el e (Fix e) (foldO e) i)
      -> (ihs : tHyps e (Fix e) (foldO e) p i xs)
      -> p (init {i = i} xs))
    -> {i : tI} -> (xs : el d (Fix e) (foldO e) i)
    -> tHyps d (Fix e) (foldO e) p i xs

  ind d p alpha (init xs) = alpha xs (hyps d d p alpha xs)

  hyps (End i o) e p alpha x = ()
  hyps (Rec i b) e p alpha (x ** xs) = (ind e p alpha x , hyps (b (foldO e x)) e p alpha xs)
  hyps (Ref i b) e p alpha (f ** xs) = ((\a => ind e p alpha (f a)), hyps (b (\a => foldO e (f a))) e p alpha xs )
  hyps (Arg tA b) e p alpha (a ** xs) = hyps (b a) e p alpha xs


module Decidable.Equality.Indexed

%default total
%access public export

interface DecEq iTy
       => DecEqIdx (iTy : Type)
                   (eTy : iTy -> Type) | eTy
  where
     decEq : {i,j : iTy}
          -> (x : eTy i)
          -> (y : eTy j)
          -> (prf : i = j)
          -> Dec (x = y)


> module InfiniteHorizonSequentialDecisionProblems.Lala

> import Data.Vect
> import Syntax.PreorderReasoning

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

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

* ---------
* Sequences
* ---------

> Seq : Type -> Type
> Seq A = Nat -> A

> head : {A : Type} -> Seq A -> A
> head f = f Z

> tail : {A : Type} -> Seq A -> Seq A
> tail f = f . S

> cons : {A : Type} -> A -> Seq A -> Seq A
> cons a f    Z  = a
> cons a f (S n) = f n

> headLemma : {A : Type} -> (a : A) -> (f : Seq A) -> head (cons a f) = a
> headLemma a f = Refl

> tailLemma : {A : Type} -> (a : A) -> (f : Seq A) -> tail (cons a f) = f
> tailLemma a d = Refl

> consLemma : {A : Type} -> (f : Seq A) -> (n : Nat) -> cons (head f) (tail f) n = f n
> consLemma f    Z  = Refl
> consLemma f (S n) = Refl

* ---------
* Fix point
* ---------

> FixPoint : {X : Type} -> X -> (X -> X) -> Type
> FixPoint x f = x = f x

* ----------------------------
* Sequential decision problems
* ----------------------------

> State  :  Type
> Ctrl   :  (x : State) -> Type
> next   :  (x : State) -> (y : Ctrl x) -> State
> Val    :  Type
> reward :  (x : State) -> (y : Ctrl x) -> State -> Val
> (<+>)  :  Val -> Val -> Val
> LTE    :  Val -> Val -> Type

* --------------------------------------
* Policies and infinite policy sequences
* --------------------------------------

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

> PolicySeq  :  Type
> -- PolicySeq  =  Nat -> Policy
> PolicySeq  =  Seq Policy

* ---------------------------------------
* The value of infinite policiy sequences
* ---------------------------------------

The value of making infinite many decision steps with a policy sequence
by starting from a given state is given by a "value" function

> val : PolicySeq -> State -> Val

that fulfils the specification

> valSpec  :  Type
> valSpec  =  (ps : PolicySeq) -> (x : State) ->
>             val ps x = reward x (head ps x) (next x (head ps x))
>             <+>
>             val (tail ps) (next x (head ps x))

A naive attempt at implementing |val| directly "from its specification"

< val ps x = reward x (head ps x) (next x (head ps x)) <+> val (tail ps) (next x (head ps x))

yiels a possibly non total function. In contrast to SDPs with a finite
number of decision steps, we cannot rely on an induction principle for
decision problems over an infinite number of steps. Obviously, there are
cases in which |val| can be implemented. For instance, if all states
have the same successor. An important case is when |State| is finite. We
discuss this case below.

* ------------------------------
* Optimality of policy sequences
* ------------------------------

> Opt     :  PolicySeq -> Type
> Opt ps  =  (ps' : PolicySeq) -> (x : State) -> val ps' x `LTE` val ps x

* ------------------------
* Optimal policy sequences
* ------------------------

Let |LTE| be a preorder

> reflexiveLTE     :  (a : Val) -> a `LTE` a
> transitiveLTE    :  {a, b, c : Val} -> a `LTE` b -> b `LTE` c -> a `LTE` c

and let |<+>| be monotonous w.r.t. |LTE|

> monotonePlusLTE  :  {a, b, c, d : Val} -> a `LTE` b -> c `LTE` d -> (a <+> c) `LTE` (b <+> d)

We can compute the value of making a first decision step with a given
control and then infinitely many further steps with a given policy
sequence in terms of the (yet to be implemented) |val| function:

> cval         :  (ps : PolicySeq) -> (x : State) -> Ctrl x -> Val
> cval ps x y  =  reward x y (next x y) <+> val ps (next x y)

Assume that, for an arbitrary policy sequence |ps| and for an arbitrary
state |x|, we can pick up a control that maximises |cval ps x|:

> cvalmax         :  (ps : PolicySeq) -> (x : State) -> Val
> cvalargmax      :  (ps : PolicySeq) -> (x : State) -> Ctrl x

> cvalargmaxSpec  :  (ps : PolicySeq) -> (x : State) -> cvalmax ps x = cval ps x (cvalargmax ps x)
> cvalmaxSpec     :  (ps : PolicySeq) -> (x : State) -> (y : Ctrl x) -> cval ps x y `LTE` cvalmax ps x

This is certainly the case if |Ctrl x| is non empty and finite for any
|x| but there are more interesting cases in which we can compute "best"
controls. In these cases, we can compute policies that are optimal
extensions of arbitrary policy sequences:

> OptExt : Policy -> PolicySeq -> Type
> OptExt p ps = (p' : Policy) -> (x : State) -> val (cons p' ps) x `LTE` val (cons p ps) x

> optExt : (ps : PolicySeq) -> Policy
> optExt = cvalargmax

> optExtLemma : (ps : PolicySeq) -> (optExt ps) `OptExt` ps
> optExtLemma ps p' x = s5 where
>   p  : Policy
>   p  = optExt ps
>   s1 : cval ps x (p' x) `LTE` cvalmax ps x
>   s1 = cvalmaxSpec ps x (p' x)
>   s2 : reward x (p' x) (next x (p' x)) <+> val ps (next x (p' x))  `LTE` cvalmax ps x
>   s2 = s1
>   s3 : reward x (p' x) (next x (p' x)) <+> val ps (next x (p' x))  `LTE` cval ps x (p x)
>   s3 = replace {P = \ X => reward x (p' x) (next x (p' x)) <+> val ps (next x (p' x))  `LTE` X} (cvalargmaxSpec ps x) s2
>   s4 : reward x (p' x) (next x (p' x)) <+> val ps (next x (p' x))  `LTE` reward x (p x) (next x (p x)) <+> val ps (next x (p x))
>   s5 : val (cons p' ps) x `LTE` val (cons p ps) x
>   s5 = ?s5prf -- via valSpec, headLemma, tailLemma

This is interesting because of

> Bellman  :  (ps  :  PolicySeq)  ->   Opt ps ->
>             (p   :  Policy)     ->   p `OptExt` ps ->
>             Opt (cons p ps)
> Bellman ps ops p oep = opps where
>   opps : Opt (cons p ps)
>   opps ps' x = s7 where
>     p'   : Policy
>     p'   = head ps'
>     ps'' : PolicySeq
>     ps'' = tail ps'
>     s4   : val (cons p' ps'') x `LTE` val (cons p' ps) x
>     s4   = ?s4prf
>     s5   : val (cons p' ps) x `LTE` val (cons p ps) x
>     s5   = ?s5prf
>     s6   : val (cons p' ps'') x `LTE` val (cons p ps) x
>     s6   = transitiveLTE s4 s5
>     s7   : val ps' x `LTE` val (cons p ps) x
>     s7   = ?s7prf -- via valSpec, consLemma, ...

I am not sure that this is going to help us but it looks remarkably
similar to the finite horizon case. Perhaps a first step towards
something like

> piter : (Policy, PolicySeq) -> (Policy, PolicySeq)
> piter (p, ps) = (optExt ps, cons (optExt ps) ps)

> piterLemma : (p : Policy) -> (ps : PolicySeq) ->
>              (p, ps) `FixPoint` piter ->
>              (n : Nat) -> ps n = p
> piterLemma p ps fp  Z    = ( ps Z )
>                          ={ Refl }=
>                            ( head ps )
>                          ={ cong (pairEqElimSnd fp) }=
>                            ( head (cons (optExt ps) ps) )
>                          ={ headLemma (optExt ps) ps }=
>                            ( optExt ps )
>                          ={ sym (pairEqElimFst fp) }=
>                            ( p )
>                          QED
> piterLemma p ps fp (S m) = ( ps (S m) )
>                          ={ sym (consLemma ps (S m)) }=
>                            ( cons (head ps) (tail ps) (S m) )
>                          ={ Refl }=
>                            ( (tail ps) m )
>                          ={ replace {P = \ X => (tail ps) m = (tail X) m} (pairEqElimSnd fp) Refl }=
>                            ( (tail (cons (optExt ps) ps)) m )
>                          ={ replace {P = \ X => (tail (cons (optExt ps) ps)) m = (tail (cons X ps)) m} (sym (pairEqElimFst fp)) Refl }=
>                            ( (tail (cons p ps)) m )
>                          ={ replace {P = \ X => (tail (cons p ps)) m = X m} (tailLemma p ps) Refl }=
>                            ( ps m )
>                          ={ piterLemma p ps fp m }=
>                            ( p )
>                          QED

> Conj : (p : Policy) -> (ps : PolicySeq) ->
>        (p, ps) `FixPoint` piter ->
>        Opt (cons p ps)
> Conj p ps fp = opps where
>   opps : Opt (cons p ps)
>   opps = s9 where
>     s0 : (p, ps) = (optExt ps, cons (optExt ps) ps)
>     s0 = fp
>     s1 : p = optExt ps
>     s1 = pairEqElimFst s0
>     s2 : ps = cons (optExt ps) ps
>     s2 = pairEqElimSnd s0
>     s3 : ps = cons p ps
>     s3 = replace {P = \ X => ps = cons X ps} (sym s1) s2
>     s4 : (optExt ps) `OptExt` ps
>     s4 = optExtLemma ps
>     s5 : p `OptExt` ps
>     s5 = replace {P = \ X => X `OptExt` ps} (sym s1) s4
>     s9 : Opt (cons p ps)
>     s9 = Bellman ps ops p oep where
>       ops : Opt ps
>       ops = assert_total (replace {P = \ X => Opt X} (sym s3) s9)
>       oep : p `OptExt` ps
>       oep = s5

> {-

> ---}


module STLC

import Pruviloj
import Pruviloj.Derive.DecEq

%hide Abs
%hide lookup

%language ElabReflection
%default total
%access public export

data Typ
    = Base
    | Arrow Typ Typ

Show Typ where
    show Base = "A"
    show (Arrow ty1 ty2) = (show ty1) ++ "->" ++ (show ty2)

Uninhabited (Base = Arrow _ _) where
    uninhabited Refl impossible

decEqTyp : (ty1, ty2 : Typ) -> Dec (ty1 = ty2)
%runElab (deriveDecEq `{decEqTyp})

DecEq Typ where
    decEq = decEqTyp

data Term
    = Var String
    | Abs String Typ Term
    | App Term Term

Show Term where
    show (Var x) = x
    show (Abs x ty t) = "\\" ++ x ++ " : " ++ (show ty) ++ ". " ++ (show t)
    show (App t1 t2) = (helper t1) ++ " " ++ (helper t2)
        where
            helper (Var x) = x
            helper t = "(" ++ show t ++ ")"
data Value : Term -> Type where
    AbsVal : Value (Abs _ _ _)

Uninhabited (Value (Var _)) where
    uninhabited _ impossible

Uninhabited (Value (App _ _)) where
    uninhabited _ impossible

Ctx : Type
Ctx = List (String, Typ)

data In : (String, Typ) -> Ctx -> Type where
    Here : In (x, ty) ((x, ty)::ctx)
    There : (x = y -> Void) -> In (y, ty1) ctx -> In (y, ty1) ((x, ty2)::ctx)

Uninhabited (In x []) where
    uninhabited _ impossible

inDrop : (x = y -> Void) -> In (x, tt1) ((y, tt2)::ctx) -> In (x, tt1) ctx
inDrop p Here = absurd (p Refl)
inDrop _ (There _ pi) = pi

lookup : (x : String) -> (ctx : Ctx) -> Dec (ty ** In (x, ty) ctx)
lookup _ [] = No (\ (_ ** pi) => uninhabited pi)
lookup x ((y, ty1) :: ctx) with (decEq x y)
    lookup x ((x, ty1) :: ctx) | (Yes Refl) = Yes (ty1 ** Here)
    | (No contra1) with (lookup x ctx)
        | (Yes (ty ** pi)) = Yes (ty ** There (contra1 . sym) pi)
        | (No contra2) = No (\(ty1 ** pi1) =>
            contra2 (ty1 ** inDrop contra1 pi1))

Subset : {z : (String, Typ)} -> (ctx1, ctx2 : Ctx) -> Type
Subset {z = z} ctx1 ctx2 = In z ctx1 -> In z ctx2

subsetNil : Subset [] ctx
subsetNil _ impossible

subsetCons : ({z : (String, Typ)} -> Subset {z = z} ctx1 ctx2) -> Subset ((x, ty)::ctx1) ((x, ty)::ctx2)
subsetCons _ Here = Here
subsetCons ps (There p pi) =
    There p (ps pi)

subsetDrop : Subset ((x, ty1)::(x, ty2)::ctx) ((x, ty1)::ctx)
subsetDrop Here = Here
subsetDrop (There p Here) = absurd (p Refl)
subsetDrop (There p (There _ pi)) = There p pi

subsetSwap : (x = y -> Void) -> Subset ((y, ty1)::(x, ty2)::ctx) ((x, ty2)::(y, ty1)::ctx)
subsetSwap p Here = There p Here
subsetSwap _ (There _ Here) = Here
subsetSwap _ (There p1 (There p2 pi)) = There p2 (There p1 pi)

inUniqueType : In (x, ty1) ctx -> In (x, ty2) ctx -> ty1 = ty2
inUniqueType Here Here = Refl
inUniqueType Here (There p _) = absurd (p Refl)
inUniqueType (There p _) Here = absurd (p Refl)
inUniqueType (There _ pi1) (There _ pi2) = inUniqueType pi1 pi2

data Typed : Ctx -> Term -> Typ -> Type where
    TVar : In (x, ty) ctx -> Typed ctx (Var x) ty
    TAbs : Typed ((x, ty1) :: ctx) t2 ty2 -> Typed ctx (Abs x ty1 t2) (Arrow ty1 ty2)
    TApp : Typed ctx t1 (Arrow ty1 ty2) -> Typed ctx t2 ty1 -> Typed ctx (App t1 t2) ty2

Uninhabited (Typed [] (Var _) _) where
    uninhabited (TVar _) impossible

typedChange : Typed ctx1 t ty -> ({z : (String, Typ)} -> Subset {z = z} ctx1 ctx2) -> Typed ctx2 t ty
typedChange (TVar pi) ps = TVar (ps pi)
typedChange (TAbs pt) ps = TAbs (typedChange pt (subsetCons ps))
typedChange (TApp pt1 pt2) ps =
    let ih1 = typedChange pt1 ps in
    let ih2 = typedChange pt2 ps in
    TApp ih1 ih2

typedWeaken : Typed [] t ty -> Typed ctx t ty
typedWeaken pt = typedChange pt subsetNil

typedDrop : Typed ((x, ty1)::(x, ty2)::ctx) t ty -> Typed ((x, ty1)::ctx) t ty
typedDrop pt = typedChange pt subsetDrop

typedSwap : (x = y -> Void) -> Typed ((y, ty1)::(x, ty2)::ctx) t ty -> Typed ((x, ty2)::(y, ty1)::ctx) t ty
typedSwap pe pt = typedChange pt (subsetSwap pe)

typedUniqueType : (Typed ctx t ty1) -> (Typed ctx t ty2) -> ty1 = ty2
typedUniqueType (TVar pi1) (TVar pi2) = inUniqueType pi1 pi2
typedUniqueType (TAbs pt1) (TAbs pt2) with (typedUniqueType pt1 pt2)
    | Refl = Refl
typedUniqueType (TApp pt1 _) (TApp pt2 _) with (typedUniqueType pt1 pt2)
    | Refl = Refl

subst : String -> Term -> Term -> Term
subst x s (Var y) with (decEq x y)
    | (Yes _) = s
    | (No _) = Var y
subst x s (Abs y ty t) with (decEq x y)
    | (Yes _) = Abs x ty t
    | (No _) = Abs y ty (subst x s t)
subst x s (App t1 t2) = App (subst x s t1) (subst x s t2)

data Eval : Term -> Term -> Type where
    EApp1 : Eval t1 t1' -> Eval (App t1 t2) (App t1' t2)
    EApp2 : Value v1 -> Eval t2 t2' -> Eval (App v1 t2) (App v1 t2')
    EAppAbs : Value v2 -> t1' = subst x v2 t1 -> Eval (App (Abs x ty t1) v2) t1'

progress : (t : Term) -> Typed [] t ty -> Either (Value t) (t' ** Eval t t')
progress (Var _) (TVar _) impossible
progress (Abs _ _ _) (TAbs _) = Left AbsVal
progress (App t1 t2) (TApp pt1 pt2) with (progress t1 pt1)
    | (Right (t1' ** pe)) = Right ((App t1' t2) ** EApp1 pe)
    | (Left pv1) with (progress t2 pt2)
        | (Right (t2' ** pe)) = Right ((App t1 t2') ** EApp2 pv1 pe)
        | (Left pv2) with (pv1)
            progress (App (Abs x _ t) t2) _ | _ | (Left pv2) | AbsVal =
                Right (subst x t2 t ** EAppAbs pv2 Refl)

substyyped : {x : String} -> {s : Term} -> (t : Term) -> Typed [] s ty1 -> Typed ((x, ty1) :: ctx) t ty2 -> Typed ctx (subst x s t) ty2
substyyped {x=x} (Var y) pt1 pt2 with (decEq x y)
    substyyped _ pt1 (TVar Here) | (Yes Refl) = typedWeaken pt1
    substyyped _ _ (TVar (There peq _)) | (Yes Refl) = absurd (peq Refl)
    substyyped _ _ (TVar Here) | (No contra) = absurd (contra Refl)
    substyyped _ _ (TVar (There _ pi)) | (No contra) = TVar pi
substyyped {x=x} (Abs y _ t) pt1 (TAbs pt2) with (decEq x y)
    substyyped _ _ (TAbs pt2) | (Yes Refl) = TAbs (typedDrop pt2)
    substyyped (Abs _ _ t) pt1 (TAbs pt2) | (No pe) =
        let ih = substyyped t pt1 (typedSwap pe pt2) in
        TAbs ih
substyyped (App t1 t2) pt1 (TApp pt2 pt3) =
    let ih1 = substyyped t1 pt1 pt2 in
    let ih2 = substyyped t2 pt1 pt3 in
    TApp ih1 ih2

preservation : (t : Term) -> Typed [] t ty -> Eval t t' -> Typed [] t' ty
preservation (App t1 _) (TApp pt1 pt2) (EApp1 pe) =
    TApp (preservation t1 pt1 pe) pt2
preservation (App (Abs _ _ _) t2) (TApp pt1 pt2) (EApp2 AbsVal pe) =
    TApp pt1 (preservation t2 pt2 pe)
preservation (App (Abs _ _ t1) _) (TApp (TAbs pt1) pt2) (EAppAbs _ peq) =
    rewrite peq in
    substyyped t1 pt2 pt1

data LongEval : Term -> Term -> Type where
    LValue : Value v -> LongEval v v
    LEval : Eval t1 t2 -> LongEval t2 t3 -> LongEval t1 t3

partial
eval' : (t : Term) -> Typed [] t ty -> (t' ** LongEval t t')
eval' t pt with (progress t pt)
    | (Left vt) = (t ** LValue vt)
    | (Right (t' ** pe)) =
        let (t2 ** ple) = eval' t' (preservation t pt pe) in
        (t2 ** LEval pe ple)

typecheckLemma : Typed ctx (App t1 t2) ty -> Typed ctx t1 (Arrow ty1 ty2) -> Typed ctx t2 ty3 -> ty1 = ty3
typecheckLemma (TApp pt1 pt2) pt3 pt4 with (typedUniqueType pt1 pt3)
    | Refl with (typedUniqueType pt2 pt4)
        | Refl = Refl

typecheck : (t : Term) -> (ctx : Ctx) -> Dec (ty ** Typed ctx t ty)
typecheck (Var x) ctx with (lookup x ctx)
    | (Yes (ty ** pi)) = Yes (ty ** TVar pi)
    | (No contra) = No (\(ty ** TVar pi) => contra (ty ** pi))
typecheck (Abs x ty1 t) ctx with (typecheck t ((x, ty1)::ctx))
    | (Yes (ty2 ** pt)) = Yes (Arrow ty1 ty2 ** TAbs pt)
    | (No contra) = No (\(Arrow _ ty4 ** TAbs pt) => contra (ty4 ** pt))
typecheck (App t1 t2) ctx with (typecheck t1 ctx)
    | (No contra) = No (\(ty ** TApp pt1 _) => contra (Arrow _ ty ** pt1))
    | (Yes (Base ** pt)) =
        No (\(_ ** TApp pt1 _) => uninhabited (typedUniqueType pt pt1))
    | (Yes (Arrow ty1 ty2 ** pt1)) with (typecheck t2 ctx)
        | (No contra) = No (\(_ ** TApp _ pt2) => contra (_ ** pt2))
        | (Yes (ty3 ** pt2)) with (decEq ty1 ty3)
            | (No contra) = No (\(ty ** pt3) =>
                contra (typecheckLemma pt3 pt1 pt2))
            | (Yes p) = Yes (ty2 ** TApp pt1 (rewrite p in pt2))
partial
eval : (t : Term) -> Either ((ty ** Typed [] t ty), (t' ** LongEval t t')) ((ty ** Typed [] t ty) -> Void)
eval t with (typecheck t [])
    | (Yes (ty ** pt)) = Left ((ty ** pt), (eval' t pt))
    | (No contra) = Right contra

partial
evalForget : Term-> Maybe Term
evalForget t with (eval t)
    | Left ((_ ** _), (t' ** _)) = Just t'
    | Right _ = Nothing


module Main

import Control.Monad.State
import Data.List
import Data.Nat
import Data.Nat.Views
import Data.Strings
import Data.Vect
import System.File

import Data.SortedMap
import Text.Lexer
import Text.Lexer.Core
import Text.Parser
import Text.Parser.Core
import Text.Token

data Bit = Zero
         | One

Eq Bit where
  Zero == Zero = True
  One == One = True
  _ == _ = False

Ord Bit where
  compare Zero Zero = EQ
  compare Zero One = LT
  compare One Zero = GT
  compare One One = EQ

Show Bit where
  show Zero = "Zero"
  show One = "One"

Bits : Type
Bits = Vect 36 Bit

record Mask where
  constructor MkMask
  bits : Vect 36 (Maybe Bit)

Show Mask where
  show (MkMask bits) = "Mask " ++ show bits

record Mem where
  constructor MkMem
  address : Nat
  value : Bits

Show Mem where
  show (MkMem address value) = "Mem " ++ show address ++ " " ++ show value

Line : Type
Line = Either Mask Mem

Program : Type
Program = List Line

Memory : Type
Memory = SortedMap Nat Bits

applyMask : Mask -> Bits -> Bits
applyMask (MkMask maskBits) valBits = f <$> maskBits <*> valBits where
  f : Maybe Bit -> Bit -> Bit
  f Nothing x = x
  f (Just x) _ = x

initState : (Mask, Memory)
initState = (MkMask $ pure Nothing, empty)

progLine : Line -> State (Mask,Memory) ()
progLine (Left mask) = do
  (oldMask, memory) <- get
  put (mask, memory)
progLine (Right (MkMem address value)) = do
  (mask, oldMemory) <- get
  let memory = insert address (applyMask mask value) oldMemory
  put (mask, memory)

bitsToNat : Bits -> Nat
bitsToNat = bitsToNat' . reverse where
  bitsToNat' : Vect n Bit -> Nat
  bitsToNat' [] = 0
  bitsToNat' (One :: xs) = 1 + 2 * bitsToNat' xs
  bitsToNat' (Zero :: xs) = 0 + 2 * bitsToNat' xs

integerToBits : {n : Nat} -> Integer -> Vect n Bit
integerToBits x with (n)
  integerToBits x | Z = []
  integerToBits x | (S k) = if x `mod` 2 == 0
                           then Zero :: integerToBits (x `div` 2)
                           else One :: integerToBits (x `div` 2)

natToBits : Nat -> Bits
natToBits n = integerToBits $ natToInteger n

Memory' : Type
Memory' = SortedMap Bits Bits

initState' : (Mask, Memory')
initState' = (MkMask $ pure Nothing, empty)

applyMaskToAddress' : Vect n (Maybe Bit) -> Vect n Bit -> Vect n (Maybe Bit)
applyMaskToAddress' [] [] = []
applyMaskToAddress' (Just Zero :: ms) (a :: as) = Just a :: applyMaskToAddress' ms as
applyMaskToAddress' (Just One :: ms) (_ :: as) = Just One :: applyMaskToAddress' ms as
applyMaskToAddress' (Nothing :: ms) (_ :: as) = Nothing :: applyMaskToAddress' ms as

floatingAddresses : Vect n (Maybe Bit) -> List (Vect n Bit)
floatingAddresses [] = pure []
floatingAddresses (Nothing :: xs) = (::) <$> [ Zero, One ] <*> floatingAddresses xs
floatingAddresses (Just x :: xs) = (x ::) <$> floatingAddresses xs

applyMaskToAddress : Mask -> Bits -> List Bits
applyMaskToAddress (MkMask mask) bs = floatingAddresses $ applyMaskToAddress' mask bs

inserter : Bits -> (key : Bits) -> State (Mask,Memory') ()
inserter value k = do
  (mask, memory) <- get
  let newMemory = insert k value memory
  put (mask, newMemory)

progLine' : Line -> State (Mask,Memory') ()
progLine' (Left mask) = do
  (oldMask, memory) <- get
  put (mask, memory)
progLine' (Right (MkMem address value)) = do
  (mask, memory) <- get
  let addresses = applyMaskToAddress mask $ natToBits address
  traverse_ (inserter value) addresses
  pure ()

namespace Parsing
  data DataKind = DKMask
                | DKMem
                | DKBracketOpen
                | DKBracketClose
                | DKSpace
                | DKEquals
                | DKNewline
                | DKNoBit
                | DKDigit

  Eq DataKind where
    (==) DKMask DKMask = True
    (==) DKMem DKMem = True
    (==) DKBracketOpen DKBracketOpen = True
    (==) DKBracketClose DKBracketClose = True
    (==) DKSpace DKSpace = True
    (==) DKEquals DKEquals = True
    (==) DKNewline DKNewline = True
    (==) DKNoBit DKNoBit = True
    (==) DKDigit DKDigit = True
    (==) _ _ = False

  export
  Show DataKind where
    show DKMask = "DKMask"
    show DKMem = "DKMem"
    show DKBracketOpen = "DKBracketOpen"
    show DKBracketClose = "DKBracketClose"
    show DKSpace = "DKSpace"
    show DKEquals = "DKEquals"
    show DKNewline = "DKNewline"
    show DKNoBit = "DKNoBit"
    show DKDigit = "DKDigit"

  data Digit = D0
             | D1
             | D2
             | D3
             | D4
             | D5
             | D6
             | D7
             | D8
             | D9

  Cast String Digit where
    cast "0" = D0
    cast "1" = D1
    cast "2" = D2
    cast "3" = D3
    cast "4" = D4
    cast "5" = D5
    cast "6" = D6
    cast "7" = D7
    cast "8" = D8
    cast "9" = D9
    cast _ = ?cantCastNonDigit

  TokenKind DataKind where
    TokType DKMask = ()
    TokType DKMem = ()
    TokType DKBracketOpen = ()
    TokType DKBracketClose = ()
    TokType DKSpace = ()
    TokType DKEquals = ()
    TokType DKNewline = ()
    TokType DKNoBit = ()
    TokType DKDigit = Digit
    tokValue DKMask _ = ()
    tokValue DKMem _ = ()
    tokValue DKBracketOpen _ = ()
    tokValue DKBracketClose _ = ()
    tokValue DKSpace _ = ()
    tokValue DKEquals _ = ()
    tokValue DKNewline _ = ()
    tokValue DKNoBit _ = ()
    tokValue DKDigit str = cast str

  export
  tokenMap : TokenMap $ Token DataKind
  tokenMap = toTokenMap
    [ (exact "mask", DKMask)
    , (exact "mem", DKMem)
    , (is '[', DKBracketOpen)
    , (is ']', DKBracketClose)
    , (newline, DKNewline)
    , (space, DKSpace)
    , (is '=', DKEquals)
    , (is 'X', DKNoBit)
    , (digit, DKDigit)
    ]

  digitsToNat : List Digit -> Nat
  digitsToNat [] = 0
  digitsToNat (x :: xs) = digitToNat x + 10 * digitsToNat xs where
    digitToNat : Digit -> Nat
    digitToNat D0 = 0
    digitToNat D1 = 1
    digitToNat D2 = 2
    digitToNat D3 = 3
    digitToNat D4 = 4
    digitToNat D5 = 5
    digitToNat D6 = 6
    digitToNat D7 = 7
    digitToNat D8 = 8
    digitToNat D9 = 9

  grammarMem : Grammar (Token DataKind) True Mem
  grammarMem = do
    match DKMem
    match DKBracketOpen
    digitsAddress <- some $ match DKDigit
    let address = digitsToNat $ reverse digitsAddress
    match DKBracketClose
    match DKSpace
    match DKEquals
    match DKSpace
    MkMem address <$> grammarVal where
      grammarVal : Grammar (Token DataKind) True Bits
      grammarVal = (reverse . natToBits . digitsToNat . reverse) <$> (some $ match DKDigit)

  countExactly : (n : Nat) -> (p : Grammar tok True a) -> Grammar tok (isSucc n) (Vect n a)
  countExactly Z p = Empty []
  countExactly (S k) p = [| p :: countExactly k p |]

  grammarMbBit : Grammar (Token DataKind) True (Maybe Bit)
  grammarMbBit = Just <$> grammarDig <|> grammarX where
    grammarDig : Grammar (Token DataKind) True Bit
    grammarDig = do
      n <- match DKDigit
      f n where
        f : Digit -> Grammar (Token DataKind) False Bit
        f D0 = pure Zero
        f D1 = pure One
        f _ = fail "Can't parser bit other than 0 or 1"
    grammarX : Grammar (Token DataKind) True (Maybe Bit)
    grammarX = match DKNoBit *> pure Nothing

  grammarMask : Grammar (Token DataKind) True Mask
  grammarMask = do
    match DKMask
    match DKSpace
    match DKEquals
    match DKSpace
    bits <- countExactly 36 $ grammarMbBit
    pure $ MkMask bits

  grammarLine : Grammar (Token DataKind) True Line
  grammarLine = (Left <$> grammarMask <|> Right <$> grammarMem) <* match DKNewline

  export
  grammarData : Grammar (Token DataKind) True Program
  grammarData = some grammarLine <* eof

main : IO ()
main = do
  inputData <- readFile "./data"
  case inputData of
       Left err => print err
       Right actualData => do
         let (lexed, debugLexed) = lex tokenMap actualData
             parsed = parse grammarData $ tok <$> lexed
         case parsed of
              Left (Error err restToks) => do
                print $ text <$> restToks
                print err
              Right (prog, rest) => do
                --let (endMask, endMemory) = execState initState (traverse_ progLine prog)
                let (endMask, endMemory) = execState initState' (traverse_ progLine' prog)
                print $ sum $ bitsToNat <$> endMemory
         pure ()
  pure ()


module Simple

%default total

public export
data LSys : a -> Type where
  MkLSys : List a -> (a -> List a) -> LSys a

iterate : Nat -> LSys a -> List a
iterate Z (MkLSys axiom _) = axiom
iterate n (MkLSys axiom rules) = go n axiom
  where
    go : Nat -> List a -> List a
    go Z word = word
    go (S n) word = let nextWord = word >>= rules
                     in go n nextWord

----------------
-- An example --
----------------

data Algae = A | B

Show Algae where
  show A = "A"
  show B = "B"

algaeRules : Algae -> List Algae
algaeRules A = [A, B]
algaeRules B = pure A

algaeExample : LSys Algae
algaeExample = MkLSys [A] algaeRules

main : IO ()
main = print $ Simple.iterate 10 algaeExample


module Data.List.Algebra

import Control.Algebra
import Data.List

%default total

public export
SemigroupV (List ty) where
  semigroupOpIsAssociative = appendAssociative

public export
MonoidV (List ty) where
  monoidNeutralIsNeutralL = appendNilRightNeutral
  monoidNeutralIsNeutralR _ = Refl


module DataStore

import Data.Vect

infixr 5 .+.

public export
data Schema = SString | SInt | (.+.) Schema Schema

public export
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

export
record DataStore (schema : Schema) where
    constructor MkData
    size : Nat
    items : Vect size (SchemaType schema)

export
empty : DataStore schema
empty = MkData 0 []

export
addToStore : (value : SchemaType schema) -> (store : DataStore schema) -> DataStore schema
addToStore value (MkData _ items) = MkData _ (value :: items)

public export
data StoreView : DataStore schema -> Type where
    SNil : StoreView empty
    SAdd : (rec : StoreView store) -> StoreView (addToStore value store)

storeViewHelp : (items : Vect size (SchemaType schema)) -> StoreView (MkData size items)
storeViewHelp [] = SNil
storeViewHelp (val :: xs) = SAdd (storeViewHelp xs)

export
storeView : (store : DataStore schema) -> StoreView store
storeView (MkData size items) = storeViewHelp items


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
module BayesianOptimization.Acquisition

import public Data.Nat
import Distribution
import Tensor
import Data
import Model
import Optimize
import BayesianOptimization.Morphisms
import Error

||| An `Empiric` constructs values from historic data and the model over that data.
|||
||| @features The shape of the feature domain.
||| @out The type of the value constructed by the `Empiric`.
public export 0
Empiric : Distribution targets marginal => (0 features : Shape) -> (0 out : Type) -> Type
Empiric features out = Dataset features targets -> ProbabilisticModel features {marginal} -> out

||| An `Acquisition` function quantifies how useful it would be to query the objective at a given
||| set of points, towards the goal of optimizing the objective.
|||
||| @batch_size The number of points in the feature domain that the `Acquisition` evaluates
|||   at once.
||| @features The shape of the feature domain.
public export 0
Acquisition : (0 batch_size : Nat) -> {auto 0 _ : GT batch_size 0} -> (0 features : Shape) -> Type
Acquisition batch_size features = Tensor (batch_size :: features) Double -> Tensor [] Double

||| Construct the acquisition function that estimates the absolute improvement in the best
||| observation if we were to evaluate the objective at a given point.
|||
||| @model The model over the historic data.
||| @best The current best observation.
export
expectedImprovement : ProbabilisticModel features {marginal=Gaussian [1]} ->
                      (best : Tensor [] Double) -> Acquisition 1 features
expectedImprovement predict best at =
  let marginal = predict at
      best' = broadcast {to=[_, 1]} best
      pdf = pdf marginal best'
      cdf = cdf marginal best'
      mean = squeeze (mean marginal)
      variance = squeeze (variance marginal)
   in (best - mean) * cdf + variance * pdf

||| Build an acquisition function that returns the absolute improvement, expected by the model, in
||| the observation value at each point.
export
expectedImprovementByModel : Empiric features {marginal=Gaussian [1]} $ Acquisition 1 features
expectedImprovementByModel (MkDataset query_points _) predict at =
  let best = squeeze $ reduce_min 0 $ mean $ predict query_points
   in expectedImprovement predict best at

||| Build an acquisition function that returns the probability that any given point will take a
||| value less than the specified `limit`.
export
probabilityOfFeasibility : (limit : Tensor [] Double) -> ClosedFormDistribution [1] d =>
                           Empiric features {marginal=d} $ Acquisition 1 features
probabilityOfFeasibility limit _ predict at = cdf (predict at) $ broadcast {to=[_, 1]} limit

||| Build an acquisition function that returns the negative of the lower confidence bound of the
||| probabilistic model. The variance contribution is weighted by a factor `beta`.
|||
||| @beta The weighting given to the variance contribution. If negative, this function will return
|||   `Nothing`.
export
negativeLowerConfidenceBound : (beta : Double) ->
  Either ValueError $ Empiric features {marginal=Gaussian [1]} $ Acquisition 1 features
negativeLowerConfidenceBound beta =
  if beta < 0
  then Left $ MkValueError $ "beta should be greater than or equal to zero, got " ++ show beta
  else Right $ \_, predict, at =>
    let marginal = predict at
     in squeeze $ mean marginal - const beta * variance marginal

||| Build the expected improvement acquisition function in the context of a constraint on the input
||| domain, where points that do not satisfy the constraint do not offer an improvement. The
||| complete acquisition function is built from a constraint acquisition function, which quantifies
||| whether specified points in the input space satisfy the constraint.
export
expectedConstrainedImprovement : (limit : Tensor [] Double) ->
  Empiric features {marginal=Gaussian [1]} $ (Acquisition 1 features -> Acquisition 1 features)


module Data.Optics.Iso

import Data.Optics.Prism

||| Isomorphism
data Iso s a =
  ||| create an isomorphism between s and a
  MkIso  (s -> a) (a -> s)

%name Iso iso, iso1, iso2

%default total

to: Iso s a -> s -> a
to (MkIso f g) s = f s

from: Iso s a -> a -> s
from (MkIso f g) a = g a

modify: (a -> a) -> (Iso s a) -> s -> s
modify f (MkIso to from) s = (from . f . to ) s

--
-- Compositions
--

infixr 9 -:+
||| compose two Isomorphisms
(-:+): Iso a b -> Iso s a -> Iso s b
x -:+ y = MkIso newTo newFrom
  where
    newTo: s -> b
    newTo  =  (to x . to y)
    newFrom: b -> s
    newFrom = (from y . from x)

infixr 9 +:-
(+:-) : (Iso s a) -> (Iso a b) -> (Iso s b)
(+:-) = flip (-:+)


module Linear.V

import Data.Floating
import Data.Void
import Data.Nat
import public Data.Vect

public export
V : Nat -> Type -> Type
V = Vect

public export
T : List Nat -> Type -> Type
T [] a = a
T (n :: ns) a = V n (T ns a)

export
{n : _} -> FromDouble a => FromDouble (V n a) where
  fromDouble = pure . fromDouble

export
{n : _} -> Num a => Num (V n a) where
  (+) = zipWith (+)
  (*) = zipWith (*)
  fromInteger = pure . fromInteger

export
{n : _} -> Neg a => Neg (V n a) where
  (-) = zipWith (-)
  negate = map negate

export
{n : _} -> Fractional a => Fractional (V n a) where
  (/) = zipWith (/)
  recip = map recip

export
{n : _} -> Floating a => Floating (V n a) where
  pi = pure pi
  exp = map exp
  ln = map ln
  sqrt = map sqrt
  pow = zipWith pow
  log = zipWith log
  sin = map sin
  cos = map cos
  tan = map tan
  asin = map asin
  acos = map acos
  atan = map atan
  sinh = map sinh
  cosh = map cosh
  tanh = map tanh

export
dot : (Num a, Foldable f, Zippable f) => f a -> f a -> a
dot x y = sum $ zipWith (*) x y

punch : V i a -> V (S j) a -> V (S j) (V (i + j) a)
punch {j = Z} xs (y :: []) = [rewrite plusZeroRightNeutral i in xs]
punch {j = S j} xs (y :: (y' :: ys)) =
  (xs ++ (y' :: ys)) :: (rewrite sym $ plusSuccRightSucc i j in punch (xs `snoc` y) (y' :: ys))

flipflop : Neg a => Bool -> V n a -> V n a
flipflop _ [] = []
flipflop False (x :: xs) = x :: flipflop True xs
flipflop True (x :: xs) = negate x :: flipflop False xs

export
det : {n : _} -> Neg a => T [S n, S n] a -> a
det {n = Z} [[n]] = n
det {n = S n} xs = sum $ zipWith (*) (flipflop False (map head xs)) (map det $ punch [] (map tail xs))

export
eye : Num a => {n : _} -> V n (V n a)
eye {n = Z} = []
eye {n = S n} = (1 :: pure 0) :: map (0 ::) eye

infix 7 *^, ^*, *!, !*
export
(*^) : (Functor f, Num a) => a -> f a -> f a
(*^) a = map (a *)

export
(^*) : (Functor f, Num a) => f a -> a -> f a
(^*) = flip (*^)

export
(*!) : (Num a, Num (f a), Functor f, Foldable f, Foldable t, Zippable t) => t a -> t (f a) -> f a
f *! g = sum $ zipWith (*^) f g

export
(!*) : Num a => Foldable t => Functor f => Zippable t => f (t a) -> t a -> f a
m !* v = map (\r => sum $ zipWith (*) r v) m

infixl 7 !*!
export
(!*!) : Num a => Num (n a) => Functor m => Foldable t => Zippable t => Zippable n => Functor n => m (t a) -> t (n a) -> m (n a)
xs !*! ys = map (\x => foldl (+) 0 (zipWith (*^) x ys)) xs

export
outer : (Functor f, Functor g, Num a) => f a -> g a -> f (g a)
outer a b = map (\x => map (* x) b) a

public export
prod : List Nat -> Nat
prod [] = 1
prod (x :: xs) = x * prod xs

-- multRightSuccPlus : (left : Nat) -> (right : Nat) -> left * S right = left + (left * right)

export
group : (n : Nat) -> (m : Nat) -> V (n * m) a -> V n (V m a)
group Z     _ _  = []
group (S n) m xs = let (l, r) = splitAt m xs in l :: group n m r

export
ranged : (n : _) -> T [n] Nat
ranged Z = []
ranged (S i) = Z :: map S (ranged i)

export
bump : (size : List Nat) -> {n : _} -> {auto prf : n = prod size} -> V n a -> T size a
bump [] {n} xs with (prf)
  bump [] {n = 1} [x] | Refl = x
bump (m :: ms) {n} xs with (prf)
  bump (m :: ms) {n = m * prod ms} xs | Refl = map (bump ms) $ group m (prod ms) xs

export
dump : {ns : _} -> T ns a -> V (prod ns) a
dump {ns = []} x = [x]
dump {ns = n :: ns} x = concat $ map dump x

export
reshape : (size : _) -> {auto ns : _} -> {auto prf : prod ns = prod size} -> T ns a -> T size a
reshape size = bump size . dump


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

%name Vect xs, ys

Eq a => Eq (Vect n a) where
    (==) [] [] = True
    (==) (x :: xs) (y :: ys) = x == y && xs == ys

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


module PowerSource

data PowerSource = Petrol | Pedal

data Vehicle : PowerSource -> Type where
     Bicycle : Vehicle Pedal
     Unicycle : Vehicle Pedal
     Car : (fuel : Nat) -> Vehicle Petrol
     Motorbike : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels (Motorbike fuel) = 2

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel (Motorbike fuel) = Motorbike 20
-- If we add impossible to the above case, Idris will report that it is a valid case
refuel Bicycle impossible


module Expr

import Maps

%access public export

%default total

State : Type
State = TotalMap Nat

empty_state : State
empty_state = t_empty 0

A : Id
A = MkId "A"

B : Id
B = MkId "B"

C : Id
C = MkId "C"

D : Id
D = MkId "D"

E : Id
E = MkId "E"

F : Id
F = MkId "F"

W : Id
W = MkId "W"

X : Id
X = MkId "X"

Y : Id
Y = MkId "Y"

Z : Id
Z = MkId "Z"

data AExp : Type where
  ANum : Nat -> AExp
  AId : Id -> AExp
  APlus : AExp -> AExp -> AExp
  AMinus : AExp -> AExp -> AExp
  AMult : AExp -> AExp -> AExp

namespace VariableNames
  A : AExp
  A = AId A

  B : AExp
  B = AId B

  C : AExp
  C = AId C

  D : AExp
  D = AId D

  E : AExp
  E = AId E

  F : AExp
  F = AId F

  W : AExp
  W = AId W

  X : AExp
  X = AId X

  Y : AExp
  Y = AId Y

  Z : AExp
  Z = AId Z

Num AExp where
  (+) = APlus
  (*) = AMult
  fromInteger = ANum . fromIntegerNat

(-) : AExp -> AExp -> AExp
(-) = AMinus

Uninhabited (ANum _ = AId _) where
  uninhabited Refl impossible

Uninhabited (ANum _ = APlus _ _) where
  uninhabited Refl impossible

Uninhabited (ANum _ = AMinus _ _) where
  uninhabited Refl impossible

Uninhabited (ANum _ = AMult _ _) where
  uninhabited Refl impossible

Uninhabited (APlus _ _ = ANum _) where
  uninhabited Refl impossible

Uninhabited (AMinus _ _ = ANum _) where
  uninhabited Refl impossible

Uninhabited (AMult _ _ = ANum _) where
  uninhabited Refl impossible

Uninhabited (AId _ = ANum _) where
  uninhabited Refl impossible

Uninhabited (AId _ = APlus _ _) where
  uninhabited Refl impossible

Uninhabited (AId _ = AMinus _ _) where
  uninhabited Refl impossible

Uninhabited (AId _ = AMult _ _) where
  uninhabited Refl impossible

Uninhabited (APlus _ _ = AId _) where
  uninhabited Refl impossible

Uninhabited (AMinus _ _ = AId _) where
  uninhabited Refl impossible

Uninhabited (AMult _ _ = AId _) where
  uninhabited Refl impossible

aNumInjective : ANum n = ANum m -> n = m
aNumInjective Refl = Refl

aIdInjective : AId x = AId y -> x = y
aIdInjective Refl = Refl

data BExp : Type where
  BTrue : BExp
  BFalse : BExp
  BEq : AExp -> AExp -> BExp
  BLe : AExp -> AExp -> BExp
  BNot : BExp -> BExp
  BAnd : BExp -> BExp -> BExp

(==) : AExp -> AExp -> BExp
(==) = BEq

(<=) : AExp -> AExp -> BExp
(<=) = BLe

not : BExp -> BExp
not = BNot

(&&) : BExp -> BExp -> BExp
(&&) = BAnd

aeval : State -> AExp -> Nat
aeval _ (ANum n) = n
aeval st (AId i) = st i
aeval st (APlus a1 a2) = aeval st a1 + aeval st a2
aeval st (AMinus a1 a2) = aeval st a1 `minus` aeval st a2
aeval st (AMult a1 a2) = aeval st a1 * aeval st a2

beval : State -> BExp -> Bool
beval _ BTrue = True
beval _ BFalse = False
beval st (BEq a1 a2) = aeval st a1 == aeval st a2
beval st (BLe a1 a2) = lte (aeval st a1) (aeval st a2)
beval st (BNot b) = not $ beval st b
beval st (BAnd b1 b2) = beval st b1 && beval st b2


module Data.Optics.Prism

||| Prism
data Prism s a =
  MkPrism (s -> Maybe a)  (a -> s)

%name Prism prism, prism1, prism2

%default total

to : Prism s a -> (s -> Maybe a)
to (MkPrism f g) s = f s

from: Prism s a -> (a -> s)
from (MkPrism f g) a = g a

infixr 9 <:+
||| compose two prisms
(<:+) : Prism a b -> Prism s a -> Prism s b
p1 <:+ p2 = MkPrism newTo newFrom
  where
    newTo: s -> Maybe b
    newTo s = case (to p2 s) of
              Nothing => Nothing
              Just a  => (to p1 a)
    newFrom: b -> s
    newFrom = with Prelude.Basics (from p2 . from p1)

infixr 9 :+>
(:+>) : Prism s a -> Prism a b -> Prism s b
(:+>) = flip (<:+)

--
-- Functions
--

||| focus on the left of an Either
left: Prism (Either a b) a
left = MkPrism to from
  where
    to: (Either a b) -> Maybe a
    to (Left x) = Just x
    to (Right x) = Nothing

    from: a -> (Either a b)
    from x = Left x

||| focus on the right of an Either
right: Prism (Either a b) b
right = MkPrism to from
  where
    to : Either a b -> Maybe b
    to (Left x) = Nothing
    to (Right x) = Just x

    from: b -> Either a b
    from x = Right x

||| focus on Just of a Maybe
just: Prism (Maybe a) a
just = MkPrism to from
  where
    to: Maybe a -> Maybe a
    to Nothing = Nothing
    to (Just x) = Just x

    from: a -> Maybe a
    from x = Just x


module Matrixes

import Data.Vect

sum : Num numType => Vect rows (Vect cols numType) ->
                     Vect rows (Vect cols numType) ->
                     Vect rows (Vect cols numType)


module Chapter4

import TypesAndFunctions
import Naturality

%default total

Exercise_4_1_1_not : Bool -> Bool
Exercise_4_1_1_not b = if b then False else True

Exercise_4_1_1_id : Bool -> Bool
Exercise_4_1_1_id b = b

Exercise_4_1_1_const_true : Bool -> Bool
Exercise_4_1_1_const_true _ = True

Exercise_4_1_1_const_false : Bool -> Bool
Exercise_4_1_1_const_false _ = False

Exercise_4_4_1_Either_a_Void_To_a : {a : Type} -> Either a Void -> a
Exercise_4_4_1_Either_a_Void_To_a (Left x) = x
Exercise_4_4_1_Either_a_Void_To_a (Right y) = void y

Exercise_4_4_1_a_To_Either_a_Void : {a : Type} -> a -> Either a Void
Exercise_4_4_1_a_To_Either_a_Void x = Left x

Exericse_4_4_1_Either_a_Void_to_a_To_Either_a_Void_id : (a : Type) ->
    IsLeftInverse
        (Exercise_4_4_1_Either_a_Void_To_a {a})
        (Exercise_4_4_1_a_To_Either_a_Void {a})
Exericse_4_4_1_Either_a_Void_to_a_To_Either_a_Void_id a (Left _) = Refl
Exericse_4_4_1_Either_a_Void_to_a_To_Either_a_Void_id a (Right _) impossible

Exercise_4_4_1_a_To_Either_a_Void_to_a_id : (a : Type) ->
    IsRightInverse
        (Exercise_4_4_1_Either_a_Void_To_a {a})
        (Exercise_4_4_1_a_To_Either_a_Void {a})
Exercise_4_4_1_a_To_Either_a_Void_to_a_id a _ = Refl

Exercise_4_4_1_are_inverses : (a : Type) ->
    IsInverse
        (Exercise_4_4_1_Either_a_Void_To_a {a})
        (Exercise_4_4_1_a_To_Either_a_Void {a})
Exercise_4_4_1_are_inverses a =
    (Exericse_4_4_1_Either_a_Void_to_a_To_Either_a_Void_id a,
     Exercise_4_4_1_a_To_Either_a_Void_to_a_id a)

SumElimination : {a, b, x : Type} -> (f : a -> x) -> (g : b -> x) ->
    Either a b -> x
SumElimination f g (Left e) = f e
SumElimination f g (Right e) = g e

CommuteSumElimination : {a, b : Type} ->
  ObserverChange {cat=TypeCategory} (Either a b) (Either b a)
CommuteSumElimination _ h (Left e) = h (Right e)
CommuteSumElimination _ h (Right e) = h (Left e)

Exercise_4_4_2_CommuteSumEliminationIsOwnInverse : {a, b : Type} ->
    IsBijectionForEach (CommuteSumElimination {a} {b})
Exercise_4_4_2_CommuteSumEliminationIsOwnInverse x =
    (CommuteSumElimination {a=b} {b=a} x **
     (\h => functionalExtensionality (\e => case e of
        Left _ => Refl
        Right _ => Refl),
      \h => functionalExtensionality (\e => case e of
        Left _ => Refl
        Right _ => Refl)))

Exercise_4_4_2_CommuteSumEliminationIsNatural : {a, b : Type} ->
    ObserverChangeIsNatural {cat=TypeCategory} (CommuteSumElimination {a} {b})
Exercise_4_4_2_CommuteSumEliminationIsNatural {a} {b} x y g =
    functionalExtensionality
        (\h => functionalExtensionality
            (\e => case e of
                Left _ => Refl
                Right _ => Refl))

Exercise_4_4_3_CommuteSum : {a, b : Type} -> Either a b -> Either b a
Exercise_4_4_3_CommuteSum (Left e) = Right e
Exercise_4_4_3_CommuteSum (Right e) = Left e

Exercise_4_4_3_CommuteSumIsOwnLeftInverse : (a, b : Type) ->
    IsLeftInverse
        (Exercise_4_4_3_CommuteSum {a} {b})
        (Exercise_4_4_3_CommuteSum {a=b} {b=a})
Exercise_4_4_3_CommuteSumIsOwnLeftInverse a b (Left _) = Refl
Exercise_4_4_3_CommuteSumIsOwnLeftInverse a b (Right _) = Refl

Exercise_4_4_3_CommuteSumIsOwnRightInverse : (a, b : Type) ->
    IsRightInverse
        (Exercise_4_4_3_CommuteSum {a} {b})
        (Exercise_4_4_3_CommuteSum {a=b} {b=a})
Exercise_4_4_3_CommuteSumIsOwnRightInverse a b (Left _) = Refl
Exercise_4_4_3_CommuteSumIsOwnRightInverse a b (Right _) = Refl

Exercise_4_4_3_CommuteSumIsOwnInverse : (a, b : Type) ->
    IsInverse
        (Exercise_4_4_3_CommuteSum {a} {b})
        (Exercise_4_4_3_CommuteSum {a=b} {b=a})
Exercise_4_4_3_CommuteSumIsOwnInverse a b =
    (Exercise_4_4_3_CommuteSumIsOwnLeftInverse a b,
     Exercise_4_4_3_CommuteSumIsOwnRightInverse a b)

Exercise_4_4_4_Functoriality : {a, a', b, b' : Type} ->
    (f : a -> a') -> (g : b -> b') -> ((Either a b) -> (Either a' b'))
Exercise_4_4_4_Functoriality f g (Left e) = Left (f e)
Exercise_4_4_4_Functoriality f g (Right e) = Right (g e)

Exercise_4_4_4_Functoriality_Preserves_Composition :
    {a, a', a'', b, b', b'' : Type} ->
    (f : a -> a') -> (f' : a' -> a'') ->
    (g : b -> b') -> (g' : b' -> b'') ->
        Exercise_4_4_4_Functoriality (f' . f) (g' . g) =
        Exercise_4_4_4_Functoriality f' g' . Exercise_4_4_4_Functoriality f g
Exercise_4_4_4_Functoriality_Preserves_Composition f f' g g' =
    functionalExtensionality
        (\e => case e of
            Left _ => Refl
            Right _ => Refl)

Exercise_4_4_5_Functoriality_Preserves_Identity :
    (a, b : Type) ->
    Exercise_4_4_4_Functoriality (id {a}) (id {a=b}) = id {a=(Either a b)}
Exercise_4_4_5_Functoriality_Preserves_Identity a b =
    functionalExtensionality
        (\e => case e of
            Left _ => Refl
            Right _ => Refl)


module Toolkit.Data.Vect.Extra

import public Decidable.Equality
import        Data.Vect

%default total

namespace Equality
   public export
   vecEq : Eq type => Vect n type -> Vect m type -> Bool
   vecEq [] [] = True
   vecEq [] (x :: xs) = False
   vecEq (x :: xs) [] = False
   vecEq (x :: xs) (y :: ys) = x == y && vecEq xs ys

namespace Decidable
  namespace SameLength
    public export
    decEq : DecEq type
          => (n = m)
          -> (xs : Vect n type)
          -> (ys : Vect m type)
          -> Dec (xs = ys)
    decEq Refl xs ys with (decEq xs ys)
      decEq Refl ys ys | (Yes Refl) = Yes Refl
      decEq Refl xs ys | (No contra) = No contra

  namespace DiffLength

    public export
    vectorsDiffLength : DecEq type
                      => (contra : (n = m) -> Void)
                      -> {xs : Vect n type}
                      -> {ys : Vect m type}
                      -> (xs = ys) -> Void
    vectorsDiffLength contra Refl = contra Refl

    public export
    decEq : DecEq type
         => {n,m : Nat}
         -> (xs : Vect n type)
         -> (ys : Vect m type)
         -> Dec (xs = ys)
    decEq xs ys {n} {m} with (decEq n m)
      decEq xs ys {n = m} {m = m} | (Yes Refl) = decEq Refl xs ys
      decEq xs ys {n = n} {m = m} | (No contra) = No (vectorsDiffLength contra)

namespace Shape

  public export
  data Shape : (xs : Vect n a)
            -> (ys : Vect m a)
            -> Type
    where
      Empty : Shape Nil Nil
      LH    : Shape (x::xs) Nil
      RH    : Shape Nil      (y::ys)
      Both  : Shape (x::xs) (y::ys)

  export
  shape : (xs : Vect n a)
       -> (ys : Vect m a)
       -> Shape xs ys
  shape [] [] = Empty
  shape [] (y :: ys) = RH
  shape (x :: xs) [] = LH
  shape (x :: xs) (y :: ys) = Both

namespace ReplaceAt

  public export
  data ReplaceAt : (idx       : Fin n)
                -> (xs        : Vect n a)
                -> (this,that : a)
                -> (ys        : Vect n a)
                             -> Type
    where
      H : ReplaceAt FZ (x::xs)
                        x
                        y
                       (y::xs)

      T : ReplaceAt     idx       xs  x y      ys
       -> ReplaceAt (FS idx) (x'::xs) x y (x'::ys)

  notSame : (x = this -> Void) -> DPair (Vect (S len) a) (ReplaceAt FZ (x :: xs) this that) -> Void
  notSame _ (MkDPair _ (T y)) impossible

  notLater : (DPair (Vect len a) (ReplaceAt x xs this that) -> Void) -> DPair (Vect (S len) a) (ReplaceAt (FS x) (y :: xs) this that) -> Void
  notLater f (MkDPair (y :: ys) (T z)) = f (MkDPair ys z)

  export
  replaceAt : DecEq a
           => (idx : Fin n)
           -> (xs  : Vect n a)
           -> (this, that : a)
           -> Dec (DPair (Vect n a) (ReplaceAt idx xs this that))
  replaceAt FZ (x :: xs) this that with (decEq x this)
    replaceAt FZ (x :: xs) x    that | (Yes Refl) = Yes (MkDPair (that :: xs) H)
    replaceAt FZ (x :: xs) this that | (No contra)
      = No (notSame contra)
  replaceAt (FS x) (y :: xs) this that with (replaceAt x xs this that)
    replaceAt (FS x) (y :: xs) this that | (Yes (MkDPair fst snd))
      = Yes (MkDPair (y :: fst) (T snd))
    replaceAt (FS x) (y :: xs) this that | (No contra)
      = No (notLater contra)

namespace Quantifier
  namespace AtIndex

    public export
    data AtIndex : (type : Type)
                -> (p    : (a : type) -> Type)
                -> (idx  : Fin n)
                -> (xs   : Vect n type)
                        -> Type
      where
        Here : (prf : p x)
                   -> AtIndex type p FZ (x::xs)

        There : (later : AtIndex type p     next            xs)
                      -> AtIndex type p (FS next) (not_x :: xs)

    export
    Uninhabited (AtIndex type p idx Nil) where
      uninhabited (Here prf) impossible
      uninhabited (There later) impossible

    notLater : (AtIndex type p     y        xs  -> Void)
             -> AtIndex type p (FS y) (x :: xs) -> Void
    notLater f (There later) = f later

    notHere : (p x -> Void)
            -> AtIndex type p FZ (x :: xs) -> Void
    notHere f (Here prf) = f prf

    export
    atIndex : {type : Type}
           -> {p    : type -> Type}
           -> (dec  : (this : type) -> Dec (p this))
           -> (idx  : Fin n)
           -> (xs   : Vect n type)
                   -> Dec (AtIndex type p idx xs)
    atIndex dec idx []
      = No absurd

    atIndex dec FZ (x :: xs) with (dec x)
      atIndex dec FZ (x :: xs) | (Yes prf)
        = Yes (Here prf)
      atIndex dec FZ (x :: xs) | (No contra)
        = No (notHere contra)

    atIndex dec (FS y) (x :: xs) with (atIndex dec y xs)
      atIndex dec (FS y) (x :: xs) | (Yes prf)
        = Yes (There prf)
      atIndex dec (FS y) (x :: xs) | (No contra)
        = No (notLater contra)

    namespace Diff
      public export
      data AtIndexI : (type : Type)
                   -> (p    : (a : type) -> Type)
                   -> (m,n  : Nat)
                   -> (idx  : Fin m)
                   -> (xs   : Vect n type)
                           -> Type
        where
          At : AtIndex  type p idx xs
            -> AtIndexI type p n n idx xs

      Uninhabited (AtIndexI type p m Z idx Nil) where
        uninhabited (At (Here prf)) impossible
        uninhabited (At (There later)) impossible

      notAtIndex : (AtIndex type p idx xs -> Void)
                -> AtIndexI type p m m idx xs -> Void
      notAtIndex f (At x) = f x

      indexDiffers : (m = n -> Void) -> AtIndexI type p m n idx xs -> Void
      indexDiffers f (At x) = f Refl

      export
      atIndexI : {type : Type}
              -> {p    : type -> Type}
              -> {m,n  : Nat}
              -> (dec  : (this : type) -> Dec (p this))
              -> (idx  : Fin m)
              -> (xs   : Vect n type)
                      -> Dec (AtIndexI type p m n idx xs)
      atIndexI {m} {n} dec idx xs with (decEq m n)
        atIndexI {m = m} {n = m} dec idx xs | (Yes Refl) with (atIndex dec idx xs)
          atIndexI {m = m} {n = m} dec idx xs | (Yes Refl) | (Yes prf)
            = Yes (At prf)

          atIndexI {m = m} {n = m} dec idx xs | (Yes Refl) | (No contra)
            = No (notAtIndex contra)
        atIndexI {m = m} {n = n} dec idx xs | (No contra)
          = No (indexDiffers contra)

-- [ EOF ]


data MyNat : Type where
     MyZ : MyNat
     MyS : (1 _ : MyNat) -> MyNat

lplus : (1 x : MyNat) -> (1 y : MyNat) -> MyNat
lplus MyZ y = y
lplus (MyS k) y = MyS (lplus k y)

foo : (1 x : MyNat) -> (1 y : MyNat) -> MyNat -> MyNat
foo x y z
    = let 1 test = the MyNat $ case z of
                        MyZ => MyZ
                        (MyS k) => MyS z
            in
          lplus test x


module Clocks

%default total

-- An Idris implementation of 'A Clocked Denotational Semantics for
-- LUCID-SYNCHRONE in COQ' by S. Boulme & G. Hamon 2001

funPower : (f : (a -> a)) -> (repeats : Nat) -> (start : a) -> a
funPower f Z x = x
funPower f (S k) x = funPower f k (f x)

funPower_commutes : (f : (a -> a)) -> (n : Nat) -> (x : a) -> (f (funPower f n x)) = (funPower f (S n) x)
funPower_commutes f Z x = Refl
funPower_commutes f (S k) x = let ff = funPower_commutes f k (f x) in
                                  rewrite ff in Refl

-- nicked from bmckenna
-- dont think we can have DecEq for streams??
-- use equivalence instead
-- infixl 9 =~=
-- data Equiv : Stream a -> Stream a -> Type where
--   Cons :  (head_prf : a = b) -> Inf (Equiv as bs) -> Equiv (a :: as) (b :: bs)

-- stream_unfold : (DecEq a) => (s : Stream a) -> Equiv s (( head s ) :: ( tail s ))
-- stream_unfold (x :: xs) with (decEq x (head (x :: xs)))
--   stream_unfold (x :: xs) | (Yes prf) = ?stream_unfold_rhs_1_rhs_3
--   stream_unfold (x :: xs) | (No contra) = ?stream_unfold_rhs_1_rhs_4

data Clk = Tick | Tock

data SamplElt : (a : Type) -> Clk -> Type where
  CNone : SamplElt a Tock
  CAny  : a -> SamplElt a Tick
  CFail : SamplElt a Tick

bad_any_fail_prf : (clk : Clk) -> (CAny x = CFail) -> Void
bad_any_fail_prf _ Refl impossible

bad_fail_any_prf : (clk : Clk) -> (CFail = CAny x) -> Void
bad_fail_any_prf _ Refl impossible

bad_any_prf : (cont : (x = y) -> Void) -> (CAny x = CAny y) -> Void
bad_any_prf cont Refl = cont Refl

(DecEq a) => DecEq (SamplElt a clk) where
    decEq CNone CNone = Yes Refl
    decEq CFail CFail = Yes Refl
    decEq (CAny x) (CAny y) = case (decEq x y) of
                Yes prf => Yes (cong prf)
                No cont => No (bad_any_prf cont)
    decEq {clk=Tick} (CAny x) CFail = No (bad_any_fail_prf Tick)
    decEq {clk=Tick} CFail (CAny y) = No (bad_fail_any_prf Tick)

    decEq CNone CFail    impossible
    decEq CFail CNone    impossible
    decEq CNone (CAny y) impossible
    decEq (CAny x) CNone impossible

Clock : Type
Clock = Stream Clk

data SamplStr : (a : Type) -> (c : Clock) -> Type where
  (::) : (SamplElt a (head c)) -> Inf (SamplStr a (tail c)) -> SamplStr a c

-- infixl 9 =~~=
-- data (=~~=) : SamplStr a c -> SamplStr a c -> Type where
--   (:::) : a = b -> Inf (as =~~= bs) -> (SPCons a as =~~= SPCons b bs)

sp_hd : SamplStr a c -> SamplElt a (head c)
sp_hd (x :: _) = x

sp_tl : SamplStr a c -> SamplStr a (tail c)
sp_tl (_ :: xs) = xs

using (c1 : Clock, c2 : Clock)
  prf_samplElt : (a : Type ) -> (c1 : Clock) -> (c2 : Clock) ->
                 (head_prf : head c1 = head c2) ->
                 (SamplElt a (head c1) = SamplElt a (head c2))
  prf_samplElt a c1 c2 head_prf = rewrite head_prf in Refl

  head_coerce : (head_prf : head c1 = head c2) ->
                (x : SamplElt a (head c1)) -> SamplElt a (head c2)
  head_coerce {a} {c1} {c2} head_prf x = let prf = prf_samplElt a c1 c2 head_prf in
                                         rewrite sym $ prf in x

  clock_coerce : (prf : c1 = c2) -> SamplStr a c1 -> SamplStr a c2
  clock_coerce Refl x = x

  sp_eq_clock_coerce : (prf : (c1 = c2)) -> (s : SamplStr a c1) -> (s = (clock_coerce prf s))
  sp_eq_clock_coerce Refl s = Refl

-- DecEq (SamplElt a (head c)) => DecEq (SamplStr a c) where
--     decEq (x::xs) (y::ys) with (decEq x y)
--       decEq (x::xs) (y::ys) | Yes prf = ?DecEq_rhs_1_rhs_1
--       decEq (x::xs) (y::ys) | No cong = No ?DecEq_rhs_1_rhs_3

-- -- doesnt work becasue Bool is different but only one clk
-- -- notFails : a -> Vect 2 (SamplElt a clk)
-- -- notFails x = [CNone, CAny x]

-- -- is_not_fail : (e : SamplElt a clk) -> Bool
-- -- is_not_fail CNone = True
-- -- is_not_fail (CAny x) = True
-- -- is_not_fail CFail = False

-- -- data WellFormed : (s : SamplStr a c) -> Type where
-- --   IsNotFail : (prf : True = is_not_fail (sp_hd s)) -> WellFormed (sp_tl s) -> WellFormed s

data WellFormed : (s : SamplStr a c) -> Type where
  HeadIsAny : ((sp_hd s) = (CAny a)) -> WellFormed (sp_tl s) -> WellFormed s
  HeadIsNone : ((sp_hd s) = CNone) -> WellFormed (sp_tl s) -> WellFormed s

elt_const : a -> (clk_value : Clk) -> SamplElt a clk_value
elt_const x clk_value = case clk_value of
  Tick   => CAny x
  Tock => CNone

sp_const : a -> (clk : Clock) -> SamplStr a clk
sp_const x (c :: cs) = (elt_const x c) :: (sp_const x cs)

-- sp_const_wellformed : (x : a) -> (clk : Clock) -> WellFormed (sp_const a clk)
-- sp_const_wellformed x (Cons c cs) = let rest = (sp_const_wellformed x cs) in
--                                     case elt_const x c of
--                                     CAny x' => ?head_any_prf rest
--                                     CNone  =>  ?head_non_prf
--                                     CFail => ?head_fail_prf

elt_extend : (SamplElt (a -> b) clk_value) -> (SamplElt a clk_value) -> (SamplElt b clk_value)
elt_extend CNone    _        = CNone
elt_extend (CAny f) (CAny x) = CAny (f x)
elt_extend _        CFail    = CFail
elt_extend CFail    _        = CFail

sp_extend : (SamplStr (a -> b) clk) -> (SamplStr a clk) -> (SamplStr b clk)
sp_extend (f :: fs) (x :: xs) = (elt_extend f x) :: (sp_extend fs xs)

-- sp_extend_wellformed : (fs : SamplStr (a->b) clk) ->
--                        (s : SamplStr a clk) ->
--                        (WellFormed fs) ->
--                        (WellFormed s) ->
--                        (WellFormed (sp_extend fs s))
-- sp_extend_wellformed fs s wf_fs wf_xs = ?sp_extend_wellformed_rhs

-- sp_extend_const_prf : (f : a -> b) -> (x : a) -> (sp_extend (sp_const f clk) (sp_const x clk)) = sp_const (f x) clk
-- sp_extend_const_prf f x = ?sp_extend_const_prf_rhs

-- sp_extend_id_prf : (x : SamplStr a clk) -> (sp_extend (sp_const id clk) x) = x
-- sp_extend_id_prf x = ?sp_extend_id_prf_rhs

-- sp_extend_comp_prf : (f : a -> b) -> (g : b -> c) -> (x : SamplStr a clk) ->
--                      (sp_extend (sp_const g clk) (sp_extend (sp_const f clk) x)) = (sp_extend (sp_const (g . f) clk) x)
-- sp_extend_comp_prf f g (SPCons x xs) = ?sp_extend_comp_prf_rhs_1

flip_bool : Bool -> Bool
flip_bool False = True
flip_bool True = False

bool_to_clk : Bool -> Clk
bool_to_clk True = Tick
bool_to_clk False = Tock

clk_to_bool : Clk -> Bool
clk_to_bool Tick = True
clk_to_bool Tock = False

sp_not :(SamplStr Bool clk) -> (SamplStr Bool clk)
sp_not {clk} = sp_extend (sp_const flip_bool clk)

if_then_else : Bool -> a -> a -> a
if_then_else cond x y = if cond then x else y

sp_if : SamplStr Bool clk -> SamplStr a clk -> SamplStr a clk -> SamplStr a clk
sp_if {clk} lc x y = sp_extend (sp_extend (sp_extend (sp_const if_then_else clk) lc) x) y

elt_on : SamplElt Bool clk_value -> Clk
elt_on CNone = Tock
elt_on (CAny x) = bool_to_clk x
elt_on CFail = Tick

sp_on : SamplStr Bool clk -> Clock
sp_on (x :: xs) = (elt_on x) :: (sp_on xs)

head_sp_on_prf : (head (sp_on s)) = (elt_on (sp_hd s))
head_sp_on_prf = ?head_sp_on_prf_rhs1

elt_when : (o : SamplElt Bool clk_value) ->
           SamplElt a clk_value ->
           SamplElt a (elt_on o)
elt_when CNone        e = CNone
elt_when (CAny False) e = CNone
elt_when (CAny True)  e = e
elt_when CFail        e = CFail

sp_when : (lc : SamplStr Bool clk) -> SamplStr a clk -> SamplStr a (sp_on lc)
sp_when (c :: cs) (x :: xs) = (elt_when c x) :: (sp_when cs xs)

-- flip_bool_prf : (elt_on (elt_extend (elt_const flip_bool Tick) (CAny False))) = Tick

elt_merge : (o : SamplElt Bool clk_value) ->
            (SamplElt a (elt_on o)) ->
            (SamplElt a (elt_on (elt_extend (elt_const Clocks.flip_bool clk_value) o))) ->
            SamplElt a clk_value
elt_merge CNone        x y = CNone
elt_merge (CAny False) x y = y
elt_merge (CAny True)  x y = x -- elt_on (CAny True)
elt_merge CFail        x y = CFail

sp_merge : (lc : SamplStr Bool clk) ->
           SamplStr a (sp_on lc) ->
           SamplStr a (sp_on (sp_not lc)) ->
           SamplStr a clk
sp_merge (c :: cs) (x :: xs) (y :: ys) = (elt_merge c x y) :: (sp_merge cs xs ?ysthings)
             -- Type mismatch between
             --         SamplElt a
             --                  (head (sp_on (sp_extend (sp_const flip_bool clk)
             --                                          (c :: cs)))) (Type of y)
             -- and
             --         SamplElt a
             --                  (elt_on (elt_extend (elt_const flip_bool (head clk))
             --                                      c)) (Expected type)

--   (c :: cs) (x :: xs) (y :: ys) = (elt_merge c x y) :: (sp_merge cs xs ys)

-- sp_if_equiv_prf : (lc : SamplStr Bool clk) -> (x : SamplStr a clk) -> (y : SamplStr a clk) ->
--                   (WellFormed x) ->
--                   (WellFormed y) ->
--                   (sp_if lc x y) = (sp_merge lc (sp_when lc x) (sp_when (sp_not lc) y))

-- chooses xs until clock ticks, then chooses ys
sp_arrow : SamplStr a clk -> SamplStr a clk -> SamplStr a clk
sp_arrow {clk = (c :: cs)} (x :: xs) (y :: ys)
  = x :: (if (clk_to_bool c) then ys else (sp_arrow xs ys))

-- delay by one Clk element - if the clock ticks then initialised with init
-- else initialise with none and recurse with rest of x :: xs
sp_delay : (SamplStr a clk) -> (SamplElt a Tick) -> SamplStr a clk
sp_delay {clk = (Tick :: cs)} (x :: xs) init = init  :: (sp_delay xs x)
sp_delay {clk = (Tock :: cs)} (x :: xs) init = CNone :: (sp_delay xs init)

sp_pre : SamplStr a clk -> SamplStr a clk
sp_pre s = sp_delay s CFail

sp_fby : SamplStr a clk -> SamplStr a clk -> SamplStr a clk
sp_fby x y = sp_arrow x (sp_pre y)

-- arrow_equiv_prf : (x : SamplStr a clk) -> (y : SamplStr a clk) ->
--                   WellFormed x -> WellFormed y ->
--                   (sp_arrow x y) = (sp_if (sp_fby (sp_const True clk) (sp_const False clk)) x y)


%default partial

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

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


module Data.Logic.Propositional

%default total

-- Idris uses intuitionistic logic, so it does not validate the
-- principle of excluded middle (PEM) or similar theorems of classical
-- logic. But it does validate certain relations among these
-- propositions, and that's what's in this file.

||| The principle of excluded middle
PEM : Type -> Type
PEM p = Either p (Not p)

||| Double negation elimination
DNE : Type -> Type
DNE p = Not $ Not p -> p

||| The consensus theorem (at least, the interesting part)
Consensus : Type -> Type -> Type -> Type
Consensus p q r = (q, r) -> Either (p, q) (Not p, r)

||| Peirce's law
Peirce : Type -> Type -> Type
Peirce p q = ((p -> q) -> p) -> p

||| Not sure if this one has a name, so call it Frege's law
Frege : Type -> Type -> Type -> Type
Frege p q r = (p -> r) -> (q -> r) -> ((p -> q) -> q) -> r

||| The converse of contraposition: (p -> q) -> Not q -> Not p
Transposition : Type -> Type -> Type
Transposition p q = (Not q -> Not p) -> p -> q

||| This isn't a good name.
Switch : Type -> Type
Switch p = (Not p -> p) -> p

-- PEM and the others can't be proved outright, but it is possible to
-- prove the double negations (DN) of all of them.

||| The double negation of a proposition
DN : Type -> Type
DN p = Not $ Not p

pemDN : DN $ PEM p
pemDN f = f $ Right $ \x => f $ Left x

dneDN : DN $ DNE p
dneDN f = f $ \g => void $ g $ \x => f $ \_ => x

consensusDN : DN $ Consensus p q r
consensusDN f = f $ \(y, z) => Right (\x => f $ \(_, _) => Left (x, y), z)

peirceDN : DN $ Peirce p q
peirceDN f = f $ \g => g $ \x => void $ f $ \_ => x

fregeDN : DN $ Frege p q r
fregeDN f = f $ \g, h, i => h $ i $ \x => void $ f $ \_, _, _ => g x

transpositionDN : DN $ Transposition p q
transpositionDN f = f $ \g, x => void $ g (\y => f $ \_, _ => y) x

switchDN : DN $ Switch p
switchDN f = f $ \g => g $ \x => f $ \_ => x

-- It's easy to prove all these theorems assuming PEM.

dnePEM : PEM p -> DNE p
dnePEM (Left l) _ = l
dnePEM (Right r) f = void $ f r

consensusPEM : PEM p -> Consensus p q r
consensusPEM (Left l) (y, _) = Left (l, y)
consensusPEM (Right r) (_, z) = Right (r, z)

peircePEM : PEM p -> Peirce p q
peircePEM (Left l) _ = l
peircePEM (Right r) f = f $ \x => void $ r x

fregePEM : PEM p -> Frege p q r
fregePEM (Left l) f _ _ = f l
fregePEM (Right r) _ g h = g $ h $ \x => void $ r x

transpositionPEM : PEM p -> Transposition q p
transpositionPEM (Left l) _ _ = l
transpositionPEM (Right r) f x = void $ f r x

switchPEM : PEM p -> Switch p
switchPEM (Left l) _ = l
switchPEM (Right r) f = f r

-- It's trivial to prove these theorems assuming double negation
-- elimination (DNE), since their double negations can all be proved.

||| Eliminate double negations
EDN : DN p -> DNE p -> p
EDN f g = g f

pemDNE : DNE $ PEM p -> PEM p
pemDNE = EDN pemDN

-- It's possible to prove the theorems assuming Peirce's law, but some
-- thought must be given to choosing the right instances. Peirce's law
-- is therefore weaker than PEM on an instance-by-instance basis, but
-- all the instances together are equivalent.

pemPeirce : Peirce (PEM p) Void -> PEM p
pemPeirce f = f $ \g => Right $ \x => g $ Left x

dnePeirce : Peirce p Void -> DNE p
dnePeirce f g = f $ \h => void $ g h

consensusPeirce : Peirce (Consensus p q r) Void -> Consensus p q r
consensusPeirce f (y, z) =
  f (\g, (_, _) => Right (\x => g (\_ => Left (x, y)), z)) (y, z)

fregePeirce : Peirce (Frege p q r) Void -> Frege p q r
fregePeirce f g h i =
  f (\j, _, _, _ => h $ i $ \x => void $ j $ \_, _, _ => g x) g h i

transpositionPeirce : Peirce (Transposition p q) Void -> Transposition p q
transpositionPeirce f g x =
  f (\h, _, _ => void $ g (\y => h $ \_, _ => y) x) (\j, _ => g j x) x

-- There are a variety of single axioms sufficient for deriving all of
-- classical logic. The earliest of these is known as Nicod's axiom,
-- but it is written using only nand operators and doesn't lend itself
-- to Idris's type system. Meredith's axiom, on the other hand, is
-- written using implication and negation.

||| Meredith's axiom, sufficient for deriving all of classical logic
Meredith : (p, q, r, s, t : Type) -> Type
Meredith p q r s t =
  ((((p -> q) -> Not r -> Not s) -> r) -> t) -> (t -> p) -> s -> p

-- The Meredith axiom implies all of classical logic, and so in
-- particular it implies PEM, and therefore cannot be proved in
-- intuitionistic logic. As usual, however, its double negation can be
-- proved.

meredithDN : DN $ Meredith p q r s t
meredithDN f =
  f $ \g, h, x =>
    h $ g $ \i =>
      void $ i
        (\y => void $ f $ \_, _, _ => y)
        (\z => f $ \_, _, _ => h $ g $ \_ => z)
        x

-- Meredith can be proved assuming PEM, since the type system itself
-- takes care of the rest.

meredithPEM : PEM p -> Meredith p q r s t
meredithPEM (Left l) _ _ _ = l
meredithPEM (Right r) f g x =
  g $ f $ \h =>
    void $ h
      (\y => void $ r y)
      (\z => r $ g $ f (\_ => z))
      x