module Equiv

import Expr
import Imp
import Logic
import Maps

%access public export

%default total

AEquiv : (a1, a2 : AExp) -> Type
AEquiv a1 a2 = (st : State) -> aeval st a1 = aeval st a2

BEquiv : (b1, b2 : BExp) -> Type
BEquiv b1 b2 = (st : State) -> beval st b1 = beval st b2

AEquiv_example : AEquiv (X - X) 0
AEquiv_example st with (st X)
  AEquiv_example st | Z = Refl
  AEquiv_example st | S k = sym $ minusZeroN k

BEquiv_example : BEquiv (X - X == 0) BTrue
BEquiv_example st with (st X)
  BEquiv_example st | Z = Refl
  BEquiv_example st | S k = rewrite sym $ minusZeroN k in Refl

btrue_is_true : BEquiv BTrue BTrue
btrue_is_true _ = Refl

bfalse_is_false : BEquiv BFalse BFalse
bfalse_is_false _ = Refl

bnot_btrue_is_bfalse : BEquiv (BNot BTrue) BFalse
bnot_btrue_is_bfalse _ = Refl

bnot_bfalse_is_btrue : BEquiv (BNot BFalse) BTrue
bnot_bfalse_is_btrue _ = Refl

CEquiv : (c1, c2 : Com) -> Type
CEquiv c1 c2 = (st, st' : State) -> ((c1 / st \\ st') ↔ (c2 / st \\ st'))

skip_left : CEquiv (do SKIP; c) c
skip_left st st' = (forward, backward)
where forward : ((do SKIP; c) / st \\ st') -> (c / st \\ st')
      forward (E_Seq E_Skip rel) = rel
      backward : (c / st \\ st') -> ((do SKIP; c) / st \\ st')
      backward rel = E_Seq E_Skip rel

skip_right : CEquiv (do c; SKIP) c
skip_right st st' = (forward, backward)
where forward : ((do c; SKIP) / st \\ st') -> (c / st \\ st')
      forward (E_Seq rel E_Skip) = rel
      backward : (c / st \\ st') -> ((do c; SKIP) / st \\ st')
      backward rel = E_Seq rel E_Skip

test_true_simple : CEquiv (IFB BTrue THEN c1 ELSE c2 FI) c1
test_true_simple st st' = (forward, backward)
where forward : ((IFB BTrue THEN c1 ELSE c2 FI) / st \\ st') ->
                (c1 / st \\ st')
      forward (E_IfTrue _ rel) = rel
      forward (E_IfFalse prf _) = absurd prf
      backward : (c1 / st \\ st') ->
                 ((IFB BTrue THEN c1 ELSE c2 FI) / st \\ st')
      backward rel = E_IfTrue Refl rel

test_true : BEquiv b BTrue -> CEquiv (IFB b THEN c1 ELSE c2 FI) c1
test_true {b} btrue st st' = (forward, backward)
where forward : ((IFB b THEN c1 ELSE c2 FI) / st \\ st') ->
                (c1 / st \\ st')
      forward (E_IfTrue _ rel) = rel
      forward (E_IfFalse prf _) = absurd $ trans (sym $ btrue st) prf
      backward : (c1 / st \\ st') ->
                 ((IFB b THEN c1 ELSE c2 FI) / st \\ st')
      backward rel = E_IfTrue (btrue st) rel

test_false : BEquiv b BFalse -> CEquiv (IFB b THEN c1 ELSE c2 FI) c2
test_false {b} bfalse st st' = (forward, backward)
where forward : ((IFB b THEN c1 ELSE c2 FI) / st \\ st') ->
                (c2 / st \\ st')
      forward (E_IfTrue prf _) = absurd $ trans (sym $ bfalse st) prf
      forward (E_IfFalse _ rel) = rel
      backward : (c2 / st \\ st') ->
                 ((IFB b THEN c1 ELSE c2 FI) / st \\ st')
      backward rel = E_IfFalse (bfalse st) rel

swap_if_branches : CEquiv (IFB b THEN c1 ELSE c2 FI)
                          (IFB not b THEN c2 ELSE c1 FI)
swap_if_branches {b} st st' = (forward, backward)
where forward : ((IFB b THEN c1 ELSE c2 FI) / st \\ st') ->
                ((IFB BNot b THEN c2 ELSE c1 FI) / st \\ st')
      forward (E_IfTrue prf rel) = E_IfFalse (cong {f=not} prf) rel
      forward (E_IfFalse prf rel) = E_IfTrue (cong {f=not} prf) rel
      backward : ((IFB BNot b THEN c2 ELSE c1 FI) / st \\ st') ->
                 ((IFB b THEN c1 ELSE c2 FI) / st \\ st')
      backward (E_IfTrue prf rel) =
        E_IfFalse (trans (sym $ notInvolutive (beval st b))
                         (cong {f=not} prf))
                  rel
      backward (E_IfFalse prf rel) =
        E_IfTrue (trans (sym $ notInvolutive (beval st b))
                        (cong {f=not} prf))
                 rel

if1_if_equiv : CEquiv (CIf1 b c) (CIf b c SKIP)
if1_if_equiv {b} {c} st st' = (forward, backward)
where forward : CEval (CIf1 b c) st st' -> CEval (CIf b c SKIP) st st'
      forward rel = case rel of
        E_If1True prf cc => E_IfTrue prf cc
        E_If1False prf => E_IfFalse prf E_Skip
      backward : CEval (CIf b c SKIP) st st' -> CEval (CIf1 b c) st st'
      backward rel = case rel of
        E_IfTrue prf cct => E_If1True prf cct
        E_IfFalse prf E_Skip => E_If1False prf

if1_true : BEquiv b BTrue -> CEquiv (CIf1 b c) c
if1_true {b} btrue st st' = (forward, backward)
where forward : CEval (CIf1 b c) st st' -> CEval c st st'
      forward rel = case rel of
        E_If1True _ cc => cc
        E_If1False prf => absurd $ trans (sym prf) (btrue st)
      backward : CEval c st st' -> CEval (CIf1 b c) st st'
      backward cc = E_If1True (btrue st) cc

if1_false : BEquiv b BFalse -> CEquiv (CIf1 b c) SKIP
if1_false {b} bfalse st st' = (forward, backward)
where forward : CEval (CIf1 b c) st st' -> CEval SKIP st st'
      forward rel = case rel of
        E_If1True prf _ => absurd $ trans (sym prf) (bfalse st)
        E_If1False _ => E_Skip
      backward : CEval SKIP st st' -> CEval (CIf1 b c) st st'
      backward rel = case rel of
        E_Skip => E_If1False (bfalse st)

while_false : BEquiv b BFalse -> CEquiv (WHILE b c) SKIP
while_false {b} bfalse st _ = (forward, backward)
where forward : ((WHILE b c) / st \\ st') -> (SKIP / st \\ st')
      forward rel = case rel of
        E_WhileEnd _ => E_Skip
        E_WhileLoop prf _ _ => absurd $ trans (sym $ bfalse st) prf
      backward : (SKIP / st \\ st') -> ((WHILE b c) / st \\ st')
      backward rel = case rel of
        E_Skip => E_WhileEnd (bfalse st)

while_true_nonterm : BEquiv b BTrue -> Not ((WHILE b c) / st \\ st')
while_true_nonterm {st'} btrue (E_WhileEnd prf) =
  absurd $ trans (sym $ btrue st') prf
while_true_nonterm btrue (E_WhileLoop prf rel next) =
  while_true_nonterm btrue next

while_true : BEquiv b BTrue -> CEquiv (WHILE b c) (WHILE BTrue SKIP)
while_true {b} btrue st st' = (forward, backward)
where forward : ((WHILE b c) / st \\ st') -> ((WHILE BTrue SKIP) / st \\ st')
      forward rel = case rel of
        E_WhileEnd prf => absurd $ trans (sym $ btrue st) prf
        E_WhileLoop _ _ next => void $ while_true_nonterm btrue next
      backward : ((WHILE BTrue SKIP) / st \\ st') -> ((WHILE b c) / st \\ st')
      backward rel = case rel of
        E_WhileEnd prf => absurd prf
        E_WhileLoop Refl _ next => void $ while_true_nonterm btrue_is_true next

loop_unrolling : CEquiv (WHILE b c) (IFB b THEN (do c; WHILE b c) ELSE SKIP FI)
loop_unrolling st st' = (forward, backward)
where forward : ((WHILE b c) / st \\ st') ->
                ((IFB b THEN (do c; WHILE b c) ELSE SKIP FI) / st \\ st')
      forward rel = case rel of
        E_WhileEnd prf => E_IfFalse prf E_Skip
        E_WhileLoop prf rel next => E_IfTrue prf (E_Seq rel next)
      backward : ((IFB b THEN (do c; WHILE b c) ELSE SKIP FI) / st \\ st') ->
                 ((WHILE b c) / st \\ st')
      backward (E_IfTrue prf (E_Seq rel next)) = E_WhileLoop prf rel next
      backward (E_IfFalse prf rel) = case rel of
        E_Skip => E_WhileEnd prf

for_while_equiv : CEquiv (CFor c1 b c2 c3) (CSeq c1 (CWhile b (CSeq c3 c2)))
for_while_equiv {c1} {b} {c2} {c3} st st' = (forward, backward)
where forward : ((CFor c1 b c2 c3) / st \\ st') ->
                ((CSeq c1 (CWhile b (CSeq c3 c2))) / st \\ st')
      forward (E_For cinit cwhile) = E_Seq cinit cwhile
      backward : ((CSeq c1 (CWhile b (CSeq c3 c2))) / st \\ st') ->
                 ((CFor c1 b c2 c3) / st \\ st')
      backward (E_Seq cinit cwhile) = E_For cinit cwhile

repeat_while_equiv : CEquiv (CRepeat c b) (CSeq c (CWhile (not b) c))
repeat_while_equiv {c} {b} st st' = (forward, backward)
where forward : CEval (CRepeat c b) st st' ->
                CEval (CSeq c (CWhile (not b) c)) st st'
      forward (E_Repeat cc cwhile) = E_Seq cc cwhile
      backward : CEval (CSeq c (CWhile (not b) c)) st st' ->
                 CEval (CRepeat c b) st st'
      backward (E_Seq cc cwhile) = E_Repeat cc cwhile

seq_assoc : CEquiv (do (do c1; c2); c3) (do c1; (do c2; c3))
seq_assoc st st' = (forward, backward)
where forward : ((do (do c1; c2); c3) / st \\ st') ->
                ((do c1; (do c2; c3)) / st \\ st')
      forward (E_Seq (E_Seq r1 r2) r3) = E_Seq r1 (E_Seq r2 r3)
      backward : ((do c1; (do c2; c3)) / st \\ st') ->
                 ((do (do c1; c2); c3) / st \\ st')
      backward (E_Seq r1 (E_Seq r2 r3)) = E_Seq (E_Seq r1 r2) r3

identity_assignment : CEquiv (x ::= AId x) SKIP
identity_assignment {x} st st' = (forward, backward)
where forward : ((x ::= AId x) / st \\ st') -> (SKIP / st \\ st')
      forward rel = case rel of
        E_Ass prf => rewrite sym prf
                     in rewrite t_update_same {m=st} {x=x}
                     in E_Skip
      backward : (SKIP / st \\ st') -> ((x ::= AId x) / st \\ st')
      backward rel = case rel of
        E_Skip => replace (t_update_same {m=st} {x=x}) (E_Ass Refl)
                    {P=\s => (x ::= AId x) / st \\ s}

assign_aequiv : AEquiv (AId x) e -> CEquiv SKIP (x ::= e)
assign_aequiv {x} {e} x_eq_e st st' = (forward, backward)
where forward : (SKIP / st \\ st') -> ((x ::= e) / st \\ st')
      forward rel = case rel of
        E_Skip => replace (t_update_same {m=st} {x=x}) (E_Ass (sym $ x_eq_e st))
                    {P=\s => (x ::= e) / st \\ s}
      backward : ((x ::= e) / st \\ st') -> (SKIP / st \\ st')
      backward rel = case rel of
        E_Ass prf => rewrite sym prf
                     in rewrite sym $ x_eq_e st
                     in rewrite t_update_same {m=st} {x=x}
                     in E_Skip

prog_a : Com
prog_a =
  WHILE (not (X <= 0)) $
    X ::= X + 1

prog_b : Com
prog_b = do
  IFB X == 0
      THEN do X ::= X + 1
              Y ::= 1
      ELSE Y ::= 0
  FI
  X ::= X - Y
  Y ::= 0

prog_c : Com
prog_c = SKIP

prog_d : Com
prog_d =
  WHILE (not (X == 0)) $
    X ::= X * Y + 1

prog_e : Com
prog_e = Y ::= 0

prog_f : Com
prog_f = do
  Y ::= X + 1
  WHILE (not (X == Y)) $
    Y ::= X + 1

prog_g : Com
prog_g = WHILE BTrue SKIP

prog_h : Com
prog_h =
  WHILE (not (X == X)) $
    X ::= X + 1

prog_i : Com
prog_i =
  WHILE (not (X == Y)) $
    X ::= Y + 1

equiv_classes : List (List Com)
equiv_classes = [ [prog_a, prog_f, prog_g]
                , [prog_b]
                , [prog_c, prog_h]
                , [prog_d]
                , [prog_e]
                , [prog_i] ]

refl_aequiv : AEquiv a a
refl_aequiv _ = Refl

sym_aequiv : AEquiv a1 a2 -> AEquiv a2 a1
sym_aequiv a1_equiv_a2 st = sym $ a1_equiv_a2 st

trans_aequiv : AEquiv a1 a2 -> AEquiv a2 a3 -> AEquiv a1 a3
trans_aequiv a1_equiv_a2 a2_equiv_a3 st = rewrite a1_equiv_a2 st
                                          in a2_equiv_a3 st

refl_bequiv : BEquiv b b
refl_bequiv _ = Refl

sym_bequiv : BEquiv b1 b2 -> BEquiv b2 b1
sym_bequiv b1_equiv_b2 st = sym $ b1_equiv_b2 st

trans_bequiv : BEquiv b1 b2 -> BEquiv b2 b3 -> BEquiv b1 b3
trans_bequiv b1_equiv_b2 b2_equiv_b3 st = rewrite b1_equiv_b2 st
                                          in b2_equiv_b3 st

refl_cequiv : CEquiv c c
refl_cequiv _ _ = (id, id)

sym_cequiv : CEquiv c1 c2 -> CEquiv c2 c1
sym_cequiv c1_equiv_c2 st st' = swap $ c1_equiv_c2 st st'

trans_cequiv : CEquiv c1 c2 -> CEquiv c2 c3 -> CEquiv c1 c3
trans_cequiv c1_equiv_c2 c2_equiv_c3 st st' =
  let (forward_c1_c2, backward_c2_c1) = c1_equiv_c2 st st'
      (forward_c2_c3, backward_c3_c2) = c2_equiv_c3 st st'
  in (forward_c2_c3 . forward_c1_c2, backward_c2_c1 . backward_c3_c2)

cAss_congruence : AEquiv a1 a2 -> CEquiv (x ::= a1) (x ::= a2)
cAss_congruence {a1} {a2} a1_equiv_a2 st st' = (forward, backward)
where forward : ((x ::= a1) / st \\ st') -> ((x ::= a2) / st \\ st')
      forward rel = case rel of
        E_Ass prf => rewrite sym prf
                     in rewrite a1_equiv_a2 st
                     in E_Ass Refl
      backward : ((x ::= a2) / st \\ st') -> ((x ::= a1) / st \\ st')
      backward rel = case rel of
        E_Ass prf => rewrite sym prf
                     in rewrite sym $ a1_equiv_a2 st
                     in E_Ass Refl

cWhile_congruence : BEquiv b1 b2 -> CEquiv c1 c2 ->
                    CEquiv (WHILE b1 c1) (WHILE b2 c2)
cWhile_congruence {b1} {b2} {c1} {c2} b1_equiv_b2 c1_equiv_c2 _ _ =
  (forward, backward)
where forward : ((WHILE b1 c1) / st \\ st') -> ((WHILE b2 c2) / st \\ st')
      forward {st} rel = case rel of
        E_WhileEnd prf => E_WhileEnd $ trans (sym $ b1_equiv_b2 st) prf
        E_WhileLoop {st1} prf rel next =>
          E_WhileLoop (trans (sym $ b1_equiv_b2 st) prf)
                      (fst (c1_equiv_c2 st st1) rel)
                      (forward {st=st1} next)
      backward : ((WHILE b2 c2) / st \\ st') -> ((WHILE b1 c1) / st \\ st')
      backward {st} rel = case rel of
        E_WhileEnd prf => E_WhileEnd $ trans (b1_equiv_b2 st) prf
        E_WhileLoop {st1} prf rel next =>
          E_WhileLoop (trans (b1_equiv_b2 st) prf)
                      (snd (c1_equiv_c2 st st1) rel)
                      (backward {st=st1} next)

cSeq_congruence : CEquiv c1 c2 -> CEquiv c3 c4 -> CEquiv (do c1; c3) (do c2; c4)
cSeq_congruence {c1} {c2} {c3} {c4} c1_equiv_c2 c3_equiv_c4 st st' =
  (forward, backward)
where forward : ((do c1; c3) / st \\ st') -> ((do c2; c4) / st \\ st')
      forward (E_Seq {st2} r1 r2) = E_Seq (fst (c1_equiv_c2 st st2) r1)
                                          (fst (c3_equiv_c4 st2 st') r2)
      backward : ((do c2; c4) / st \\ st') -> ((do c1; c3) / st \\ st')
      backward (E_Seq {st2} r3 r4) = E_Seq (snd (c1_equiv_c2 st st2) r3)
                                           (snd (c3_equiv_c4 st2 st') r4)

for_false : BEquiv cond BFalse -> CEquiv (CFor init cond updt body) init
for_false {init} {cond} {updt} {body} cond_equiv =
  trans_cequiv (for_while_equiv {c1=init} {b=cond} {c2=updt} {c3=body})
               (trans_cequiv (cSeq_congruence (refl_cequiv {c=init})
                                              (while_false cond_equiv))
                             (skip_right {c=init}))

for_true : BEquiv cond BTrue -> CEquiv (CFor init cond updt body)
                                       (CSeq init (CWhile BTrue SKIP))
for_true {init} {cond} {updt} {body} cond_equiv =
  trans_cequiv (for_while_equiv {c1=init} {b=cond} {c2=updt} {c3=body})
               (cSeq_congruence (refl_cequiv {c=init}) (while_true cond_equiv))

cFor_congruence : CEquiv init1 init2 -> BEquiv cond1 cond2 ->
                  CEquiv updt1 updt2 -> CEquiv body1 body2 ->
                  CEquiv (CFor init1 cond1 updt1 body1)
                         (CFor init2 cond2 updt2 body2)
cFor_congruence init_equiv cond_equiv updt_equiv body_equiv =
  trans_cequiv for_while_equiv
               (trans_cequiv
                  (cSeq_congruence init_equiv
                                   (cWhile_congruence
                                      cond_equiv
                                      (cSeq_congruence body_equiv updt_equiv)))
                  (sym_cequiv for_while_equiv))

repeat_false : BEquiv b BFalse -> CEquiv (CRepeat c b)
                                         (CSeq c (CWhile BTrue SKIP))
repeat_false {b} {c} cond_equiv =
  let not_cond_equiv = \st1 => cong {f=not} (cond_equiv st1)
  in trans_cequiv repeat_while_equiv
                  (cSeq_congruence refl_cequiv (while_true not_cond_equiv))

repeat_true : BEquiv b BTrue -> CEquiv (CRepeat c b) c
repeat_true {b} {c} cond_equiv =
  let not_cond_equiv = \st1 => cong {f=not} (cond_equiv st1)
  in trans_cequiv repeat_while_equiv
                  (trans_cequiv (cSeq_congruence refl_cequiv
                                                 (while_false not_cond_equiv))
                                skip_right)

cRepeat_congruence : CEquiv body1 body2 -> BEquiv cond1 cond2 ->
                     CEquiv (CRepeat body1 cond1) (CRepeat body2 cond2)
cRepeat_congruence body_equiv cond_equiv =
  let not_cond_equiv = \st1 => cong {f=not} (cond_equiv st1)
  in trans_cequiv repeat_while_equiv
                  (trans_cequiv
                     (cSeq_congruence body_equiv
                                      (cWhile_congruence not_cond_equiv
                                                         body_equiv))
                     (sym_cequiv repeat_while_equiv))

cIf_congruence : BEquiv b1 b2 -> CEquiv c1 c2 -> CEquiv c3 c4 ->
                 CEquiv (IFB b1 THEN c1 ELSE c3 FI) (IFB b2 THEN c2 ELSE c4 FI)
cIf_congruence {b1} {b2} {c1} {c2} {c3} {c4}
               b1_equiv_b2 c1_equiv_c2 c3_equiv_c4 st st' =
  (forward, backward)
where forward : ((IFB b1 THEN c1 ELSE c3 FI) / st \\ st') ->
                ((IFB b2 THEN c2 ELSE c4 FI) / st \\ st')
      forward (E_IfTrue prf rel) = E_IfTrue (trans (sym $ b1_equiv_b2 st) prf)
                                            (fst (c1_equiv_c2 st st') rel)
      forward (E_IfFalse prf rel) = E_IfFalse (trans (sym $ b1_equiv_b2 st) prf)
                                              (fst (c3_equiv_c4 st st') rel)
      backward : ((IFB b2 THEN c2 ELSE c4 FI) / st \\ st') ->
                 ((IFB b1 THEN c1 ELSE c3 FI) / st \\ st')
      backward (E_IfTrue prf rel) = E_IfTrue (trans (b1_equiv_b2 st) prf)
                                             (snd (c1_equiv_c2 st st') rel)
      backward (E_IfFalse prf rel) = E_IfFalse (trans (b1_equiv_b2 st) prf)
                                               (snd (c3_equiv_c4 st st') rel)

cIf1_congruence : BEquiv b1 b2 -> CEquiv c1 c2 ->
                  CEquiv (CIf1 b1 c1) (CIf1 b2 c2)
cIf1_congruence b_equiv c_equiv =
  trans_cequiv
    (trans_cequiv if1_if_equiv
                  (cIf_congruence b_equiv c_equiv (refl_cequiv {c=SKIP})))
    (sym_cequiv if1_if_equiv)

congruence_example : CEquiv
  (do X ::= 0
      IFB X == 0
          THEN Y ::= 0
          ELSE Y ::= 42
      FI)
  (do X ::= 0
      IFB X == 0
          THEN Y ::= X - X
          ELSE Y ::= 42
      FI)
congruence_example =
  cSeq_congruence refl_cequiv
                  (cIf_congruence refl_bequiv statements_equiv refl_cequiv)
where forward : ((Y ::= 0) / st \\ st') ->
                ((Y ::= X - X) / st \\ st')
      forward {st} (E_Ass prf) = E_Ass $ trans (sym $ minusZeroN (st X)) prf
      backward : ((Y ::= X - X) / st \\ st') ->
                 ((Y ::= 0) / st \\ st')
      backward {st} (E_Ass prf) = rewrite minusZeroN (st X)
                                  in rewrite prf
                                  in E_Ass Refl
      statements_equiv : CEquiv (Y ::= 0) (Y ::= X - X)
      statements_equiv _ _ = (forward, backward)

ATransSound : (atrans : AExp -> AExp) -> Type
ATransSound atrans = (a : AExp) -> AEquiv a (atrans a)

BTransSound : (btrans : BExp -> BExp) -> Type
BTransSound btrans = (b : BExp) -> BEquiv b (btrans b)

CTransSound : (ctrans : Com -> Com) -> Type
CTransSound ctrans = (c : Com) -> CEquiv c (ctrans c)


import Data.Vect

maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)

elemOfEmptyAbsurd : Elem a [] -> Void
elemOfEmptyAbsurd Here impossible
elemOfEmptyAbsurd (There _) impossible

removeElem : (elem : a) -> (v : Vect (S n) a) -> Elem elem v -> Vect n a
removeElem elem (elem :: xs) Here = xs
removeElem {n = Z} elem (x :: []) (There later) = absurd later
removeElem {n = (S k)} elem (x :: xs) (There later) = x :: removeElem elem xs later

removeElem_auto : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a
removeElem_auto value xs {prf} = removeElem value xs prf

isElem' : DecEq a => (elem : a) -> (v : Vect n a) -> Dec (Elem elem v)
isElem' elem [] = No absurd
isElem' elem (x :: xs) = case decEq elem x of
                              (Yes Refl) => Yes Here
                              (No contraHead) => case isElem' elem xs of
                                                      (Yes prf) => Yes (There prf)
                                                      (No contraTail) => No (\prf => (case prf of
                                                                                Here => contraHead Refl
                                                                                (There later) => contraTail later))

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

data Last : List a -> a -> Type where
  LastOne : Last [a] a
  LastCons : Last as a -> Last (x :: as) a

noLastElemForEmptyList : Last [] a -> Void
noLastElemForEmptyList LastOne impossible
noLastElemForEmptyList (LastCons _) impossible

isLast : DecEq a => (xs : List a) -> (elem : a) -> Dec (Last xs elem)
isLast [] elem = No noLastElemForEmptyList
isLast [e] elem = case decEq elem e of
                       (Yes Refl) => Yes LastOne
                       (No contra) => No (\prf => (case prf of
                                                        LastOne => contra Refl
                                                        (LastCons x) => noLastElemForEmptyList x))
isLast (_ :: y :: ys) elem = case isLast (y::ys) elem of
                               (Yes prf) => Yes $ LastCons prf
                               (No contra) => No (\prf => (case prf of
                                                                (LastCons x) => contra x))


||| Lambductive core calculus
module Lambductive.Core

%default total

data Context : Type

data TypeTerm : Context -> Type

infixl 7 :::

||| De Bruijn variable context
data Context : Type where
  Nil : Context
  ||| Add a variable to a context
  ||| @type The type of the variable
  (:::) : (context : Context) -> (type : TypeTerm context) -> Context

||| Judgment of whether the interpretation of a term as a type code is reducible
data InterpretReducibility : Type where
  InterpretReducible : InterpretReducibility
  InterpretIrreducible : InterpretReducibility

data ValueTerm : (context : Context) -> TypeTerm context -> InterpretReducibility -> Type

||| Types of the calculus
data TypeTerm : Context -> Type where
  ||| A universe of type codes
  U : (level : Nat) -> TypeTerm context
  ||| Dependent function type
  Pi : (domain : TypeTerm context) -> (codomain : TypeTerm (context ::: domain)) -> TypeTerm context
  ||| An irreducible application of the type code interpretation operator
  |||
  ||| Use the `interpret` function to interpret type codes without any concern for reducibility
  IrreducibleInterpret : ValueTerm context (U level) InterpretIrreducible -> TypeTerm context

||| Bring a type into a context with an extra variable at the head
addVarToType : TypeTerm context -> TypeTerm (context ::: type)

||| An index into a context
||| @type The type of the variable at that index
data ContextIndex : (context : Context) -> (type : TypeTerm context) -> Type where
  Z : ContextIndex (_ ::: type) (addVarToType type)
  S : ContextIndex context type -> ContextIndex (context ::: type') (addVarToType type)

||| Interpret a type code to a type
interpret : ValueTerm context (U _) _ -> TypeTerm context

||| Values of the calculus
data ValueTerm : (context : Context) -> TypeTerm context -> InterpretReducibility -> Type where
  Var : ContextIndex context type -> ValueTerm context type InterpretIrreducible

interpret (Var idx) = IrreducibleInterpret (Var idx)

||| An offset into a context
data ContextOffset : Context -> Type where
  OffZ : ContextOffset context
  OffS : ContextOffset context -> ContextOffset (context ::: type)

||| Drop some variables from a context
drop : (context : Context) -> ContextOffset context -> Context
drop context OffZ = context
drop (context ::: _) (OffS off) = drop context off

||| Insert a variable into a context at a given offset
||| @type The type of the variable
insertAt : (context : Context) -> (off : ContextOffset context) -> (type : TypeTerm (drop context off)) -> Context

||| Bring a type into a context with an extra variable at a given offset
addVarToTypeAtOffset : (off : ContextOffset context) -> TypeTerm context -> TypeTerm (insertAt context off type)

insertAt context OffZ type = context ::: type
insertAt (context ::: type) (OffS off) type' = insertAt context off type' ::: addVarToTypeAtOffset off type

||| Bring a type code into a context with an extra variable at a given offset
addVarToCodeAtOffset : (off : ContextOffset context) -> ValueTerm context (U level) interpretReducible -> ValueTerm (insertAt context off type') (U level) interpretReducible

addVarToTypeAtOffset _ (U level) = U level
addVarToTypeAtOffset off (Pi domain codomain) = Pi (addVarToTypeAtOffset off domain) (addVarToTypeAtOffset (OffS off) codomain)
addVarToTypeAtOffset off (IrreducibleInterpret code) = IrreducibleInterpret (addVarToCodeAtOffset off code)

addVarToType type = addVarToTypeAtOffset OffZ type

||| Bring a value into a context with an extra variable at a given offset
addVarToValueAtOffset : (off : ContextOffset context) -> ValueTerm context type interpretReducible -> ValueTerm (insertAt context off type') (addVarToTypeAtOffset off type) interpretReducible
addVarToValueAtOffset OffZ (Var idx) = Var (S idx)
addVarToValueAtOffset (OffS off) (Var idx) = ?hole

addVarToCodeAtOffset off code = addVarToValueAtOffset off code


NatOrError : Nat -> Type
NatOrError Z = String
NatOrError (S k) = Nat

divide : (x:Nat) -> (y:Nat) -> NatOrError y
divide x Z = "Error: Division by zero"
divide x (S k) = div x (S k)


-- Copyright (c) 2017, Matthew Morris
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

module Main

fizzbuzz : Integer -> String
fizzbuzz n with (mod n 3, mod n 5)
  fizzbuzz n | (0, 0) = "fizzbuzz"
  fizzbuzz n | (0, _) = "fizz"
  fizzbuzz n | (_, 0) = "buzz"
  fizzbuzz n | _ = show n

main : IO ()
main =
  traverse_ putStrLn $ map fizzbuzz [1..100]


module Main

corecord Str a where -- Current stream is codata, not a corecord
  constructor (::)
  head : a
  tail : Str a

implementation Functor Str where
  map f (x :: xs) = (f x) :: (map f xs)

total -- marked total to check that corecords are indeed treated as coinductive types
zeros : Str Int
zeros = 0 :: zeros

ones : Str Int
ones = map (1+) zeros

main : IO ()
main = do let x = record { head = 1 } zeros
          printLn $ head zeros
          printLn $ head x
          printLn $ head (record { head = 3 } x)
          printLn $ head (tail ones)
          printLn $ head (tail (record { tail = zeros } ones))


module Door

public export
data Usage = Once | Many

public export
data Lin : (Type -> Type) -> Usage -> Type -> Type where
     Pure : (1 x :   a) -> Lin m u a
     Lift : (1 x : m a) -> Lin m Many a
     BindOnce : (1 act : Lin m Once a) ->
                (1 k : (1 x : a) -> Lin m t b) -> Lin m t b
     BindMany : (1 act : Lin m Many a) ->
                (1 k : (x : a) -> Lin m t b) -> Lin m t b

public export
data Unrestricted : Type -> Type where
     MkUn : (x : a) -> Unrestricted a

export
pure : (1 x : a) -> Lin m u a
pure = Pure

export
lift : (1 x : m a) -> Lin m Many a
lift = Lift

public export
contType : (Type -> Type) -> Usage -> Usage -> Type -> Type -> Type
contType m Once q a b = (1 x : a) -> Lin m q b
contType m Many q a b = (x : a) -> Lin m q b

public export
(>>=) : {p : _}
     -> (1 f : Lin m p a)
     -> (1 k : contType m p q a b)
     -> Lin m q b
(>>=) {p=Once} = BindOnce
(>>=) {p=Many} = BindMany

export
run : Monad m => Lin m u t -> m t
run (Pure x) = pure x
run (Lift p) = p
run (BindOnce act k)
    = do act' <- run act
         run (k act')
run (BindMany act k)
    = do act' <- run act
         run (k act')

public export
One : (Type -> Type) -> Type -> Type
One m = Lin m Once

public export
Any : (Type -> Type) -> Type -> Type
Any m = Lin m Many

data DoorState = Closed | Open

-- changes start here

openWhen : Bool -> DoorState
openWhen ok = if ok then Open else Closed

data Door : DoorState -> Type where
  MkDoor : (isOpen : Bool) -> Door (if isOpen then Open else Closed)

-- Testing that 'if' works okay in an interface
interface Doored (m : Type -> Type) where
    newDoor    : One m (Door Closed)
    knock      : (1 d : Door t)      -> One m (Door t)
    openDoor   : (1 d : Door Closed)
             ->  One m (Res Bool (\ok => Door (if ok then Open else Closed)))
    closeDoor  : (1 d : Door Open)   -> One m (Door Closed)
    deleteDoor : (1 d : Door Closed) -> Any m ()


module Main

-- base
import Data.List
import System.File

-- contrib
import Text.Parser
import Text.Parser.Core

data Direction = East
               | SouthEast
               | SouthWest
               | West
               | NorthEast
               | NorthWest

Eq Direction where
  (==) East East = True
  (==) SouthEast SouthEast = True
  (==) SouthWest SouthWest = True
  (==) West West = True
  (==) NorthEast NorthEast = True
  (==) NorthWest NorthWest = True
  (==) _ _ = False

Show Direction where
  show East = "East"
  show SouthEast = "SouthEast"
  show SouthWest = "SouthWest"
  show West = "West"
  show NorthEast = "NorthEast"
  show NorthWest = "NorthWest"

namespace Grammar
  eastWestGrammar : Grammar Char True Direction
  eastWestGrammar = terminal "Can't parse East" $ \ x =>
                    case x of
                         'e' => Just East
                         'w' => Just West
                         _ => Nothing

  northGrammar : Grammar Char True Direction
  northGrammar = terminal "Can't parse North" checkN *> terminal "Can't parse North-?" checkEW where
    checkN : Char -> Maybe ()
    checkN 'n' = Just ()
    checkN _ = Nothing

    checkEW : Char -> Maybe Direction
    checkEW 'e' = Just NorthEast
    checkEW 'w' = Just NorthWest
    checkEW _ = Nothing

  southGrammar : Grammar Char True Direction
  southGrammar = terminal "Can't parse South" checkS *> terminal "Can't parse South-?" checkEW where
    checkS : Char -> Maybe ()
    checkS 's' = Just ()
    checkS _ = Nothing

    checkEW : Char -> Maybe Direction
    checkEW 'e' = Just SouthEast
    checkEW 'w' = Just SouthWest
    checkEW _ = Nothing

  directionGrammar : Grammar Char True Direction
  directionGrammar = eastWestGrammar <|> northGrammar <|> southGrammar

  directionsGrammar : Grammar Char True (List Direction)
  directionsGrammar = many directionGrammar <* terminal "Can't parse newline" checkNewline where
    checkNewline : Char -> Maybe ()
    checkNewline '\n' = Just ()
    checkNewline _ = Nothing

  export
  dataGrammar : Grammar Char False (List (List Direction))
  dataGrammar = many directionsGrammar <* eof

record HexVector where
  constructor MkHexVector
  east, southeast, southwest : Integer

Eq HexVector where
  (==) (MkHexVector x y z) (MkHexVector x' y' z') = x == x' && y == y' && z == z'

Show HexVector where
  show (MkHexVector east southeast southwest) = "HexVector " ++ show east ++ " " ++ show southeast ++ " " ++ show southwest

namespace HexVector
  succ : Integer -> Integer
  succ = (+ 1)

  pred : Integer -> Integer
  pred x = x - 1

  export
  toHexVector : List Direction -> HexVector
  toHexVector [] = MkHexVector 0 0 0
  toHexVector (East :: xs) = record { east $= succ } (toHexVector xs)
  toHexVector (SouthEast :: xs) = record { southeast $= succ } (toHexVector xs)
  toHexVector (SouthWest :: xs) = record { southwest $= succ } (toHexVector xs)
  toHexVector (West :: xs) = record { east $= pred } (toHexVector xs)
  toHexVector (NorthEast :: xs) = record { southwest $= pred } (toHexVector xs)
  toHexVector (NorthWest :: xs) = record { southeast $= pred } (toHexVector xs)

record Coordinate where
  constructor MkCoordinate
  xCoord, yCoord : Integer

Eq Coordinate where
  (==) (MkCoordinate x y) (MkCoordinate x' y') = x == x' && y == y'

Show Coordinate where
  show (MkCoordinate x y) = "Coordinate " ++ show x ++ " " ++ show y

toCoordinate : HexVector -> Coordinate
toCoordinate (MkHexVector east southeast southwest) = MkCoordinate x y where
  x : Integer
  x = 2 * east + southeast - southwest
  y : Integer
  y = southeast + southwest

namespace countElements
  -- removes duplicates
  export
  elements : Eq a => List a -> List a -> List a
  elements [] acc = acc
  elements (x :: xs) acc with (find (== x) acc)
    elements (x :: xs) acc | Nothing = elements xs (x :: acc)
    elements (x :: xs) acc | (Just _) = elements xs acc

  occurrences : Eq a => a -> List a -> Nat
  occurrences x [] = Z
  occurrences x (y :: xs) with (x == y)
    occurrences x (y :: xs) | True = S $ occurrences x xs
    occurrences x (y :: xs) | False = occurrences x xs

  export
  countElements : List Coordinate -> List (Coordinate,Nat)
  countElements xs = f <$> elements xs [] where
    f : Coordinate -> (Coordinate,Nat)
    f x = (x,occurrences x xs)

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

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

adjacentCoordinates : Coordinate -> List Coordinate
adjacentCoordinates (MkCoordinate xCoord yCoord) =
  [ MkCoordinate (xCoord - 2) yCoord
  , MkCoordinate (xCoord + 2) yCoord
  , MkCoordinate (xCoord - 1) (yCoord + 1)
  , MkCoordinate (xCoord - 1) (yCoord - 1)
  , MkCoordinate (xCoord + 1) (yCoord + 1)
  , MkCoordinate (xCoord + 1) (yCoord - 1)
  ]

-- adjacent to: c, list of blacks: cs
countAdjacentBlacks : Coordinate -> List Coordinate -> Nat
countAdjacentBlacks c cs = length $ filter id (f <$> adjacentCoordinates c) where
  f : Coordinate -> Bool
  f adjC = case find (== adjC) cs of
                Nothing => False
                (Just _) => True

blacksToWhites : List Coordinate -> List Coordinate
blacksToWhites blacks = elements (foldr f prepWhites blacks) [] where
  prepWhites : List Coordinate
  prepWhites = concat $ adjacentCoordinates <$> blacks
  f : Coordinate -> List Coordinate -> List Coordinate
  f c cs = filter (/= c) cs

flipOnce : List Coordinate -> List Coordinate
flipOnce blacks = newBlacks where
  whites : List Coordinate
  whites = blacksToWhites blacks
  blacksWithAdjacentBlacks : List (Coordinate,Nat)
  blacksWithAdjacentBlacks = (\ c => (c,countAdjacentBlacks c blacks)) <$> blacks
  whitesWithAdjacentBlacks : List (Coordinate,Nat)
  whitesWithAdjacentBlacks = (\ c => (c,countAdjacentBlacks c blacks)) <$> whites
  newBlacks : List Coordinate
  newBlacks = elements (map fst (filter (\ (_,n) => not (n == 0 || n > 2)) blacksWithAdjacentBlacks ++ filter (\ (_,n) => n == 2) whitesWithAdjacentBlacks)) []

flipTimes : Nat -> List Coordinate -> List Coordinate
flipTimes 0 cs = cs
flipTimes (S n) cs = flipTimes n $ flipOnce cs

main : IO ()
main = do
  inputData <- readFile "./data"
  case inputData of
       Left err => print err
       Right dat => do
         let tokenList = unpack dat
             directions = parse dataGrammar tokenList
         case directions of
              (Left (Error err _)) => putStrLn err
              (Right (ds,cs)) => do
                --print ds
                let vecs = toHexVector <$> ds
                --print vecs
                let coords = toCoordinate <$> vecs
                --print coords
                let counts = countElements coords
                    flips = snd <$> counts
                    countBlacks = length $ filter odd flips
                --print countBlacks
                -- part 2
                let blackCountsOdd = filter (\ (_,c) => odd c) counts
                    blacks = fst <$> blackCountsOdd
                    newBlacks = flipTimes 100 blacks
                    countNewBlacks = length newBlacks
                print countNewBlacks
         pure ()
  pure ()


module Control.Monad.Ideal

%access public
%default total

data Ideal : (Type -> Type) -> Type -> Type where
  P : {f : Type -> Type} -> a -> Ideal f a
  I : {f : Type -> Type} -> (f a) -> Ideal f a

class Functor f => Mu' (f : Type -> Type) where
  mu' : f (Ideal f a) -> f a

instance Mu' f => Functor (Ideal f) where
  map g (P a) = P $ g a
  map g (I fa) = I $ map g fa

instance Mu' f => Applicative (Ideal f) where
  pure a = P a
  (P g) <$> x = map g x
  (I fg) <$> (P a) = I $ mu' $ map (\k => P $ k a) fg
  (I fg) <$> (I fa) = I $ mu' $ map (\k => I $ map k fa) fg

instance Mu' f => Monad (Ideal f) where
  (P a) >>= k = k a
  (I fa) >>= k = I $ mu' $ map k fa


module Main

import Data.Vect
import Control.ST
import Control.ST.ImplicitCall
import TicTacToe

start : ST m Var [add (State (Game Start InPlay))]
start = do game <- new initGame
           pure game

status : (game : Var) -> ST m GameState [game ::: State (Game b st)]
status game = pure $ currentStatus !(read game)

grid : (game : Var) -> ST m Grid [game ::: State (Game b st)]
grid game = pure $ currentGrid !(read game)

board : {b : Board g p turn} -> (game : Var) -> ST m (Board g p turn) [game ::: State (Game b st)]
board game = pure $ currentBoard !(read game)

move : {b : Board g p turn}
    -> (pos : Position)
    -> (game : Var)
    -> {auto prf : Empty pos g}
    -> ST m GameState [game ::: State (Game b InPlay) :->
                          (\st' => State (Game (Turn pos b {prf = prf}) st'))]
move pos game = do g <- read game
                   let (st' ** g') = move pos g
                   write game g'
                   pure st'

inputPosition : ConsoleIO m => ST m (Maybe Position) []
inputPosition = do putStr "Input x position: "
                   x <- inputNat
                   putStr "Input y position: "
                   y <- inputNat
                   pure [MkPair px py | x' <- x, y' <- y, px <- natToFin x' 3, py <- natToFin y' 3]
  where
    inputNat : ConsoleIO m => ST m (Maybe Nat) []
    inputNat = do input <- getStr
                  if all isDigit (unpack input)
                     then pure . Just . cast $ input
                     else pure Nothing

inputPosLoop : ConsoleIO m => ST m Position []
inputPosLoop = do Just pos <- inputPosition
                    | Nothing => do putStrLn "Bad input"
                                    inputPosLoop
                  pure pos

ExistBoard : Type
ExistBoard = (g : Grid ** p : Player ** turn : Nat ** Board g p turn)

WholeGame : (ExistBoard, EndState) -> Type
WholeGame ((_ ** _ ** _ ** b), res) = State (Game b (Ended res))

loop : ConsoleIO m
    => (game : Var)
    -> {b : Board g p turn}
    -> ST m (ExistBoard, EndState)
            [game ::: State (Game b InPlay) :-> WholeGame]
loop game {b} {g} = do putStrLn $ Grid.show g
                       pos <- inputPosLoop
                       case isEmpty pos g of
                            Yes prf => do InPlay <- move pos game
                                            | Ended end => pure ((_ ** _ ** _ ** _), end)
                                          loop game
                            No contra => do putStrLn "Position already occupied"
                                            loop game

main : IO ()
main = run $ do game <- start
                ((g ** _ ** _ ** b), res) <- loop game
                putStrLn $ Grid.show g
                case res of
                     Draw => do putStrLn "DRAW!"
                                delete game
                     Won p => do print p
                                 putStrLn " is the WINNER!"
                                 delete game


> module FastSimpleProb.MeasuresProperties

> import Data.So
> import Syntax.PreorderReasoning

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicPostulates
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.Predicates
> import FastSimpleProb.Functor
> import FastSimpleProb.Measures
> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Predicates
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Measures
> import NonNegDouble.LTEProperties
> import List.Operations
> import List.Properties
> import Fun.Operations
> import Rel.TotalPreorder
> import Pairs.Operations
> import Functor.Predicates
> import Functor.Properties

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

* Monotonicity (of |SimpleProb| measures):

> ||| Monotonicity
> Monotone : (SimpleProb NonNegDouble -> NonNegDouble) -> Type
> Monotone = Functor.Predicates.Monotone {B = NonNegDouble} {C = NonNegDouble} {F = SimpleProb} LTE LTE

* General monotonicity results

> ||| |monotoneNaturalLemma| for |SimpleProb|s
> normalizePreservesMonotonicity : (m : SimpleProb NonNegDouble -> NonNegDouble) ->
>                                  Monotone m ->
>                                  Monotone (m . normalize)
> normalizePreservesMonotonicity m mm =
>   monotoneNaturalLemma {B = NonNegDouble} {C = NonNegDouble} {F = SimpleProb}
>                        LTE LTE m mm normalize naturalNormalize

* Monotonicity of measures

> using implementation NumNonNegDouble
>   ||| |(uncurry (*)) . (cross f id)| is monotone
>   monotoneUncurryMultCrossId : {A : Type} ->
>                                (f : A -> NonNegDouble) -> (g : A -> NonNegDouble) ->
>                                (p : (a : A) -> f a `LTE` g a) ->
>                                (ap : (A, NonNegDouble)) ->
>                                uncurry (*) ((cross f id) ap) `LTE` uncurry (*) ((cross g id) ap)
>   monotoneUncurryMultCrossId {A} f g p (a, x) = s3 where
>     s1 : f a `LTE` g a
>     s1 = p a
>     s2 : (f a) * x `LTE` (g a) * x
>     s2 = monotoneMultLTE s1 (reflexiveLTE x)
>     s3 : uncurry (*) ((cross f id) (a, x)) `LTE` uncurry (*) ((cross g id) (a, x))
>     s3 = s2

> using implementation NumNonNegDouble
>   ||| |sum| is monotone
>   monotoneSum : Monotone sum
>   monotoneSum = ms where
>     ms  : {A : Type} ->
>           (f : A -> NonNegDouble) ->
>           (g : A -> NonNegDouble) ->
>           (p : (a : A) -> f a `LTE` g a) ->
>           (sp : SimpleProb A) ->
>           sum (map f sp) `LTE` sum (map g sp)
>     ms {A} f g p sp = s6 where
>       f'  : (A, NonNegDouble) -> NonNegDouble
>       f'  = uncurry (*) . (cross f id)
>       g'  : (A, NonNegDouble) -> NonNegDouble
>       g'  = uncurry (*) . (cross g id)
>       p'  : (ap : (A, NonNegDouble)) -> f' ap `LTE` g' ap
>       p'  = monotoneUncurryMultCrossId f g p
>       aps : List (A, NonNegDouble)
>       aps = toList sp
>       s1  : Prelude.Foldable.sum (map f' aps) `LTE` Prelude.Foldable.sum (map g' aps)
>       s1  = monotoneSum {A = (A, NonNegDouble)} f' g' p' aps
>       s2  : map f' aps = map (uncurry (*)) (toList (fmap f sp))
>       s2  = ( map f' aps )
>           ={ Refl }=
>             ( map ((uncurry (*)) . (cross f id)) aps )
>           ={ sym (mapFusion (uncurry (*)) (cross f id) aps) }=
>             ( map (uncurry (*)) (fmap (cross f id) aps) )
>           ={ cong (sym (toListFmapLemma f sp)) }=
>             ( map (uncurry (*)) (toList (fmap f sp)) )
>           QED
>       s3  : map g' aps = map (uncurry (*)) (toList (fmap g sp))
>       s3  = ( map g' aps )
>           ={ Refl }=
>             ( map ((uncurry (*)) . (cross g id)) aps )
>           ={ sym (mapFusion (uncurry (*)) (cross g id) aps) }=
>             ( map (uncurry (*)) (fmap (cross g id) aps) )
>           ={ cong (sym (toListFmapLemma g sp)) }=
>            ( map (uncurry (*)) (toList (fmap g sp)) )
>           QED
>       s4  : Prelude.Foldable.sum (map (uncurry (*)) (toList (fmap f sp))) `LTE` Prelude.Foldable.sum (map g' aps)
>       s4  = replace {P = \ X => Prelude.Foldable.sum X `LTE` (Prelude.Foldable.sum (map g' aps))} s2 s1
>       s5  : Prelude.Foldable.sum (map (uncurry (*)) (toList (fmap f sp))) `LTE` Prelude.Foldable.sum (map (uncurry (*)) (toList (fmap g sp)))
>       s5  = replace {P = \ X => Prelude.Foldable.sum (map (uncurry (*)) (toList (fmap f sp))) `LTE` Prelude.Foldable.sum X} s3 s4
>       s6  : sum (fmap f sp) `LTE` sum (fmap g sp)
>       s6  = s5

> ||| |expectedValue| is monotone
> monotoneExpectedValue : Monotone expectedValue
> monotoneExpectedValue = normalizePreservesMonotonicity sum monotoneSum

> {-

> ---}


import Data.Vect

read_vect_len : (len : Nat) -> IO (Vect len String)
read_vect_len Z = pure []
read_vect_len (S k) = do x <- getLine
                         xs <- read_vect_len k
                         pure (x :: xs)

data VectUnknown : Type -> Type where
  MkVect : (len : Nat) -> Vect len a -> VectUnknown a

read_vect : IO (len ** Vect len String)
read_vect = do x <- getLine
               if (x == "")
                  then pure (_ ** [])
                  else do (_ ** xs) <- read_vect
                          pure (_ ** x :: xs)


module Main

import Data.Fin
import Data.Vect

--------------------------------------------------------------------------------
-- Player

data Player = X | O | N  -- N means nobody
instance Eq Player where
    X == X = True
    O == O = True
    N == N = True
    _ == _ = False
instance Show Player where
    show X = "X"
    show O = "O"
    show N = " "

otherPlayer : Player -> Player
otherPlayer p = case p of
    X => O
    O => X
    N => N

--------------------------------------------------------------------------------
-- BoardSquares (and accessors)

BoardSquares : Type
BoardSquares = Vect 9 Player

blankBoardSquares : BoardSquares
blankBoardSquares = [N,N,N,N,N,N,N,N,N]

rows : BoardSquares -> Vect 3 (Vect 3 Player)
rows [a,b,c,d,e,f,g,h,i] = [[a,b,c],[d,e,f],[g,h,i]]

cols : BoardSquares -> Vect 3 (Vect 3 Player)
cols sqs = transpose (rows sqs)

--------------------------------------------------------------------------------
-- Board (and Accessors)

record Board : Type where
    MkBoard : (squares : BoardSquares) ->
              (whoseTurn : Player) -> Board

initialBoard : Board
initialBoard = MkBoard blankBoardSquares X

BoardLocation : Type
BoardLocation = Fin 9

{-
-- TODO: Need to fix type of (+) in the standard library first.
--       Should be:      (Fin n) -> (Fin m) -> (Fin (n + m - 1))
--       But is instead: (Fin n) -> (Fin m) -> (Fin (n + m))
mkBoardLocation : Fin 3 -> Fin 3 -> BoardLocation
mkBoardLocation x y =
    (y + y + y) + x
     3   5   7    9
 -}

square : Board -> BoardLocation -> Player
square b loc =
    index loc (squares b)

isPositionOccupied : Board -> BoardLocation -> Bool
isPositionOccupied b loc =
    (square b loc) /= N

--------------------------------------------------------------------------------
-- winner : BoardSquares -> Maybe Player

allEqTo : Eq t => t -> Vect n t -> Bool
allEqTo e Nil       = True
allEqTo e (x :: xs) = if x == e then (allEqTo e xs)
                                else False

allEq : Eq t => Vect n t -> Bool
allEq Nil       = True
allEq (x :: xs) = allEqTo x xs

winnerInList : Vect (S n') Player -> Maybe Player
winnerInList (x :: xs) =
    let isWinner = allEq (x :: xs) in
    if isWinner then if x /= N then Just x
                               else Nothing
                else Nothing

-- TODO: Surely this is in the standard library...
firstJust : Vect n (Maybe t) -> Maybe t
firstJust Nil       = Nothing
firstJust (m :: ms) =
    case m of
        Nothing => firstJust ms
        Just x  => Just x

-- TODO: Surely this is in the standard library...
firstJust' : List (Maybe t) -> Maybe t
firstJust' Nil       = Nothing
firstJust' (m :: ms) =
    case m of
        Nothing => firstJust' ms
        Just x  => Just x

winnerRowCol : BoardSquares -> Maybe Player
winnerRowCol sqs = firstJust' [firstJust (map winnerInList (rows sqs)),
                               firstJust (map winnerInList (cols sqs))]

winnerDiag : BoardSquares -> Maybe Player
winnerDiag [a,b,c,d,e,f,g,h,i] =
    if      a == e && e == i && a /= N then Just a
    else if c == e && e == g && c /= N then Just c
                                       else Nothing

{-
-- TODO: Surely this is in the standard library...
-- TODO: Figure out why I can't match on Nil. Compile error.
-- TODO: Rename "eType" to "E" without confusing the compiler.
-- TODO: Reorder arguments to be: Vect n eType -> eType -> Maybe (Fin n)
indexOf : Eq eType => {n:Nat} -> eType -> Vect n eType -> Maybe (Fin n)
indexOf {n} e v =
    case v of
        Nil =>
            Nothing
        x::xs =>
            case (x == e) of
                True =>
                    Just (the (Fin n) 0)
                False =>
                    case (indexOf e xs) of
                        Just index => index + 1  -- NOTE: requires linear memory
                        Nothing    => Nothing
-}

-- TODO: Surely this is in the standard library...
contains : Eq eType => Vect n eType -> eType -> Bool
contains Nil e =
    False
contains (x::xs) e =
    (e == x) || (contains xs e)

winnerTie : BoardSquares -> Maybe Player
winnerTie sqs =
    if (contains sqs N) then Nothing
                        else Just N

winner : BoardSquares -> Maybe Player
winner sqs = firstJust' [winnerRowCol sqs, winnerDiag sqs, winnerTie sqs]

--------------------------------------------------------------------------------
-- Board Mutators

-- TODO: Exercise: Refuse to play at an occupied location at *compile* time
-- TODO: Exercise: Refuse to play if there is a winner at *compile* time
move : Board -> BoardLocation -> Maybe Board
move b loc =
    if (not (isJust (winner (squares b)))) &&
       (not (isPositionOccupied b loc)) then
        Just (MkBoard (replaceAt loc (whoseTurn b) (squares b))
                                  (otherPlayer (whoseTurn b)))
    else
        Nothing

-- TODO: Implement a takeMoveBack method
-- TODO: Exercise: Refuse to take back a move on an empty board at *compile* time

--------------------------------------------------------------------------------
-- Main

-- NOTE: Implementation is probably quadratic time unless recursive string
--       appends are specially optimized. Unlikely.
--
-- TODO: Figure out how to make this work with (List String)
--       in addition to (Vect n String). Probably some kind of
--       type generalization is required.
intercalateAcc : String -> Vect n String -> String -> String
intercalateAcc separator Nil result =
    result
intercalateAcc separator (x::xs) result =
    intercalateAcc separator xs (result ++ separator ++ x)

intercalate : String -> Vect n String -> String
intercalate separator Nil =
    ""
intercalate separator (x::xs) =
    intercalateAcc separator xs x

formatCell : Player -> String
formatCell cell =
    " " ++ (show cell) ++ " "

formatBoardRow : Vect 3 Player -> String
formatBoardRow row =
    intercalate "|" (map formatCell row)

formatBoardSquares : BoardSquares -> String
formatBoardSquares sqs =
    intercalate "\n---|---|---\n" (map formatBoardRow (rows sqs))

formatBoard : Board -> String
formatBoard board =
    formatBoardSquares (squares board)

inputFin : (n:Nat) -> IO (Fin n)
inputFin n = do
    line <- getLine
    -- TODO: Detect and reject non-integer input
    let int = the Integer (cast line)
    case (integerToFin int n) of
        Just int' => return int'
        Nothing   => inputFin n  -- out of bounds; try again

runGame : Board -> IO ()
runGame board = do
    putStrLn (formatBoard board)
    putStrLn ""
    case (winner (squares board)) of
        Just theWinner =>
            case theWinner of
                N => putStrLn "Tie!"
                _ => putStrLn ((show theWinner) ++ " wins!")
        Nothing => do
            putStr "Next move? (0-8) "
            loc' <- inputFin 9
            putStrLn ""
            let loc = the BoardLocation loc'
            case (move board loc) of
                Just newBoard => runGame newBoard
                Nothing       => runGame board    -- illegal move; try again

main : IO ()
main = do
    runGame initialBoard


module Apply

-- These are not Biapplicatives.  Those are in Data.Biapplicative

import Bifunctor

infixl 4 <<$>>, <<&>>, <<.>>, <<., .>>, <<..>>

||| Primarily used to make the definitions of bilift2 and bilift3 pretty
|||
||| ```idris example
||| bimap const const <<$>> (1, 2) <<.>> (3, 4) == (1, 2)
||| ```
|||
export
(<<$>>) : (a -> b) -> a -> b
(<<$>>) = id

||| <<$>> with the arguments reversed
|||
||| ```idris example
||| (1, 2) <<&>> bimap const const <<.>> (3, 4) == (1, 2)
||| ```
|||
(<<&>>) : a -> (a -> b) -> b
(<<&>>) = flip id

||| Biapplys (not to be confused with Biapplicatives)
||| @p The action of the Biapply on pairs of objects
public export
interface Bifunctor p => Biapply (p : Type -> Type -> Type) where

  ||| Applys a Bifunctor of functions to another Bifunctor of the same type
  |||
  ||| ````idris example
  ||| (reverse, (\x => x + 1)) <<.>> ("hello", 1) == ("olleh", 2)
  ||| ````
  |||
  (<<.>>) : p (a -> b) (c -> d) -> p a c -> p b d

  ||| Given two Bifunctors, sequences them leftwards
  |||
  ||| ````idris example
  ||| ("hello", 1) <<. ("goodbye", 2) == ("hello", 1)
  ||| ````
  |||
  (<<.) : p a b -> p c d -> p a b
  a <<. b = bimap const const <<$>> a <<.>> b

  ||| Given two Bifunctors, sequences them rightwards
  |||
  ||| ````idris example
  ||| ("hello", 1) <<. ("goodbye", 2) == ("goodbye", 2)
  ||| ````
  |||
  (.>>) : p a b -> p c d -> p c d
  a .>> b = bimap (const id) (const id) <<$>> a <<.>> b

||| Lifts a pair of binary functions into a Bifunctor
|||
||| ````idris example
||| bilift2 (++) (+) ("hello", 1) ("goodbye", 2) == ("hellogoodbye", 3)
||| ````
|||
bilift2 : Biapply p => (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
bilift2 f g a b = bimap f g <<$>> a <<.>> b

||| Lifts a pair of ternary functions into a Bifunctor
|||
||| ````idris example
||| bilift3 (\x,y,z => x ++ (y ++ z)) (\x,y,z => x + (y + z))
|||         ("hello", 1) ("goodbye", 2) ("hello again", 3) ==
||| ("hellogoodbyehello again", 6)
||| ````
|||
bilift3 : Biapply p => (a -> b -> c -> d) -> (e -> f -> g -> h)
        -> p a e -> p b f -> p c g -> p d h
bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c

||| Applies the second of two Bifunctors to the first
|||
||| ````idris example
||| ("hello", 1) <<..>> (reverse, (\x => x + 1)) == ("olleh", 2)
||| ````
|||
(<<..>>): Biapply p => p a c -> p (a -> b) (c -> d) -> p b d
(<<..>>) = flip (<<.>>)

implementation Biapply Pair where
  (f, g) <<.>> (a, b) = (f a, g b)


module MSubst

-- Multiple substitution in order to
-- turn a term that is well-typed in
-- a context into a closed term (i.e.
-- into a term that is well-typed in
-- the empty context).

import R
import Subst
import SubstLemmas
import Term
import Typing

%default total
%access export

-------------------------------------------------------------
-- Begin: VALUE ENVIRONMENT THAT IS COMPATIBLE WITH A CONTEXT

public export
data VEnv : Context -> Type where
  VNil  : VEnv []
  VCons : (e : Term) -> Value e -> r s e ->
          VEnv ctx ->
          VEnv (s::ctx)

-- End: VALUE ENVIRONMENT THAT IS COMPATIBLE WITH A CONTEXT
-----------------------------------------------------------

-------------------------------
-- Begin: MULTIPLE SUBSTITUTION

public export
msubst : Term -> (i : Nat) -> VEnv ctx -> Term
msubst e _ VNil = e
msubst e i (VCons x _ _ venv) =
  let e' = subst x i e
  in msubst e' i venv

-- End: MULTIPLE SUBSTITUTION
-----------------------------

-------------------
-- Begin: WEAKENING

-- Weakening means extending a typing context
-- of a term 'e' on the right. This leaves the
-- de Bruijn indices that are referenced in 'e'
-- unchanged.
-- Weakening can be implemented with the 'shiftTerm'
-- operation by using a cutoff that is exactly the
-- length of the typing context.
-- Weakening is useful in the subsequent reasoning
-- about the 'msubst' operation.

weaken : (e : Term) ->
         Typing ctx e t ->
         Context ->
         Term
weaken e {ctx} _ ctx' = shiftTerm (length ctx) (length ctx') e

-- Weakening does not actually change a term:
weakenIdentity : (e : Term) ->
                 (ty : Typing ctx e t) ->
                 (ctx' : Context) ->
                 weaken e ty ctx' = e
weakenIdentity e {ctx} ty ctx' =
  let eq1 = shiftTermPastCtx e ctx ty Z (length ctx')
      eq2 = plusZeroRightNeutral (length ctx)
      eq3 = cong {f = \q => shiftTerm q (length ctx') e} (sym eq2)
  in trans eq3 eq1

-- Weakening preserves typing, albeit in
-- an extended context:
weakenPreservesTy : (e : Term) ->
                    (ty : Typing ctx e t) ->
                    (ctx' : Context) ->
                    Typing (ctx++ctx') (weaken e ty ctx') t
weakenPreservesTy e {ctx} {t} ty ctx' =
  let eq1 = appendNilRightNeutral ctx
      ty1 = replace {P = \q => Typing q e t} (sym eq1) ty
      ty2 = shiftTermTy e {ctx1=ctx} {ctx2=[]} ty1 ctx'
      e'  = shiftTerm (length ctx) (length ctx') e
      eq2 = appendNilRightNeutral ctx'
  in replace {P = \q => Typing (ctx++q) e' t} eq2 ty2

-- End: WEAKENING
-----------------

--------------------------------------------
-- Begin: LEMMAS ABOUT MULTIPLE SUBSTITUTION

-- Multiple substitution preserves typing:
mSubstPreservesTy : (e : Term) ->
                    Typing (ctx1++ctx2) e t ->
                    (venv : VEnv ctx2) ->
                    Typing ctx1 (msubst e (length ctx1) venv) t
mSubstPreservesTy e ty {t} VNil {ctx1} =
  let eq = appendNilRightNeutral ctx1
  in replace {P = \q => Typing q e t} eq ty
mSubstPreservesTy e ty {t} (VCons x _ rx venv) {ctx1} {ctx2 = s::ctx2} =
  let tyx  = rTyping x rx
      x'   = weaken x tyx ctx2
      tyx1 = weakenPreservesTy x tyx ctx2
      ty'  = substPreservesTy {ctx1=ctx1} e ty x' tyx1
      eq1  = weakenIdentity x tyx ctx2
      ty'' = replace {P = \q => Typing (ctx1++ctx2) (subst q (length ctx1) e) t} eq1 ty'
  in mSubstPreservesTy (subst x (length ctx1) e) ty'' venv

-- Multiple substitution acts as the identity
-- on an expression 'e' if 'e' is typed in the
-- context 'ctx' but multiple substitution only
-- takes place at an index 'i' that is equal to
-- or greater than 'length ctx':
mSubstPastCtx : (e : Term) ->
                (ctx : Context) ->
                (Typing ctx e t) ->
                (venv : VEnv ctx') ->
                msubst e (length ctx) venv = e
mSubstPastCtx e ctx ty VNil = Refl
mSubstPastCtx e ctx ty (VCons x _ rx venv) {t} {ctx' = s::ctx'} =
  let e'  = weaken e ty [s]
      ty1 = weakenPreservesTy e ty [s]
      tyx = rTyping x rx
      ty2 = substPreservesTy {ctx1=ctx} {ctx2=[]} e' ty1 x tyx
      eq1 = appendNilRightNeutral ctx
      ty3 = replace {P = \q => Typing q (subst x (length ctx) e') t} eq1 ty2
      eq2 = weakenIdentity e ty [s]
      ty4 = replace {P = \q => Typing ctx (subst x (length ctx) q) t} eq2 ty3
      ih  = mSubstPastCtx (subst x (length ctx) e) ctx ty4 venv
      eq3 = substPastCtx e ctx ty {n=0}
      eq4 = cong {f = \q => subst x q e} $ plusZeroRightNeutral (length ctx)
      eq5 = trans (sym eq4) eq3
  in trans ih eq5

-- Multiple subsitution commutes with (ordinary) substitution:
mSubstSubstSwap : (e : Term) ->
                  (i : Nat) -> (venv : VEnv ctx) ->
                  (y : Term) -> Typing [] y s ->
                  subst y i (msubst e (S i) venv) = msubst (subst y i e) i venv
mSubstSubstSwap e i VNil y tyy = Refl
mSubstSubstSwap e i (VCons x _ _ venv) y tyy =
  let eq1 = substSwap e i y x tyy
      eq2 = cong {f = \q => msubst q i venv} eq1
      ih  = mSubstSubstSwap (subst x (S i) e) i venv y tyy
  in trans ih (sym eq2)

-- Following multiple substitution with an ordinary
-- substitution amounts to multiple substitution in
-- an extended environment:
mSubstSubstSwap' : (e : Term) ->
                   (i : Nat) -> (venv : VEnv ctx) ->
                   (y : Term) -> (vy : Value y) -> (ry : r s y) ->
                   subst y i (msubst e (S i) venv) = msubst e i (VCons y vy ry venv)
mSubstSubstSwap' e i venv y vy ry = mSubstSubstSwap e i venv y (rTyping y ry)

-- End: LEMMAS ABOUT MULTIPLE SUBSTITUTION
------------------------------------------

---------------------------------------------------------------
-- Begin: MULTIPLE SUBSTITUTION COMMUTES WITH TERM CONSTRUCTORS

mSubstAbsComm : (e : Term) ->
                (i : Nat) -> (venv : VEnv ctx) ->
                TAbs (msubst e (S i) venv) = msubst (TAbs e) i venv
mSubstAbsComm e _ VNil = Refl
mSubstAbsComm e i (VCons x _ _ venv) = mSubstAbsComm (subst x (S i) e) i venv

mSubstAppComm : (e1 : Term) -> (e2 : Term) ->
                (i : Nat) -> (venv : VEnv ctx) ->
                TApp (msubst e1 i venv) (msubst e2 i venv) = msubst (TApp e1 e2) i venv
mSubstAppComm e1 e2 i VNil = Refl
mSubstAppComm e1 e2 i (VCons x _ _ venv) =
  mSubstAppComm (subst x i e1) (subst x i e2) i venv

mSubstRecComm : (e1 : Term) -> (e2 : Term) -> (e3 : Term) ->
                (i : Nat) -> (venv : VEnv ctx) ->
                TRec (msubst e1 i venv) (msubst e2 i venv) (msubst e3 i venv) =
                  msubst (TRec e1 e2 e3) i venv
mSubstRecComm e1 e2 e3 i VNil = Refl
mSubstRecComm e1 e2 e3 i (VCons x _ _ venv) =
  mSubstRecComm (subst x i e1) (subst x i e2) (subst x i e3) i venv

mSubstSuccComm : (e : Term) ->
                 (i : Nat) -> (venv : VEnv ctx) ->
                 TSucc (msubst e i venv) = msubst (TSucc e) i venv
mSubstSuccComm e i VNil = Refl
mSubstSuccComm e i (VCons x _ _ venv) =
  mSubstSuccComm (subst x i e) i venv

mSubstPredComm : (e : Term) ->
                 (i : Nat) -> (venv : VEnv ctx) ->
                 TPred (msubst e i venv) = msubst (TPred e) i venv
mSubstPredComm e i VNil = Refl
mSubstPredComm e i (VCons x _ _ venv) =
  mSubstPredComm (subst x i e) i venv

mSubstIfzComm : (e1 : Term) -> (e2 : Term) -> (e3 : Term) ->
                (i : Nat) -> (venv : VEnv ctx) ->
                TIfz (msubst e1 i venv) (msubst e2 i venv) (msubst e3 i venv) =
                  msubst (TIfz e1 e2 e3) i venv
mSubstIfzComm e1 e2 e3 i VNil = Refl
mSubstIfzComm e1 e2 e3 i (VCons x _ _ venv) =
  mSubstIfzComm (subst x i e1) (subst x i e2) (subst x i e3) i venv

-- End: MULTIPLE SUBSTITUTION COMMUTES WITH TERM CONSTRUCTORS
-------------------------------------------------------------


import Data.Fin

foo : (n : Nat) -> (i : Fin n) -> Bool
foo n@(_) i = ?foo_rhs


module Lambdapants.Environment

import Lambdapants.Term
import Lambdapants.Term.Nats
import Lambdapants.Term.Reduction

%default total

public export
Environment : Type
Environment = List (String, Term)

export
substEnv : Term -> Environment -> Term
substEnv = foldr (uncurry substitute)

export
encodeNats : Term -> Term
encodeNats = enc [] where
  enc : List String -> Term -> Term
  enc bound (Var name) =
    if not (elem name bound) && all isDigit (unpack name)
       then let num = cast name in
                if num > 800 -- Treat numbers larger than 800 as literals
                   then Var name
                   else encoded num
       else Var name
  enc bound (App t u) = App (enc bound t) (enc bound u)
  enc bound (Lam v t) = Lam v (enc (v :: bound) t)

export
closed : Term -> Environment -> Term
closed = substEnv . encodeNats


module Main
import Types
import Lib

---Testcase calculateDeltas--PASS

main: IO()
main = do
  let thetas = (0, 0)
  let alpha = 0.3
  let trainingset = [(0.0,50.0), (1.0,60.0), (2.0,70.0)]
  let iterations = 1
  print $ show $ linearRegression thetas alpha trainingset iterations

--Results for the test -50.0

--Testcase adjustDeltas -- PASS
--main: IO()
--main = do
--  let deltas = [6.0, 5.2]
--  let examples = [(7.0,50.0), (2.0,3.0)]
--  print $ adjustDeltas deltas examples


module Average

export
average : String -> Double
average s = (cast (totalLength s)) / (cast (numWords s))
  where
    totalLength : String -> Nat
    totalLength s = sum (map length (words s))

    numWords : String -> Nat
    numWords x = length (words x)


module Main

numTest : (Num a, Show a) => a -> a -> IO ()
numTest a b = do
  putStrLn $ show a ++ " + " ++ show b ++ " = " ++ show (a + b)
  putStrLn $ show a ++ " * " ++ show b ++ " = " ++ show (a * b)

integralTest : (Integral a, Show a) => a -> a -> IO ()
integralTest a b = do
  putStrLn $ show a ++ " div " ++ show b ++ " = " ++ show (a `div` b)
  putStrLn $ show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)

fractionalTest : (Fractional a, Show a) => a -> a -> IO ()
fractionalTest a b = do
  putStrLn $ show a ++ " / " ++ show b ++ " = " ++ show (a / b)
  putStrLn $ "recip " ++ show a ++ " = " ++ show (recip a)
  putStrLn $ "recip " ++ show b ++ " = " ++ show (recip b)

showOrdering : Ordering -> String
showOrdering EQ = "EQ"
showOrdering LT = "LT"
showOrdering GT = "GT"

ordTest : (Ord a, Show a) => a -> a -> IO ()
ordTest a b = putStrLn $ "compare " ++ show a ++ " " ++ show b ++ " = " ++ showOrdering (compare a b)

int1 : Int
int1 = 2147483647

int2 : Int
int2 = -2147483648

int3 : Int
int3 = 4

integer1 : Integer
integer1 = 100000000000000009

integer2 : Integer
integer2 = 200000000000000008

bits8_1: Bits8
bits8_1 = 255

bits8_2: Bits8
bits8_2 = 255

bits16_1: Bits16
bits16_1 = 4097

bits16_2: Bits16
bits16_2 = 512

bits32_1: Bits32
bits32_1 = 8388608

bits32_2: Bits32
bits32_2 = 524288

bits64_1: Bits64
bits64_1 = 9223372036854775807

bits64_2: Bits64
bits64_2 = 281474976710656

double1 : Double
double1 = 24.234234

double2 : Double
double2 = 75676.23232

printHeader : String -> IO ()
printHeader header = do
  putStrLn ""
  putStrLn header
  putStrLn $ concat $ replicate (length header) "="

pythag : Int -> List (Int, Int, Int)
pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y],
                          x * x + y * y == z * z]
main : IO ()
main = do
  print "Hello "
  putStrLn "world!"
  printHeader "numTest on Int"
  numTest int1 int2

  printHeader "numTest on Integer"
  numTest integer1 integer2

  printHeader "numTest on Bits8"
  numTest bits8_1 bits8_2

  printHeader "numTest on Bits16"
  numTest bits16_1 bits16_2

  printHeader "numTest on Bits32"
  numTest bits32_1 bits32_2

  printHeader "numTest on Bits64"
  numTest bits64_1 bits64_2

  printHeader "numTest on Double"
  numTest double1 double2

  printHeader "integralTest on Int"
  integralTest int1 int2

  printHeader "integralTest on Integer"
  integralTest integer1 integer2

  printHeader "integralTest on Bits8"
  integralTest bits8_1 bits8_2

  printHeader "integralTest on Bits16"
  integralTest bits16_1 bits16_2

  printHeader "integralTest on Bits32"
  integralTest bits32_1 bits32_2

  printHeader "integralTest on Bits64"
  integralTest bits64_1 bits64_2

  printHeader "fractionalTest on Double"
  fractionalTest double1 double2

  printHeader "ordTest on Int"
  ordTest int1 int2

  printHeader "ordTest on Integer"
  ordTest integer1 integer2

  printHeader "ordTest on Bits8"
  ordTest bits8_1 bits8_2

  printHeader "ordTest on Bits16"
  ordTest bits16_1 bits16_2

  printHeader "ordTest on Bits32"
  ordTest bits32_1 bits32_2

  printHeader "ordTest on Bits64"
  ordTest bits64_1 bits64_2

  printHeader "ordTest on Double"
  ordTest double1 double2

  putStrLn ""
  printLn $ pythag 50


||| Defines functions to use in place of `RegExp`'s data constructors, in order to create
||| regular expressions which are "normalized" to a canonical form as much as possible. This adds
||| some compile-time complexity but results in smaller DFAs for testing language membership.
module RegExp.Equivalences

import Data.List
import Decidable.Equality

import public RegExp.Types

%default total

||| Constructs a "normalized" `Cat`, which applies the following rules:
|||   - ∅ · r ≈ ∅
|||   - r · ∅ ≈ ∅
|||   - ε · r ≈ r
|||   - r · ε ≈ r
|||   - (r · s) · t ≈ r · (s · t)
export
normCat : DecEq a => RegExp a -> RegExp a -> RegExp a
normCat Null      _     = Null
normCat _         Null  = Null
normCat Empty     r     = r
normCat r         Empty = r
normCat (Cat r s) t     = Cat r (Cat s t)
normCat r         s     = Cat r s

||| Constructs a "normalized" `Disj`, which applies the following rules:
|||
|||   - ∅ + r ≈ r
|||   - r + r ≈ r
|||   - (r + s) + t ≈ r + (s + t)
|||
||| Note that the remaining equivalence (symmetry) is not captured:
|||
|||   - r + s ≈ s + r
export
normDisj : DecEq a => RegExp a -> RegExp a -> RegExp a
normDisj Null r    = r
normDisj r    Null = r
normDisj r s with (decEq r s)
  normDisj r          r | (Yes Refl) = r
  normDisj (Disj r s) t | (No _)     = Disj r (Disj s t)
  normDisj r          s | (No _)     = Disj r s

||| Constructs a "normalized" `Conj`, which applies the following rules:
|||   - ∅ & r ≈ ∅
|||   - r & r ≈ r
|||   - (r & s) & t ≈ r & (s & t)
|||
||| Note that the remaining equivalence (symmetry) is not captured:
|||
|||   - r & s ≈ s & r
export
normConj : DecEq a => RegExp a -> RegExp a -> RegExp a
normConj Null _    = Null
normConj _    Null = Null
normConj r s with (decEq r s)
  normConj r r          | (Yes Refl) = r
  normConj (Conj r s) t | (No _)     = Conj r (Conj s t)
  normConj r s          | (No _)     = Conj r s

||| Proof (by exhaustion) that `normCat` is sound.
export
normCat_isSound : DecEq a =>
                  {xs : List a} ->
                  {r : RegExp a} ->
                  {s : RegExp a} ->
                  Matches (normCat r s) xs ->
                  Matches (Cat r s) xs
normCat_isSound      {r=Null}       {s}            p = absurd p
normCat_isSound      {r=Empty}      {s=Null}       p = absurd p
normCat_isSound      {r=Empty}      {s=Empty}      p = InCat Refl InEmpty p
normCat_isSound      {r=Empty}      {s=(Lit _)}    p = InCat Refl InEmpty p
normCat_isSound      {r=Empty}      {s=(Cat _ _)}  p = InCat Refl InEmpty p
normCat_isSound      {r=Empty}      {s=(Disj _ _)} p = InCat Refl InEmpty p
normCat_isSound      {r=Empty}      {s=(Conj _ _)} p = InCat Refl InEmpty p
normCat_isSound      {r=Empty}      {s=(Star _)}   p = InCat Refl InEmpty p
normCat_isSound      {r=(Lit _)}    {s=Null}       p = absurd p
normCat_isSound {xs} {r=(Lit _)}    {s=Empty}      p = InCat (sym $ appendNilRightNeutral xs) p InEmpty
normCat_isSound      {r=(Lit _)}    {s=(Lit _)}    p = p
normCat_isSound      {r=(Lit _)}    {s=(Cat _ _)}  p = p
normCat_isSound      {r=(Lit _)}    {s=(Disj _ _)} p = p
normCat_isSound      {r=(Lit _)}    {s=(Conj _ _)} p = p
normCat_isSound      {r=(Lit _)}    {s=(Star _)}   p = p
normCat_isSound      {r=(Cat _ _)}  {s=Null}       p = absurd p
normCat_isSound {xs} {r=(Cat _ _)}  {s=Empty}      p = InCat (sym $ appendNilRightNeutral xs) p InEmpty
normCat_isSound {xs=xs++(ys++zs)} {r=(Cat _ _)} {s=(Lit _)} (InCat {xs} {ys=ys++zs} Refl pr (InCat {xs=ys} {ys=zs} Refl ps pl)) =
  InCat (appendAssociative xs ys zs) (InCat Refl pr ps) pl
normCat_isSound {xs=xs++(ys++zs)} {r=(Cat _ _)} {s=(Cat _ _)} (InCat {xs} {ys=ys++zs} Refl pr (InCat {xs=ys} {ys=zs} Refl ps pl)) =
  InCat (appendAssociative xs ys zs) (InCat Refl pr ps) pl
normCat_isSound {xs=xs++(ys++zs)} {r=(Cat _ _)} {s=(Disj _ _)} (InCat {xs} {ys=ys++zs} Refl pr (InCat {xs=ys} {ys=zs} Refl ps pl)) =
  InCat (appendAssociative xs ys zs) (InCat Refl pr ps) pl
normCat_isSound {xs=xs++(ys++zs)} {r=(Cat _ _)} {s=(Conj _ _)} (InCat {xs} {ys=ys++zs} Refl pr (InCat {xs=ys} {ys=zs} Refl ps pl)) =
  InCat (appendAssociative xs ys zs) (InCat Refl pr ps) pl
normCat_isSound {xs=xs++(ys++zs)} {r=(Cat _ _)} {s=(Star _)} (InCat {xs} {ys=ys++zs} Refl pr (InCat {xs=ys} {ys=zs} Refl ps pl)) =
  InCat (appendAssociative xs ys zs) (InCat Refl pr ps) pl
normCat_isSound      {r=(Disj _ _)} {s=Null}       p = absurd p
normCat_isSound {xs} {r=(Disj _ _)} {s=Empty}      p = InCat (sym $ appendNilRightNeutral xs) p InEmpty
normCat_isSound      {r=(Disj _ _)} {s=(Lit z)}    p = p
normCat_isSound      {r=(Disj _ _)} {s=(Cat z w)}  p = p
normCat_isSound      {r=(Disj _ _)} {s=(Disj z w)} p = p
normCat_isSound      {r=(Disj _ _)} {s=(Conj z w)} p = p
normCat_isSound      {r=(Disj _ _)} {s=(Star z)}   p = p
normCat_isSound      {r=(Conj _ _)} {s=Null}       p = absurd p
normCat_isSound {xs} {r=(Conj _ _)} {s=Empty}      p = InCat (sym $ appendNilRightNeutral xs) p InEmpty
normCat_isSound      {r=(Conj _ _)} {s=(Lit z)}    p = p
normCat_isSound      {r=(Conj _ _)} {s=(Cat z w)}  p = p
normCat_isSound      {r=(Conj _ _)} {s=(Disj z w)} p = p
normCat_isSound      {r=(Conj _ _)} {s=(Conj z w)} p = p
normCat_isSound      {r=(Conj _ _)} {s=(Star z)}   p = p
normCat_isSound      {r=(Star _)}   {s=Null}       p = absurd p
normCat_isSound {xs} {r=(Star _)}   {s=Empty}      p = InCat (sym $ appendNilRightNeutral xs) p InEmpty
normCat_isSound      {r=(Star _)}   {s=(Lit y)}    p = p
normCat_isSound      {r=(Star _)}   {s=(Cat y z)}  p = p
normCat_isSound      {r=(Star _)}   {s=(Disj y z)} p = p
normCat_isSound      {r=(Star _)}   {s=(Conj y z)} p = p
normCat_isSound      {r=(Star _)}   {s=(Star y)}   p = p

||| Proof (by exhaustion) that `normCat` is complete.
export
normCat_isComplete : DecEq a =>
                     {xs : List a} ->
                     {r : RegExp a} ->
                     {s : RegExp a} ->
                     Matches (Cat r s) xs ->
                     Matches (normCat r s) xs
normCat_isComplete {r=Null}                      (InCat _ pr _) = absurd pr
normCat_isComplete                {s=Null}       (InCat _ _ ps) = absurd ps
normCat_isComplete {r=Empty}      {s=Empty}      (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=Empty}      {s=(Lit _)}    (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=Empty}      {s=(Cat _ _)}  (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=Empty}      {s=(Disj _ _)} (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=Empty}      {s=(Conj _ _)} (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=Empty}      {s=(Star _)}   (InCat pCat InEmpty ps) = rewrite pCat in ps
normCat_isComplete {r=(Lit _)}    {s=Empty}      (InCat {xs} Refl pr InEmpty) = rewrite (appendNilRightNeutral xs) in pr
normCat_isComplete {r=(Lit _)}    {s=(Lit _)}    p = p
normCat_isComplete {r=(Lit _)}    {s=(Cat _ _)}  p = p
normCat_isComplete {r=(Lit _)}    {s=(Disj _ _)} p = p
normCat_isComplete {r=(Lit _)}    {s=(Conj _ _)} p = p
normCat_isComplete {r=(Lit _)}    {s=(Star _)}   p = p
normCat_isComplete {r=(Cat _ _)}  {s=Empty} (InCat {xs} Refl pr InEmpty) = rewrite (appendNilRightNeutral xs) in pr
normCat_isComplete {xs=(xs'++ys)++[x]} {r=(Cat _ _)} {s=(Lit x)} (InCat {xs=xs'++ys} {ys=[x]} Refl (InCat {xs=xs'} {ys} Refl pr ps) InLit) =
  InCat (sym $ appendAssociative xs' ys [x]) pr (InCat Refl ps InLit)
normCat_isComplete {xs=(xs'++ys)++zs} {r=(Cat _ _)} {s=(Cat _ _)} (InCat {xs=xs'++ys} {ys=zs} Refl (InCat {xs=xs'} {ys} Refl pr ps) pt) =
  InCat (sym $ appendAssociative xs' ys zs) pr (InCat Refl ps pt)
normCat_isComplete {xs=(xs'++ys)++zs} {r=(Cat _ _)} {s=(Disj _ _)} (InCat {xs=xs'++ys} {ys=zs} Refl (InCat {xs=xs'} {ys} Refl pr ps) pt) =
  InCat (sym $ appendAssociative xs' ys zs) pr (InCat Refl ps pt)
normCat_isComplete {xs=(xs'++ys)++zs} {r=(Cat _ _)} {s=(Conj _ _)} (InCat {xs=xs'++ys} {ys=zs} Refl (InCat {xs=xs'} {ys} Refl pr ps) pt) =
  InCat (sym $ appendAssociative xs' ys zs) pr (InCat Refl ps pt)
normCat_isComplete {xs=(xs'++ys)++zs} {r=(Cat _ _)} {s=(Star _)} (InCat {xs=xs'++ys} {ys=zs} Refl (InCat {xs=xs'} {ys} Refl pr ps) pt) =
  InCat (sym $ appendAssociative xs' ys zs) pr (InCat Refl ps pt)
normCat_isComplete {r=(Disj _ _)} {s=Empty}      (InCat {xs} Refl pr InEmpty) = rewrite (appendNilRightNeutral xs) in pr
normCat_isComplete {r=(Disj _ _)} {s=(Lit _)}    p = p
normCat_isComplete {r=(Disj _ _)} {s=(Cat _ _)}  p = p
normCat_isComplete {r=(Disj _ _)} {s=(Disj _ _)} p = p
normCat_isComplete {r=(Disj _ _)} {s=(Conj _ _)} p = p
normCat_isComplete {r=(Disj _ _)} {s=(Star _)}   p = p
normCat_isComplete {r=(Conj _ _)} {s=Empty}      (InCat {xs} Refl pr InEmpty) = rewrite (appendNilRightNeutral xs) in pr
normCat_isComplete {r=(Conj _ _)} {s=(Lit _)}    p = p
normCat_isComplete {r=(Conj _ _)} {s=(Cat _ _)}  p = p
normCat_isComplete {r=(Conj _ _)} {s=(Disj _ _)} p = p
normCat_isComplete {r=(Conj _ _)} {s=(Conj _ _)} p = p
normCat_isComplete {r=(Conj _ _)} {s=(Star _)}   p = p
normCat_isComplete {r=(Star _)}   {s=Empty}      (InCat {xs} Refl pr InEmpty) = rewrite (appendNilRightNeutral xs) in pr
normCat_isComplete {r=(Star _)}   {s=(Lit _)}    p = p
normCat_isComplete {r=(Star _)}   {s=(Cat _ _)}  p = p
normCat_isComplete {r=(Star _)}   {s=(Disj _ _)} p = p
normCat_isComplete {r=(Star _)}   {s=(Conj _ _)} p = p
normCat_isComplete {r=(Star _)}   {s=(Star _)}   p = p

||| Proof (by exhaustion) that `normDisj` is sound.
export
normDisj_isSound : DecEq a =>
                   {xs : List a} ->
                   {r : RegExp a} ->
                   {s : RegExp a} ->
                   Matches (normDisj r s) xs ->
                   Matches (Disj r s) xs
normDisj_isSound {r=Null}                      p                     = InDisjR p
normDisj_isSound {r=Empty}      {s=Null}       p                     = InDisjL p
normDisj_isSound {r=Empty}      {s=Empty}      p                     = p
normDisj_isSound {r=Empty}      {s=(Lit _)}    p                     = p
normDisj_isSound {r=Empty}      {s=(Cat _ _)}  p                     = p
normDisj_isSound {r=Empty}      {s=(Disj _ _)} p                     = p
normDisj_isSound {r=Empty}      {s=(Conj _ _)} p                     = p
normDisj_isSound {r=Empty}      {s=(Star _)}   p                     = p
normDisj_isSound {r=(Lit _)}    {s=Null}       p                     = InDisjL p
normDisj_isSound {r=(Lit _)}    {s=Empty}      p                     = p
normDisj_isSound {r=(Lit x)}    {s=(Lit y)}    p with (decEq x y)
  normDisj_isSound {r=(Lit x)}  {s=(Lit x)}    p | (Yes Refl)        = InDisjL p
  normDisj_isSound {r=(Lit x)}  {s=(Lit y)}    p | (No _)       = p
normDisj_isSound {r=(Lit _)}    {s=(Cat _ _)}  p                     = p
normDisj_isSound {r=(Lit _)}    {s=(Disj _ _)} p                     = p
normDisj_isSound {r=(Lit _)}    {s=(Conj _ _)} p                     = p
normDisj_isSound {r=(Lit _)}    {s=(Star _)}   p                     = p
normDisj_isSound {r=(Cat _ _)}  {s=Null}       p                     = InDisjL p
normDisj_isSound {r=(Cat _ _)}  {s=Empty}      p                     = p
normDisj_isSound {r=(Cat _ _)}  {s=(Lit _)}    p                     = p
normDisj_isSound {r=(Cat r s)}  {s=(Cat t u)}  p with (decEq r t)
  normDisj_isSound {r=(Cat r s)} {s=(Cat r u)} p | (Yes Refl) with (decEq s u)
    normDisj_isSound {r=(Cat r s)} {s=(Cat r s)} p | (Yes Refl) | (Yes Refl) = InDisjL p
    normDisj_isSound {r=(Cat r s)} {s=(Cat r u)} p | (Yes Refl) | (No _) = p
  normDisj_isSound {r=(Cat r s)} {s=(Cat t u)} p | (No _) = p
normDisj_isSound {r=(Cat _ _)}  {s=(Disj _ _)} p                     = p
normDisj_isSound {r=(Cat _ _)}  {s=(Conj _ _)} p                     = p
normDisj_isSound {r=(Cat _ _)}  {s=(Star _)}   p                     = p
normDisj_isSound {r=(Disj _ _)} {s=Null}       p                     = InDisjL p
normDisj_isSound {r=(Disj _ _)} {s=Empty}      (InDisjL p)           = InDisjL (InDisjL p)
normDisj_isSound {r=(Disj _ _)} {s=Empty}      (InDisjR (InDisjL p)) = InDisjL (InDisjR p)
normDisj_isSound {r=(Disj _ _)} {s=Empty}      (InDisjR (InDisjR p)) = InDisjR p
normDisj_isSound {r=(Disj _ _)} {s=(Lit _)}    (InDisjL p)           = InDisjL (InDisjL p)
normDisj_isSound {r=(Disj _ _)} {s=(Lit _)}    (InDisjR (InDisjL p)) = InDisjL (InDisjR p)
normDisj_isSound {r=(Disj _ _)} {s=(Lit _)}    (InDisjR (InDisjR p)) = InDisjR p
normDisj_isSound {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjL p)           = InDisjL (InDisjL p)
normDisj_isSound {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjR (InDisjL p)) = InDisjL (InDisjR p)
normDisj_isSound {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjR (InDisjR p)) = InDisjR p
normDisj_isSound {r=(Disj r s)} {s=(Disj t u)} p with (decEq r t)
  normDisj_isSound {r=(Disj r s)} {s=(Disj r u)} p                     | (Yes Refl) with (decEq s u)
    normDisj_isSound {r=(Disj r s)} {s=(Disj r s)} p                     | (Yes Refl) | (Yes Refl) = InDisjL p
    normDisj_isSound {r=(Disj r s)} {s=(Disj r u)} (InDisjL p)           | (Yes Refl) | (No _)     = InDisjL (InDisjL p)
    normDisj_isSound {r=(Disj r s)} {s=(Disj r u)} (InDisjR (InDisjL p)) | (Yes Refl) | (No _)     = InDisjL (InDisjR p)
    normDisj_isSound {r=(Disj r s)} {s=(Disj r u)} (InDisjR (InDisjR p)) | (Yes Refl) | (No _)     = InDisjR p
  normDisj_isSound {r=(Disj r s)} {s=(Disj t u)} (InDisjL p)           | (No _) = InDisjL (InDisjL p)
  normDisj_isSound {r=(Disj r s)} {s=(Disj t u)} (InDisjR (InDisjL p)) | (No _) = InDisjL (InDisjR p)
  normDisj_isSound {r=(Disj r s)} {s=(Disj t u)} (InDisjR (InDisjR p)) | (No _) = InDisjR p
normDisj_isSound {r=(Disj _ _)} {s=(Conj _ _)} (InDisjL p)           = InDisjL (InDisjL p)
normDisj_isSound {r=(Disj _ _)} {s=(Conj _ _)} (InDisjR (InDisjL p)) = InDisjL (InDisjR p)
normDisj_isSound {r=(Disj _ _)} {s=(Conj _ _)} (InDisjR (InDisjR p)) = InDisjR p
normDisj_isSound {r=(Disj _ _)} {s=(Star _)}   (InDisjL p)           = InDisjL (InDisjL p)
normDisj_isSound {r=(Disj _ _)} {s=(Star _)}   (InDisjR (InDisjL p)) = InDisjL (InDisjR p)
normDisj_isSound {r=(Disj _ _)} {s=(Star _)}   (InDisjR (InDisjR p)) = InDisjR p
normDisj_isSound {r=(Conj _ _)} {s=Null}       p                     = InDisjL p
normDisj_isSound {r=(Conj _ _)} {s=Empty}      p                     = p
normDisj_isSound {r=(Conj _ _)} {s=(Lit _)}    p                     = p
normDisj_isSound {r=(Conj _ _)} {s=(Cat _ _)}  p                     = p
normDisj_isSound {r=(Conj _ _)} {s=(Disj _ _)} p                     = p
normDisj_isSound {r=(Conj r s)} {s=(Conj t u)} p with (decEq r t)
  normDisj_isSound {r=(Conj r s)} {s=(Conj r u)} p | (Yes Refl) with (decEq s u)
    normDisj_isSound {r=(Conj r s)} {s=(Conj r s)} p | (Yes Refl) | (Yes Refl) = InDisjL p
    normDisj_isSound {r=(Conj r s)} {s=(Conj r u)} p | (Yes Refl) | (No _) = p
  normDisj_isSound {r=(Conj r s)} {s=(Conj t u)} p | (No _) = p
normDisj_isSound {r=(Conj _ _)} {s=(Star _)}   p                     = p
normDisj_isSound {r=(Star _)}   {s=Null}       p                     = InDisjL p
normDisj_isSound {r=(Star _)}   {s=Empty}      p                     = p
normDisj_isSound {r=(Star _)}   {s=(Lit _)}    p                     = p
normDisj_isSound {r=(Star _)}   {s=(Cat _ _)}  p                     = p
normDisj_isSound {r=(Star _)}   {s=(Disj _ _)} p                     = p
normDisj_isSound {r=(Star _)}   {s=(Conj _ _)} p                     = p
normDisj_isSound {r=(Star r)}   {s=(Star s)}   p with (decEq r s)
  normDisj_isSound {r=(Star r)} {s=(Star r)}   p | (Yes Refl)        = InDisjL p
  normDisj_isSound {r=(Star r)} {s=(Star s)}   p | (No _)            = p

||| Proof (by exhaustion) that `normDisj` is complete.
export
normDisj_isComplete : DecEq a =>
                      {xs : List a} ->
                      {r : RegExp a} ->
                      {s : RegExp a} ->
                      Matches (Disj r s) xs ->
                      Matches (normDisj r s) xs
normDisj_isComplete {r=Null}                      (InDisjL p)           = absurd p
normDisj_isComplete {r=Null}                      (InDisjR p)           = p
normDisj_isComplete {r=Empty}      {s=Null}       (InDisjL p)           = p
normDisj_isComplete {r=Empty}      {s=Null}       (InDisjR p)           = absurd p
normDisj_isComplete {r=Empty}      {s=Empty}      (InDisjL p)           = InDisjL p
normDisj_isComplete {r=Empty}      {s=Empty}      (InDisjR p)           = InDisjR p
normDisj_isComplete {r=Empty}      {s=(Lit _)}    p                     = p
normDisj_isComplete {r=Empty}      {s=(Cat _ _)}  p                     = p
normDisj_isComplete {r=Empty}      {s=(Disj _ _)} p                     = p
normDisj_isComplete {r=Empty}      {s=(Conj _ _)} p                     = p
normDisj_isComplete {r=Empty}      {s=(Star _)}   p                     = p
normDisj_isComplete {r=(Lit _)}    {s=Null}       (InDisjL p)           = p
normDisj_isComplete {r=(Lit _)}    {s=Null}       (InDisjR p)           = absurd p
normDisj_isComplete {r=(Lit _)}    {s=Empty}      p                     = p
normDisj_isComplete {r=(Lit x)}    {s=(Lit y)}    p with (decEq x y)
  normDisj_isComplete {r=(Lit x)}  {s=(Lit x)}    (InDisjL p) | (Yes Refl) = p
  normDisj_isComplete {r=(Lit x)}  {s=(Lit x)}    (InDisjR p) | (Yes Refl) = p
  normDisj_isComplete {r=(Lit x)}  {s=(Lit y)}    p           | (No _)     = p
normDisj_isComplete {r=(Lit _)}    {s=(Cat _ _)} p                      = p
normDisj_isComplete {r=(Lit _)}    {s=(Disj _ _)} p                     = p
normDisj_isComplete {r=(Lit _)}    {s=(Conj _ _)} p                     = p
normDisj_isComplete {r=(Lit _)}    {s=(Star _)} p                       = p
normDisj_isComplete {r=(Cat _ _)}  {s=Null} (InDisjL p)                 = p
normDisj_isComplete {r=(Cat _ _)}  {s=Null} (InDisjR p)                 = absurd p
normDisj_isComplete {r=(Cat _ _)}  {s=Empty} p = p
normDisj_isComplete {r=(Cat _ _)}  {s=(Lit _)} p = p
normDisj_isComplete {r=(Cat r s)}  {s=(Cat t u)} p with (decEq r t)
  normDisj_isComplete {r=(Cat r s)} {s=(Cat r u)} p | (Yes Refl) with (decEq s u)
    normDisj_isComplete {r=(Cat r s)} {s=(Cat r s)} (InDisjL p) | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Cat r s)} {s=(Cat r s)} (InDisjR p) | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Cat r s)} {s=(Cat r u)} p           | (Yes Refl) | (No _)     = p
  normDisj_isComplete {r=(Cat r s)} {s=(Cat t u)} p             | (No _) = p
normDisj_isComplete {r=(Cat _ _)}  {s=(Disj _ _)} p                     = p
normDisj_isComplete {r=(Cat _ _)}  {s=(Conj _ _)} p                     = p
normDisj_isComplete {r=(Cat _ _)}  {s=(Star _)} p                       = p
normDisj_isComplete {r=(Disj _ _)} {s=Null}       (InDisjL p)           = p
normDisj_isComplete {r=(Disj _ _)} {s=Null}       (InDisjR p)           = absurd p
normDisj_isComplete {r=(Disj _ _)} {s=Empty}      (InDisjL (InDisjL p)) = InDisjL p
normDisj_isComplete {r=(Disj _ _)} {s=Empty}      (InDisjL (InDisjR p)) = InDisjR (InDisjL p)
normDisj_isComplete {r=(Disj _ _)} {s=Empty}      (InDisjR p)           = InDisjR (InDisjR p)
normDisj_isComplete {r=(Disj _ _)} {s=(Lit _)}    (InDisjL (InDisjL p)) = InDisjL p
normDisj_isComplete {r=(Disj _ _)} {s=(Lit _)}    (InDisjL (InDisjR p)) = InDisjR (InDisjL p)
normDisj_isComplete {r=(Disj _ _)} {s=(Lit _)}    (InDisjR p)           = InDisjR (InDisjR p)
normDisj_isComplete {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjL (InDisjL p)) = InDisjL p
normDisj_isComplete {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjL (InDisjR p)) = InDisjR (InDisjL p)
normDisj_isComplete {r=(Disj _ _)} {s=(Cat _ _)}  (InDisjR p)           = InDisjR (InDisjR p)
normDisj_isComplete {r=(Disj r s)} {s=(Disj t u)} p with (decEq r t)
  normDisj_isComplete {r=(Disj r s)} {s=(Disj r u)} p                       | (Yes Refl) with (decEq s u)
    normDisj_isComplete {r=(Disj r s)} {s=(Disj r s)} (InDisjL p)             | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Disj r s)} {s=(Disj r s)} (InDisjR p)             | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Disj r s)} {s=(Disj r u)} (InDisjL (InDisjL p)) | (Yes Refl) | (No _)       = InDisjL p
    normDisj_isComplete {r=(Disj r s)} {s=(Disj r u)} (InDisjL (InDisjR p)) | (Yes Refl) | (No _)       = InDisjR (InDisjL p)
    normDisj_isComplete {r=(Disj r s)} {s=(Disj r u)} (InDisjR p)             | (Yes Refl) | (No _)     = InDisjR (InDisjR p)
  normDisj_isComplete {r=(Disj r s)} {s=(Disj t u)} (InDisjL (InDisjL p))   | (No _)                    = InDisjL p
  normDisj_isComplete {r=(Disj r s)} {s=(Disj t u)} (InDisjL (InDisjR p))   | (No _)                    = InDisjR (InDisjL p)
  normDisj_isComplete {r=(Disj r s)} {s=(Disj t u)} (InDisjR p)               | (No _)                  = InDisjR (InDisjR p)
normDisj_isComplete {r=(Disj _ _)} {s=(Conj _ _)} (InDisjL (InDisjL p)) = InDisjL p
normDisj_isComplete {r=(Disj _ _)} {s=(Conj _ _)} (InDisjL (InDisjR p)) = InDisjR (InDisjL p)
normDisj_isComplete {r=(Disj _ _)} {s=(Conj _ _)} (InDisjR p)           = InDisjR (InDisjR p)
normDisj_isComplete {r=(Disj _ _)} {s=(Star _)}   (InDisjL (InDisjL p)) = InDisjL p
normDisj_isComplete {r=(Disj _ _)} {s=(Star _)}   (InDisjL (InDisjR p)) = InDisjR (InDisjL p)
normDisj_isComplete {r=(Disj _ _)} {s=(Star _)}   (InDisjR p)           = InDisjR (InDisjR p)
normDisj_isComplete {r=(Conj _ _)} {s=Null}       (InDisjL p)           = p
normDisj_isComplete {r=(Conj _ _)} {s=Null}       (InDisjR p)           = absurd p
normDisj_isComplete {r=(Conj _ _)} {s=Empty}      p                     = p
normDisj_isComplete {r=(Conj _ _)} {s=(Lit _)}    p                     = p
normDisj_isComplete {r=(Conj _ _)} {s=(Cat _ _)}  p                     = p
normDisj_isComplete {r=(Conj _ _)} {s=(Disj _ _)} p                     = p
normDisj_isComplete {r=(Conj r s)} {s=(Conj t u)} p with (decEq r t)
  normDisj_isComplete {r=(Conj r s)} {s=(Conj r u)} p | (Yes Refl) with (decEq s u)
    normDisj_isComplete {r=(Conj r s)} {s=(Conj r s)} (InDisjL p) | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Conj r s)} {s=(Conj r s)} (InDisjR p) | (Yes Refl) | (Yes Refl) = p
    normDisj_isComplete {r=(Conj r s)} {s=(Conj r u)} p           | (Yes Refl) | (No _)     = p
  normDisj_isComplete {r=(Conj r s)} {s=(Conj t u)} p | (No _)                              = p
normDisj_isComplete {r=(Conj _ _)} {s=(Star _)}   p                     = p
normDisj_isComplete {r=(Star _)} {s=Null}         (InDisjL p)           = p
normDisj_isComplete {r=(Star _)} {s=Null}         (InDisjR p)           = absurd p
normDisj_isComplete {r=(Star _)} {s=Empty}        p                     = p
normDisj_isComplete {r=(Star _)} {s=(Lit _)}      p                     = p
normDisj_isComplete {r=(Star _)} {s=(Cat _ _)}    p                     = p
normDisj_isComplete {r=(Star _)} {s=(Disj _ _)}   p                     = p
normDisj_isComplete {r=(Star _)} {s=(Conj _ _)}   p                     = p
normDisj_isComplete {r=(Star r)} {s=(Star s)} p with (decEq r s)
  normDisj_isComplete {r=(Star r)} {s=(Star r)}   (InDisjL p) | (Yes Refl) = p
  normDisj_isComplete {r=(Star r)} {s=(Star r)}   (InDisjR p) | (Yes Refl) = p
  normDisj_isComplete {r=(Star r)} {s=(Star s)}   p           | (No _)     = p

||| Proof (by exhaustion) that `normConj` is sound.
export
normConj_isSound : DecEq a =>
                   {xs : List a} ->
                   {r : RegExp a} ->
                   {s : RegExp a} ->
                   Matches (normConj r s) xs ->
                   Matches (Conj r s) xs
normConj_isSound {r=Null}       {s}       p = absurd p
normConj_isSound {r=Empty}      {s=Null}       p = absurd p
normConj_isSound {r=Empty}      {s=Empty}      p = p
normConj_isSound {r=Empty}      {s=(Lit _)}    p = p
normConj_isSound {r=Empty}      {s=(Cat _ _)}  p = p
normConj_isSound {r=Empty}      {s=(Disj _ _)} p = p
normConj_isSound {r=Empty}      {s=(Conj _ _)} p = p
normConj_isSound {r=Empty}      {s=(Star _)}   p = p
normConj_isSound {r=(Lit _)}    {s=Null}       p = absurd p
normConj_isSound {r=(Lit _)}    {s=Empty}      p = p
normConj_isSound {r=(Lit x)}    {s=(Lit y)}    p with (decEq x y)
  normConj_isSound {r=(Lit x)}    {s=(Lit x)}    p | (Yes Refl) = InConj p p
  normConj_isSound {r=(Lit x)}    {s=(Lit y)}    p | (No _)     = p
normConj_isSound {r=(Lit _)}    {s=(Cat _ _)}  p = p
normConj_isSound {r=(Lit _)}    {s=(Disj _ _)} p = p
normConj_isSound {r=(Lit _)}    {s=(Conj _ _)} p = p
normConj_isSound {r=(Lit _)}    {s=(Star _)}   p = p
normConj_isSound {r=(Cat _ _)}  {s=Null}       p = absurd p
normConj_isSound {r=(Cat _ _)}  {s=Empty}      p = p
normConj_isSound {r=(Cat _ _)}  {s=(Lit _)}    p = p
normConj_isSound {r=(Cat r s)}  {s=(Cat t u)}  p with (decEq r t)
  normConj_isSound {r=(Cat r s)} {s=(Cat r u)} p | (Yes Refl) with (decEq s u)
    normConj_isSound {r=(Cat r s)} {s=(Cat r s)} p | (Yes Refl) | (Yes Refl) = InConj p p
    normConj_isSound {r=(Cat r s)} {s=(Cat r u)} p | (Yes Refl) | (No _) = p
  normConj_isSound {r=(Cat r s)} {s=(Cat t u)} p | (No _) = p
normConj_isSound {r=(Cat _ _)}  {s=(Disj _ _)} p = p
normConj_isSound {r=(Cat _ _)}  {s=(Conj _ _)} p = p
normConj_isSound {r=(Cat _ _)}  {s=(Star _)}   p = p
normConj_isSound {r=(Disj _ _)} {s=Null}       p = absurd p
normConj_isSound {r=(Disj _ _)} {s=Empty}      p = p
normConj_isSound {r=(Disj _ _)} {s=(Lit _)}    p = p
normConj_isSound {r=(Disj _ _)} {s=(Cat _ _)}  p = p
normConj_isSound {r=(Disj r s)} {s=(Disj t u)} p with (decEq r t)
  normConj_isSound {r=(Disj r s)} {s=(Disj r u)} p | (Yes Refl) with (decEq s u)
    normConj_isSound {r=(Disj r s)} {s=(Disj r s)} p | (Yes Refl) | (Yes Refl) = InConj p p
    normConj_isSound {r=(Disj r s)} {s=(Disj r u)} p | (Yes Refl) | (No _) = p
  normConj_isSound {r=(Disj r s)} {s=(Disj t u)} p | (No _) = p
normConj_isSound {r=(Disj _ _)} {s=(Conj _ _)} p = p
normConj_isSound {r=(Disj _ _)} {s=(Star _)}   p = p
normConj_isSound {r=(Conj _ _)} {s=Null}       p = absurd p
normConj_isSound {r=(Conj _ _)} {s=Empty}      (InConj pr (InConj ps pt)) = InConj (InConj pr ps) pt
normConj_isSound {r=(Conj _ _)} {s=(Lit _)}    (InConj pr (InConj ps pt)) = InConj (InConj pr ps) pt
normConj_isSound {r=(Conj _ _)} {s=(Cat _ _)}  (InConj pr (InConj ps pt)) = InConj (InConj pr ps) pt
normConj_isSound {r=(Conj _ _)} {s=(Disj _ _)} (InConj pr (InConj ps pt)) = InConj (InConj pr ps) pt
normConj_isSound {r=(Conj r s)} {s=(Conj t u)} p with (decEq r t)
  normConj_isSound {r=(Conj r s)} {s=(Conj r u)} p | (Yes Refl) with (decEq s u)
    normConj_isSound {r=(Conj r s)} {s=(Conj r s)} p | (Yes Refl) | (Yes Refl) = InConj p p
    normConj_isSound {r=(Conj r s)} {s=(Conj r u)} (InConj _ (InConj ps (InConj pt pu))) | (Yes Refl) | (No _) =
      InConj (InConj pt ps) (InConj pt pu)
  normConj_isSound {r=(Conj r s)} {s=(Conj t u)} (InConj pr (InConj ps (InConj pt pu))) | (No _) =
    InConj (InConj pr ps) (InConj pt pu)
normConj_isSound {r=(Conj _ _)} {s=(Star _)}   (InConj pr (InConj ps pt)) = InConj (InConj pr ps) pt
normConj_isSound {r=(Star _)}   {s=Null}       p = absurd p
normConj_isSound {r=(Star _)}   {s=Empty}      p = p
normConj_isSound {r=(Star _)}   {s=(Lit _)}    p = p
normConj_isSound {r=(Star _)}   {s=(Cat _ _)}  p = p
normConj_isSound {r=(Star _)}   {s=(Disj _ _)} p = p
normConj_isSound {r=(Star _)}   {s=(Conj _ _)} p = p
normConj_isSound {r=(Star r)}   {s=(Star s)}   p with (decEq r s)
  normConj_isSound {r=(Star r)}   {s=(Star r)}   p | (Yes Refl) = InConj p p
  normConj_isSound {r=(Star r)}   {s=(Star s)}   p | (No _)     = p

||| Proof (by exhaustion) that `normCat` is complete.
export
normConj_isComplete : DecEq a =>
                      {xs : List a} ->
                      {r : RegExp a} ->
                      {s : RegExp a} ->
                      Matches (Conj r s) xs ->
                      Matches (normConj r s) xs
normConj_isComplete {r=Null}                      (InConj p _) = absurd p
normConj_isComplete                {s=Null}       (InConj _ p) = absurd p
normConj_isComplete {r=Empty}      {s=Empty}      p = p
normConj_isComplete {r=Empty}      {s=(Lit _)}    p = p
normConj_isComplete {r=Empty}      {s=(Cat _ _)}  p = p
normConj_isComplete {r=Empty}      {s=(Disj _ _)} p = p
normConj_isComplete {r=Empty}      {s=(Conj _ _)} p = p
normConj_isComplete {r=Empty}      {s=(Star _)}   p = p
normConj_isComplete {r=(Lit _)}    {s=Empty}      p = p
normConj_isComplete {r=(Lit x)}    {s=(Lit y)}    p with (decEq x y)
  normConj_isComplete {r=(Lit x)}  {s=(Lit x)}    (InConj p _) | Yes Refl = p
  normConj_isComplete {r=(Lit x)}  {s=(Lit y)}    p            | No _     = p
normConj_isComplete {r=(Lit _)}    {s=(Cat _ _)}  p = p
normConj_isComplete {r=(Lit _)}    {s=(Disj _ _)} p = p
normConj_isComplete {r=(Lit _)}    {s=(Conj _ _)} p = p
normConj_isComplete {r=(Lit _)}    {s=(Star _)}   p = p
normConj_isComplete {r=(Cat _ _)}  {s=Empty}      p = p
normConj_isComplete {r=(Cat _ _)}  {s=(Lit _)}    p = p
normConj_isComplete {r=(Cat r s)}   {s=(Cat t u)} p with (decEq (Cat r s) (Cat t u))
  normConj_isComplete {r=(Cat r s)} {s=(Cat r s)} (InConj p _) | Yes Refl = p
  normConj_isComplete {r=(Cat r s)} {s=(Cat t u)} p            | No _     = p
normConj_isComplete {r=(Cat _ _)}  {s=(Disj _ _)} p = p
normConj_isComplete {r=(Cat _ _)}  {s=(Conj _ _)} p = p
normConj_isComplete {r=(Cat _ _)}  {s=(Star _)}   p = p
normConj_isComplete {r=(Disj _ _)} {s=Empty}      p = p
normConj_isComplete {r=(Disj _ _)} {s=(Lit _)}    p = p
normConj_isComplete {r=(Disj _ _)} {s=(Cat _ _)}  p = p
normConj_isComplete {r=(Disj r s)}   {s=(Disj t u)} p with (decEq (Disj r s) (Disj t u))
  normConj_isComplete {r=(Disj r s)} {s=(Disj r s)} (InConj p _) | Yes Refl = p
  normConj_isComplete {r=(Disj r s)} {s=(Disj t u)} p            | No _     = p
normConj_isComplete {r=(Disj _ _)} {s=(Conj _ _)} p = p
normConj_isComplete {r=(Disj _ _)} {s=(Star _)}   p = p
normConj_isComplete {r=(Conj _ _)} {s=Empty}      (InConj (InConj pr ps) pt) = InConj pr (InConj ps pt)
normConj_isComplete {r=(Conj _ _)} {s=(Lit _)}    (InConj (InConj pr ps) pt) = InConj pr (InConj ps pt)
normConj_isComplete {r=(Conj _ _)} {s=(Cat _ _)}  (InConj (InConj pr ps) pt) = InConj pr (InConj ps pt)
normConj_isComplete {r=(Conj _ _)} {s=(Disj _ _)} (InConj (InConj pr ps) pt) = InConj pr (InConj ps pt)
normConj_isComplete {r=(Conj r s)} {s=(Conj t u)} p with (decEq (Conj r s) (Conj t u))
  normConj_isComplete {r=(Conj r s)} {s=(Conj r s)} (InConj p _)                           | Yes Refl = p
  normConj_isComplete {r=(Conj r s)} {s=(Conj t u)} (InConj (InConj pr ps) (InConj pt pu)) | No _     =
    InConj pr (InConj ps (InConj pt pu))
normConj_isComplete {r=(Conj _ _)} {s=(Star _)}   (InConj (InConj pr ps) pt) = InConj pr (InConj ps pt)
normConj_isComplete {r=(Star _)}   {s=Empty}      p = p
normConj_isComplete {r=(Star _)}   {s=(Lit _)}    p = p
normConj_isComplete {r=(Star _)}   {s=(Cat _ _)}  p = p
normConj_isComplete {r=(Star _)}   {s=(Disj _ _)} p = p
normConj_isComplete {r=(Star _)}   {s=(Conj _ _)} p = p
normConj_isComplete {r=(Star r)}   {s=(Star s)}   p with (decEq r s)
  normConj_isComplete {r=(Star r)} {s=(Star r)}   (InConj p _) | Yes Refl = p
  normConj_isComplete {r=(Star r)} {s=(Star s)}   p            | No _     = p


import Data.Vect

length : Vect n elem -> Nat
length {n} xs = n

empties : Vect n (Vect 0 a)
empties {n = Z} = []
empties {n = (S k)} = [] :: empties