||| Properties of Data.Vect.map
module Data.Vect.Properties.Map

import Data.Vect.Properties.Tabulate
import Data.Vect.Properties.Index
import Data.Vect.Properties.Foldr

import Data.Vect
import Data.Vect.Elem
import Data.Fin
import Data.Vect.Extra

import Syntax.PreorderReasoning

||| `map` functoriality: identity preservation
export
mapId : (xs : Vect n a) -> map Prelude.id xs = xs
mapId xs = vectorExtensionality _ _ $ \i => indexNaturality _ _ _

||| `mapWtihPos f` represents post-composition the tabulated function `f`
export
indexMapWithPos : (f : Fin n -> a -> b) -> (xs : Vect n a) -> (i : Fin n)
  -> index i (mapWithPos f xs) = f i (index i xs)
indexMapWithPos f (x :: _ )  FZ    = Refl
indexMapWithPos f (_ :: xs) (FS i) = indexMapWithPos _ _ _

||| `tabulate : (Fin n ->) -> Vect n` is a natural transformation
export
mapTabulate : (f : a -> b) -> (g : Fin n -> a)
  -> tabulate (f . g) = map f (tabulate g)
mapTabulate f g = irrelevantEq $
  vectorExtensionality _ _ $ \i => Calc $
  |~ index i (tabulate (f . g))
  ~~ f (g i)                      ...(indexTabulate _ _)
  ~~ f (index i $ tabulate g)     ...(cong f (sym $ indexTabulate _ _))
  ~~ index i (map f $ tabulate g) ...(sym $ indexNaturality _ _ _)

||| Tabulating with the constant function is replication
export
tabulateConstantly : (x : a) -> Fin.tabulate {len} (const x) === replicate len  x
tabulateConstantly x = irrelevantEq $
  vectorExtensionality _ _ $ \i => Calc $
  |~ index i (Fin.tabulate (const x))
  ~~ x ...(indexTabulate _ _)
  ~~ index i (replicate _ x) ...(sym $ indexReplicate _ _)

||| It's enough that two functions agree on the elements of a vector for the maps to agree
export
mapRestrictedExtensional : (f, g : a -> b) -> (xs : Vect n a)
  -> (prf : (i : Fin n) -> f (index i xs) = g (index i xs))
  -> map f xs = map g xs
mapRestrictedExtensional f g xs prf = vectorExtensionality _ _ $ \i => Calc $
  |~ index i (map f xs)
  ~~ f (index i xs)     ...(      indexNaturality _ _ _)
  ~~ g (index i xs)     ...(prf _)
  ~~ index i (map g xs) ...(sym $ indexNaturality _ _ _)

||| function extensionality is a congruence wrt map
export
mapExtensional : (f, g : a -> b)
  -> (prf : (x : a) -> f x = g x)
  -> (xs : Vect n a)
  -> map f xs = map g xs
mapExtensional f g prf xs = mapRestrictedExtensional f g xs (\i => prf (index i xs))

||| map-fusion property for vectors up to function extensionality
export
mapFusion : (f : b -> c) -> (g : a -> b) -> (xs : Vect n a)
  -> map f (map g xs) = map (f . g) xs
mapFusion f g    []     = Refl
mapFusion f g (x :: xs) = cong (f $ g x ::) $ mapFusion f g xs

||| function extensionality is a congruence wrt mapWithElem
export
mapWithElemExtensional : (xs : Vect n a) -> (f, g :  (x : a) -> (0 _ : x `Elem` xs) -> b)
  -> ((x : a) -> (0 pos : x `Elem` xs) -> f x pos = g x pos)
  -> mapWithElem xs f = mapWithElem xs g
mapWithElemExtensional    []     f g prf = Refl
mapWithElemExtensional (x :: xs) f g prf
  = cong2 (::) (prf x Here)
               (mapWithElemExtensional xs _ _ (\x,pos => prf x (There pos)))


module EquivFoldConstants

import Equiv
import Expr
import Logic
import Imp
import Maps

%access public export

%default total

fold_constants_aexp : (a : AExp) -> AExp
fold_constants_aexp (ANum k) = ANum k
fold_constants_aexp (AId x) = AId x
fold_constants_aexp (APlus a1 a2) =
  case (fold_constants_aexp a1, fold_constants_aexp a2) of
    (ANum n1, ANum n2) => ANum (n1 + n2)
    (e1, e2) => APlus e1 e2
fold_constants_aexp (AMinus a1 a2) =
  case (fold_constants_aexp a1, fold_constants_aexp a2) of
    (ANum n1, ANum n2) => ANum (minus n1 n2)
    (e1, e2) => AMinus e1 e2
fold_constants_aexp (AMult a1 a2) =
  case (fold_constants_aexp a1, fold_constants_aexp a2) of
    (ANum n1, ANum n2) => ANum (n1 * n2)
    (e1, e2) => AMult e1 e2

fold_aexp_example_1 : fold_constants_aexp ((1 + 2) * X) = 3 * X
fold_aexp_example_1 = Refl

fold_aexp_example_2 : fold_constants_aexp (X - (0 * 6 + Y))
                    = X - (0 + Y)
fold_aexp_example_2 = Refl

fold_constants_bexp : (b : BExp) -> BExp
fold_constants_bexp BTrue = BTrue
fold_constants_bexp BFalse = BFalse
fold_constants_bexp (BEq a1 a2) =
  case (fold_constants_aexp a1, fold_constants_aexp a2) of
    (ANum n1, ANum n2) => if n1 == n2 then BTrue else BFalse
    (e1, e2) => BEq e1 e2
fold_constants_bexp (BLe a1 a2) =
  case (fold_constants_aexp a1, fold_constants_aexp a2) of
    (ANum n1, ANum n2) => if lte n1 n2 then BTrue else BFalse
    (e1, e2) => BLe e1 e2
fold_constants_bexp (BNot b) =
  case fold_constants_bexp b of
    BTrue => BFalse
    BFalse => BTrue
    e => BNot e
fold_constants_bexp (BAnd b1 b2) =
  case (fold_constants_bexp b1, fold_constants_bexp b2) of
    (BTrue, e2) => e2
    (BFalse, _) => BFalse
    (e1, e2) => BAnd e1 e2

fold_bexp_example_1 : fold_constants_bexp (BTrue && (not (BFalse && BTrue)))
                    = BTrue
fold_bexp_example_1 = Refl

fold_bexp_example_2 : fold_constants_bexp ((X == Y) && (0 == 2 - (1 + 1)))
                    = (X == Y) && BTrue
fold_bexp_example_2 = Refl

fold_constants_com : (c : Com) -> Com
fold_constants_com CSkip = SKIP
fold_constants_com (CAss x e) = x ::= fold_constants_aexp e
fold_constants_com (CSeq c1 c2) = CSeq (fold_constants_com c1)
                                       (fold_constants_com c2)
fold_constants_com (CIf b ct cf) =
  case fold_constants_bexp b of
    BTrue => fold_constants_com ct
    BFalse => fold_constants_com cf
    e => CIf e (fold_constants_com ct) (fold_constants_com cf)
fold_constants_com (CIf1 b c) =
  case fold_constants_bexp b of
    BTrue => fold_constants_com c
    BFalse => SKIP
    e => CIf1 e (fold_constants_com c)
fold_constants_com (CWhile b c) =
  case fold_constants_bexp b of
    BTrue => CWhile BTrue SKIP
    BFalse => SKIP
    e => CWhile e (fold_constants_com c)
fold_constants_com (CFor init cond updt body) =
  case fold_constants_bexp cond of
    BTrue => CSeq (fold_constants_com init) (CWhile BTrue SKIP)
    BFalse => fold_constants_com init
    e => CFor (fold_constants_com init)
              e
              (fold_constants_com updt)
              (fold_constants_com body)
fold_constants_com (CRepeat c b) =
  case fold_constants_bexp b of
    BTrue => fold_constants_com c
    BFalse => CSeq (fold_constants_com c) (CWhile BTrue SKIP)
    e => CRepeat (fold_constants_com c) e

fold_com_example_1 :
  fold_constants_com
    (do X ::= 4 + 5
        Y ::= X - 3
        IFB X - Y == 2 + 4
            THEN SKIP
            ELSE Y ::= 0
        FI
        IFB 0 <= 4 - (2 + 1)
            THEN Y ::= 0
            ELSE SKIP
        FI
        WHILE (Y == 0) $
          X ::= X + 1)
  = (do X ::= 9
        Y ::= X - 3
        IFB X - Y == 6
            THEN SKIP
            ELSE Y ::= 0
        FI
        Y ::= 0
        WHILE (Y == 0) $
          X ::= X + 1)
fold_com_example_1 = Refl

fold_constants_aexp_sound : ATransSound EquivFoldConstants.fold_constants_aexp
fold_constants_aexp_sound (ANum _) _ = Refl
fold_constants_aexp_sound (AId _) _ = Refl
fold_constants_aexp_sound (APlus a1 a2) st
  with (fold_constants_aexp a1) proof a1prf
    fold_constants_aexp_sound (APlus a1 a2) st | ANum _
      with (fold_constants_aexp a2) proof a2prf
        fold_constants_aexp_sound (APlus a1 a2) st | ANum _ | ANum _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (APlus a1 a2) st | ANum _ | AId _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (APlus a1 a2) st | ANum _ | APlus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (APlus a1 a2) st | ANum _ | AMinus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (APlus a1 a2) st | ANum _ | AMult _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    fold_constants_aexp_sound (APlus a1 a2) st | AId _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (APlus a1 a2) st | APlus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (APlus a1 a2) st | AMinus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (APlus a1 a2) st | AMult _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
fold_constants_aexp_sound (AMinus a1 a2) st
  with (fold_constants_aexp a1) proof a1prf
    fold_constants_aexp_sound (AMinus a1 a2) st | ANum _
      with (fold_constants_aexp a2) proof a2prf
        fold_constants_aexp_sound (AMinus a1 a2) st | ANum _ | ANum _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMinus a1 a2) st | ANum _ | AId _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMinus a1 a2) st | ANum _ | APlus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMinus a1 a2) st | ANum _ | AMinus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMinus a1 a2) st | ANum _ | AMult _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    fold_constants_aexp_sound (AMinus a1 a2) st | AId _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMinus a1 a2) st | APlus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMinus a1 a2) st | AMinus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMinus a1 a2) st | AMult _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
fold_constants_aexp_sound (AMult a1 a2) st
  with (fold_constants_aexp a1) proof a1prf
    fold_constants_aexp_sound (AMult a1 a2) st | ANum _
      with (fold_constants_aexp a2) proof a2prf
        fold_constants_aexp_sound (AMult a1 a2) st | ANum _ | ANum _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMult a1 a2) st | ANum _ | AId _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMult a1 a2) st | ANum _ | APlus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMult a1 a2) st | ANum _ | AMinus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_aexp_sound (AMult a1 a2) st | ANum _ | AMult _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    fold_constants_aexp_sound (AMult a1 a2) st | AId _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMult a1 a2) st | APlus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMult a1 a2) st | AMinus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_aexp_sound (AMult a1 a2) st | AMult _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl

fold_constants_bexp_sound : BTransSound EquivFoldConstants.fold_constants_bexp
fold_constants_bexp_sound BTrue _ = Refl
fold_constants_bexp_sound BFalse _ = Refl
fold_constants_bexp_sound (BEq a1 a2) st
  with (fold_constants_aexp a1) proof a1prf
    fold_constants_bexp_sound (BEq a1 a2) st | ANum k
      with (fold_constants_aexp a2) proof a2prf
        fold_constants_bexp_sound (BEq a1 a2) st | ANum k | ANum j
          with (k == j) proof eprf
            fold_constants_bexp_sound (BEq a1 a2) st | ANum k | ANum j | False =
              rewrite fold_constants_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite fold_constants_aexp_sound a2 st
              in rewrite sym a2prf
              in rewrite sym eprf
              in Refl
            fold_constants_bexp_sound (BEq a1 a2) st | ANum k | ANum j | True =
              rewrite fold_constants_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite fold_constants_aexp_sound a2 st
              in rewrite sym a2prf
              in rewrite sym eprf
              in Refl
        fold_constants_bexp_sound (BEq a1 a2) st | ANum _ | AId _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BEq a1 a2) st | ANum _ | APlus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BEq a1 a2) st | ANum _ | AMinus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BEq a1 a2) st | ANum _ | AMult _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    fold_constants_bexp_sound (BEq a1 a2) st | AId _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BEq a1 a2) st | APlus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BEq a1 a2) st | AMinus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BEq a1 a2) st | AMult _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
fold_constants_bexp_sound (BLe a1 a2) st
  with (fold_constants_aexp a1) proof a1prf
    fold_constants_bexp_sound (BLe a1 a2) st | ANum k
      with (fold_constants_aexp a2) proof a2prf
        fold_constants_bexp_sound (BLe a1 a2) st | ANum k | ANum j
          with (lte k j) proof lte_prf
            fold_constants_bexp_sound (BLe a1 a2) st | ANum k | ANum j | False =
              rewrite fold_constants_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite fold_constants_aexp_sound a2 st
              in rewrite sym a2prf
              in rewrite lte_prf
              in Refl
            fold_constants_bexp_sound (BLe a1 a2) st | ANum k | ANum j | True =
              rewrite fold_constants_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite fold_constants_aexp_sound a2 st
              in rewrite sym a2prf
              in rewrite lte_prf
              in Refl
        fold_constants_bexp_sound (BLe a1 a2) st | ANum _ | AId _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BLe a1 a2) st | ANum _ | APlus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BLe a1 a2) st | ANum _ | AMinus _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        fold_constants_bexp_sound (BLe a1 a2) st | ANum _ | AMult _ _ =
          rewrite fold_constants_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite fold_constants_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    fold_constants_bexp_sound (BLe a1 a2) st | AId _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BLe a1 a2) st | APlus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BLe a1 a2) st | AMinus _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
    fold_constants_bexp_sound (BLe a1 a2) st | AMult _ _ =
      rewrite fold_constants_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite fold_constants_aexp_sound a2 st
      in Refl
fold_constants_bexp_sound (BNot b) st
  with (fold_constants_bexp b) proof bprf
    fold_constants_bexp_sound (BNot b) st | BTrue =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
    fold_constants_bexp_sound (BNot b) st | BFalse =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
    fold_constants_bexp_sound (BNot b) st | BEq _ _ =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
    fold_constants_bexp_sound (BNot b) st | BLe _ _ =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
    fold_constants_bexp_sound (BNot b) st | BNot _ =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
    fold_constants_bexp_sound (BNot b) st | BAnd _ _ =
      rewrite fold_constants_bexp_sound b st
      in rewrite sym bprf
      in Refl
fold_constants_bexp_sound (BAnd b1 b2) st
  with (fold_constants_bexp b1) proof b1prf
    fold_constants_bexp_sound (BAnd b1 b2) st | BTrue =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in fold_constants_bexp_sound b2 st
    fold_constants_bexp_sound (BAnd b1 b2) st | BFalse =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in Refl
    fold_constants_bexp_sound (BAnd b1 b2) st | BEq _ _ =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite fold_constants_bexp_sound b2 st
      in Refl
    fold_constants_bexp_sound (BAnd b1 b2) st | BLe _ _ =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite fold_constants_bexp_sound b2 st
      in Refl
    fold_constants_bexp_sound (BAnd b1 b2) st | BNot _ =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite fold_constants_bexp_sound b2 st
      in Refl
    fold_constants_bexp_sound (BAnd b1 b2) st | BAnd _ _ =
      rewrite fold_constants_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite fold_constants_bexp_sound b2 st
      in Refl

fold_constants_com_sound : CTransSound EquivFoldConstants.fold_constants_com
fold_constants_com_sound CSkip st st' = refl_cequiv {c=CSkip} st st'
fold_constants_com_sound (CAss x e) st st' =
  let c_equiv = cAss_congruence (fold_constants_aexp_sound e)
  in c_equiv st st'
fold_constants_com_sound (CSeq c1 c2) st st' =
  let c_equiv = cSeq_congruence (fold_constants_com_sound c1)
                                (fold_constants_com_sound c2)
  in c_equiv st st'
fold_constants_com_sound (CIf b ct cf) st st'
  with (fold_constants_bexp b) proof bprf
    fold_constants_com_sound (CIf b ct cf) st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in trans_cequiv (test_true b_equiv) (fold_constants_com_sound ct) st st'
    fold_constants_com_sound (CIf b ct cf) st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in trans_cequiv (test_false b_equiv) (fold_constants_com_sound cf) st st'
    fold_constants_com_sound (CIf b ct cf) st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          ct_equiv = fold_constants_com_sound ct
          cf_equiv = fold_constants_com_sound cf
          cif_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in cif_equiv st st'
    fold_constants_com_sound (CIf b ct cf) st st' | BLe _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                            (sym bprf) (fold_constants_bexp_sound b st1)
          ct_equiv = fold_constants_com_sound ct
          cf_equiv = fold_constants_com_sound cf
          cif_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in cif_equiv st st'
    fold_constants_com_sound (CIf b ct cf) st st' | BNot _ =
      let b_equiv = \st1 =>
            replace {P=\x => beval st1 b = beval st1 x}
                    (sym bprf) (fold_constants_bexp_sound b st1)
          ct_equiv = fold_constants_com_sound ct
          cf_equiv = fold_constants_com_sound cf
          cif_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in cif_equiv st st'
    fold_constants_com_sound (CIf b ct cf) st st' | BAnd _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          ct_equiv = fold_constants_com_sound ct
          cf_equiv = fold_constants_com_sound cf
          cif_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in cif_equiv st st'
fold_constants_com_sound (CIf1 b c) st st'
  with (fold_constants_bexp b) proof bprf
    fold_constants_com_sound (CIf1 b c) st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in trans_cequiv (if1_true b_equiv) (fold_constants_com_sound c) st st'
    fold_constants_com_sound (CIf1 b c) st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in if1_false b_equiv st st'
    fold_constants_com_sound (CIf1 b c) st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (fold_constants_com_sound c)
      in cif1_equiv st st'
    fold_constants_com_sound (CIf1 b c) st st' | BLe _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (fold_constants_com_sound c)
      in cif1_equiv st st'
    fold_constants_com_sound (CIf1 b c) st st' | BNot _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (fold_constants_com_sound c)
      in cif1_equiv st st'
    fold_constants_com_sound (CIf1 b c) st st' | BAnd _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (fold_constants_com_sound c)
      in cif1_equiv st st'
fold_constants_com_sound (CWhile b c) st st'
  with (fold_constants_bexp b) proof bprf
    fold_constants_cwhile_sound (CWhile b c) st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in while_true b_equiv st st'
    fold_constants_cwhile_sound (CWhile b c) st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
      in while_false b_equiv st st'
    fold_constants_cwhile_sound (CWhile b c) st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          c_equiv = fold_constants_com_sound c
          while_equiv = cWhile_congruence b_equiv c_equiv
      in while_equiv st st'
    fold_constants_cwhile_sound (CWhile b c) st st' | BLe _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          c_equiv = fold_constants_com_sound c
          while_equiv = cWhile_congruence b_equiv c_equiv
      in while_equiv st st'
    fold_constants_cwhile_sound (CWhile b c) st st' | BNot _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          c_equiv = fold_constants_com_sound c
          while_equiv = cWhile_congruence b_equiv c_equiv
      in while_equiv st st'
    fold_constants_cwhile_sound (CWhile b c) st st' | BAnd _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (fold_constants_bexp_sound b st1)
          c_equiv = fold_constants_com_sound c
          while_equiv = cWhile_congruence b_equiv c_equiv
      in while_equiv st st'
fold_constants_com_sound (CFor init cond updt body) st st'
  with (fold_constants_bexp cond) proof cond_prf
    fold_constants_com_sound (CFor init cond updt body) st st' | BTrue =
      let cond_equiv = \st1 => cong {f=beval st1} (sym cond_prf)
          while_equiv = trans_cequiv
                          (trans_cequiv
                             (cFor_congruence
                                {cond1=fold_constants_bexp cond} {cond2=BTrue}
                                refl_cequiv cond_equiv refl_cequiv refl_cequiv)
                             for_while_equiv)
                          (cSeq_congruence (fold_constants_com_sound init)
                                           (while_true btrue_is_true))
          equiv = trans_cequiv (cFor_congruence
                                  refl_cequiv
                                  (fold_constants_bexp_sound cond)
                                  refl_cequiv
                                  refl_cequiv)
                                while_equiv
      in equiv st st'
    fold_constants_com_sound (CFor init cond updt body) st st' | BFalse =
      let cond_equiv = \st1 => cong {f=beval st1} (sym cond_prf)
          while_equiv = trans_cequiv
                          (trans_cequiv
                             (cFor_congruence
                                {cond1=fold_constants_bexp cond} {cond2=BFalse}
                                refl_cequiv cond_equiv refl_cequiv refl_cequiv)
                             for_while_equiv)
                          (cSeq_congruence (fold_constants_com_sound init)
                                           (while_false bfalse_is_false))
          equiv = trans_cequiv (cFor_congruence
                                  refl_cequiv
                                  (fold_constants_bexp_sound cond)
                                  refl_cequiv
                                  refl_cequiv)
                               (trans_cequiv while_equiv skip_right)
      in equiv st st'
    fold_constants_com_sound (CFor init cond updt body) st st' | BEq _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (fold_constants_com_sound init)
                                  cond_equiv
                                  (fold_constants_com_sound updt)
                                  (fold_constants_com_sound body)
      in equiv st st'
    fold_constants_com_sound (CFor init cond updt body) st st' | BLe _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (fold_constants_com_sound init)
                                  cond_equiv
                                  (fold_constants_com_sound updt)
                                  (fold_constants_com_sound body)
      in equiv st st'
    fold_constants_com_sound (CFor init cond updt body) st st' | BNot _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (fold_constants_com_sound init)
                                  cond_equiv
                                  (fold_constants_com_sound updt)
                                  (fold_constants_com_sound body)
      in equiv st st'
    fold_constants_com_sound (CFor init cond updt body) st st' | BAnd _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (fold_constants_com_sound init)
                                  cond_equiv
                                  (fold_constants_com_sound updt)
                                  (fold_constants_com_sound body)
      in equiv st st'
fold_constants_com_sound (CRepeat body cond) st st'
  with (fold_constants_bexp cond) proof cond_prf
    fold_constants_com_sound (CRepeat body cond) st st' | BTrue =
      let cond_equiv = trans_bequiv
                         (fold_constants_bexp_sound cond)
                         (\st1 => cong {f=beval st1} (sym cond_prf))
          while_equiv = trans_cequiv
                          (cRepeat_congruence (fold_constants_com_sound body)
                                              cond_equiv)
                          (trans_cequiv
                             repeat_while_equiv
                             (cSeq_congruence
                                refl_cequiv
                                (while_false bnot_btrue_is_bfalse)))
          equiv = trans_cequiv while_equiv skip_right
      in equiv st st'
    fold_constants_com_sound (CRepeat body cond) st st' | BFalse =
      let cond_equiv = trans_bequiv
                         (fold_constants_bexp_sound cond)
                         (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = trans_cequiv
                    (cRepeat_congruence (fold_constants_com_sound body)
                                        cond_equiv)
                    (trans_cequiv
                       repeat_while_equiv
                       (cSeq_congruence
                          refl_cequiv
                          (while_true bnot_bfalse_is_btrue)))
      in equiv st st'
    fold_constants_com_sound (CRepeat body cond) st st' | BEq _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (fold_constants_com_sound body) cond_equiv
      in equiv st st'
    fold_constants_com_sound (CRepeat body cond) st st' | BLe _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (fold_constants_com_sound body) cond_equiv
      in equiv st st'
    fold_constants_com_sound (CRepeat body cond) st st' | BNot _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (fold_constants_com_sound body) cond_equiv
      in equiv st st'
    fold_constants_com_sound (CRepeat body cond) st st' | BAnd _ _ =
      let cond_equiv = trans_bequiv (fold_constants_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (fold_constants_com_sound body) cond_equiv
      in equiv st st'


import VISD.Common

-- List Bool <-> Nat, with size and endianness

data Endianness = BE | LE

snoc : {n : Nat} -> {a : Type} -> (x : a) -> Vect n a -> Vect (S n) a
snoc x [] = [x]
snoc x (y :: xs) = (y :: snoc x xs)

reverse : {n : Nat} -> Vect n a -> Vect n a
reverse [] = []
reverse (x :: xs) = (snoc x (reverse xs))

reverse_snoc : {a : Type} -> {n : Nat} -> (x : a) -> (v : Vect n a) -> reverse (snoc x v) = x :: reverse v
reverse_snoc x [] = Refl
reverse_snoc x (y :: xs) = rewrite (reverse_snoc x xs) in Refl

double_reverse : (v : Vect n a) -> reverse (reverse v) = v
double_reverse [] = Refl
double_reverse (x :: xs) = rewrite (reverse_snoc x (reverse xs)) in
  rewrite (double_reverse xs) in Refl

order : Endianness -> Vect n Bool -> Vect n Bool
order BE v = reverse v
order LE v = v

double_order : (e : Endianness) -> (v : Vect n Bool) -> order e (order e v) = v
double_order BE v = (double_reverse v)
double_order LE v = Refl

div2 : Nat -> Nat
div2 Z = 0
div2 (S Z) = 0
div2 (S (S k)) = div2' (S k)
  where -- a hack for totality checker
    div2' : Nat -> Nat
    div2' Z = 0
    div2' (S n) = S (div2 n)

div2_zero : (k : Nat) -> (lte k (S Z) = True) -> div2 k = Z
div2_zero Z prf = Refl
div2_zero (S Z) prf = Refl
div2_zero (S (S k)) prf = (void (trueNotFalse (sym prf)))

mul2 : Nat -> Nat
mul2 Z = 0
mul2 (S k) = (S (S (mul2 k)))

mul2_n_zero : (n : Nat) -> (mul2 n = Z) -> n = Z
mul2_n_zero Z prf = Refl
mul2_n_zero (S k) prf = void $ OnotS (sym prf)

mul2_zero_n : (n : Nat) -> n = Z -> mul2 n = Z
mul2_zero_n n prf = rewrite prf in Refl

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

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

even_inv : (n : Nat) -> (even (S n) = not (even n))
even_inv Z = Refl
even_inv (S Z) = Refl
even_inv (S (S k)) = (even_inv k)

mul2_even : (n : Nat) -> even (mul2 n) = True
mul2_even Z = Refl
mul2_even (S k) = (mul2_even k)

mul2_not_odd : (n : Nat) -> odd (mul2 n) = False
mul2_not_odd Z = Refl
mul2_not_odd (S k) = (mul2_not_odd k)

div2_mul2_n_eq_n : (n : Nat) -> div2 (mul2 n) = n
div2_mul2_n_eq_n Z = Refl
div2_mul2_n_eq_n (S k) = cong {f=S} $ div2_mul2_n_eq_n k

div2_S_mul2_n_eq_n : (n : Nat) -> div2 (S (mul2 n)) = n
div2_S_mul2_n_eq_n Z = Refl
div2_S_mul2_n_eq_n (S k) = cong {f=S} $ div2_S_mul2_n_eq_n k

mul2_div2_even : (n : Nat) -> (even n = True) -> mul2 (div2 n) = n
mul2_div2_even Z prf = Refl
mul2_div2_even (S Z) prf = (void (trueNotFalse (sym prf)))
mul2_div2_even (S (S k)) prf = cong {f=S} $ cong {f=S} (mul2_div2_even k prf)

mul2_div2_eq : (n, m : Nat) -> (even m = True) -> (n = div2 m) -> mul2 n = m
mul2_div2_eq n m evp eqp = rewrite eqp in (mul2_div2_even m evp)

div2_S_even : (n : Nat) -> (even n = True) -> div2 (S n) = div2 n
div2_S_even Z prf = Refl
div2_S_even (S Z) prf = (void (trueNotFalse (sym prf)))
div2_S_even (S (S k)) prf = cong {f=S} (div2_S_even k prf)

natToBitsLe : (k : Nat) -> Nat -> Maybe (Vect k Bool)
natToBitsLe bits Z = Just $ replicate bits False
natToBitsLe Z n = Nothing
natToBitsLe (S bits) n = do
  next <- natToBitsLe bits (div2 n)
  return $ odd n :: next

bitsToNatLe : Vect k Bool -> Nat
bitsToNatLe [] = Z
bitsToNatLe (v :: l) = (if v then 1 else 0) + (mul2 $ bitsToNatLe l)

btnl_zero_step : (xs : Vect k Bool) -> (bitsToNatLe (False :: xs) = Z) -> bitsToNatLe xs = Z
btnl_zero_step xs prf = mul2_n_zero (bitsToNatLe xs) $
  replace {P=(\x => 0 + x = Z)} (plusZeroLeftNeutral (mul2 $ bitsToNatLe xs)) prf

btnl_zero : (n : Nat) -> (v : Vect n Bool) -> bitsToNatLe v = Z -> v = Vect.replicate n False
btnl_zero Z [] prf = Refl
btnl_zero (S k) (False :: xs) prf = cong {f=((Vect.(::)) False)} (btnl_zero k xs (btnl_zero_step xs prf))
btnl_zero (S k) (True :: xs) prf = (void $ OnotS (sym prf))

ntbl_zero : (x : Nat) -> (xs : Vect x Bool) -> natToBitsLe x Z = Just xs -> xs = Vect.replicate x False
ntbl_zero Z [] prf = Refl
ntbl_zero (S n) (y :: xs) prf =
  rewrite (justInjective (replace {P=(\z => z = Just (y :: xs))} (ntbl_zero' (S n)) prf)) in Refl
  where
    ntbl_zero' : (x : Nat) -> natToBitsLe x Z = Just $ Vect.replicate x False
    ntbl_zero' x = Refl

ntbl_step_false : (n : Nat) -> (xs : Vect n Bool) ->
  natToBitsLe n (bitsToNatLe xs) = Just xs ->
  natToBitsLe (S n) (mul2 (bitsToNatLe xs)) = Just (False :: xs)
ntbl_step_false x xs prf with (bitsToNatLe xs)
  | Z = rewrite (ntbl_zero x xs prf) in Refl
  | S m = rewrite (div2_mul2_n_eq_n (S m)) in
    rewrite prf in
      rewrite (mul2_not_odd m) in Refl

ntbl_step_true : (n : Nat) -> (xs : Vect n Bool) ->
  natToBitsLe n (bitsToNatLe xs) = Just xs ->
  natToBitsLe (S n) (S (mul2 (bitsToNatLe xs))) = Just (True :: xs)
ntbl_step_true n xs prf = rewrite (mul2_even (bitsToNatLe xs)) in
  rewrite (div2_S_mul2_n_eq_n (bitsToNatLe xs)) in
    rewrite prf in Refl

ntbl_btnl : (k : Nat) -> (v : Vect k Bool) -> natToBitsLe k (bitsToNatLe v) = Just v
ntbl_btnl Z [] = Refl
ntbl_btnl (S n) (x :: xs) with (inspect $ bitsToNatLe xs)
    | match Z {eq=eq} = rewrite eq in
      rewrite (btnl_zero n xs eq) in case (inspect x) of
        match True {eq=eq1} => rewrite eq1 in Refl
        match False {eq=eq1} => rewrite eq1 in Refl
    | match (S m) {eq=eq} = case (inspect x) of
      match True {eq=eq1} => rewrite eq1 in (ntbl_step_true n xs (ntbl_btnl n xs))
      match False {eq=eq1} => rewrite eq1 in (ntbl_step_false n xs (ntbl_btnl n xs))

btnl_rep_false : (k : Nat) -> bitsToNatLe (replicate k False) = Z
btnl_rep_false Z = Refl
btnl_rep_false (S k) = (mul2_zero_n (bitsToNatLe (replicate k False)) (btnl_rep_false k))

btnl_ntbl : (k, n : Nat) -> maybe () (\x => bitsToNatLe x = n) $ natToBitsLe k n
btnl_ntbl k Z = (btnl_rep_false k)
btnl_ntbl Z (S j) = ()
btnl_ntbl (S k) (S j) with (inspect $ natToBitsLe k (div2 (S j)))
  | match Nothing {eq=eq} = rewrite eq in ()
  | match (Just xs) {eq=eq} = rewrite eq in case (inspect $ even j) of
    match True {eq=eq1} => rewrite eq1 in cong {f=S} $
      mul2_div2_eq (bitsToNatLe xs) j eq1 $
        replace {P=(\p => maybe () (\x => bitsToNatLe x = div2 j) p)}
          (replace {P=(\p => natToBitsLe k p = Just xs)} (div2_S_even j eq1) eq)
          (btnl_ntbl k (div2 j))
    match False {eq=eq1} => rewrite eq1 in
      mul2_div2_eq (bitsToNatLe xs) (S j) (replace {P=(\p => even (S j) = not p)} eq1 (even_inv j)) $
        replace {P=(\p => maybe () ((\x => bitsToNatLe x = div2 (S j))) p)} eq (btnl_ntbl k (div2 $ S j))

just_btnl_ntbl : (k, n : Nat) -> maybe () (\x => Just (bitsToNatLe x) = Just n) $ natToBitsLe k n
just_btnl_ntbl k n with (inspect $ natToBitsLe k n)
      | match Nothing {eq=eq} = rewrite eq in ()
      | match (Just v) {eq=eq} = rewrite eq in cong {f=Just} $ case (btnl_ntbl k n) of
        wojust => replace eq wojust

natLeIso : (k : Nat) -> PartIso (Vect k Bool) Nat
natLeIso k = MkPartIso (Just . bitsToNatLe) (natToBitsLe k) tf ft
  where
    tf n = just_btnl_ntbl k n
    ft v = ntbl_btnl k v

natLe : Syntax d Bool => (k : Nat) -> d Nat Bool
natLe k = natLeIso k <$> rep k item

natToBits : Endianness -> (k : Nat) -> Nat -> Maybe (Vect k Bool)
natToBits e k n = natToBitsLe k n >>= Just . order e

bitsToNat : Endianness -> Vect n Bool -> Maybe Nat
bitsToNat e v = Just $ bitsToNatLe (order e v)

btn_ntb : (k, n : Nat) -> (e : Endianness) -> maybe () (\x => bitsToNat e x = Just n) $ natToBits e k n
btn_ntb k n e with (inspect $ natToBitsLe k n)
  | match Nothing {eq=eq} = rewrite eq in ()
  | match (Just as) {eq=eq} = rewrite eq in rewrite (double_order e as) in
    cong {f=Just} (replace eq {P=(\y => maybe () (\x => bitsToNatLe x = n) y)} (btnl_ntbl k n))

ntb_btn : (k : Nat) -> (e : Endianness) -> (v : Vect k Bool) ->
  maybe () (\x => natToBits e k x = Just v) $ bitsToNat e v
ntb_btn k e v = rewrite (ntbl_btnl k (order e v)) in rewrite (double_order e v) in Refl

natIso : (e : Endianness) -> (k : Nat) -> PartIso (Vect k Bool) Nat
natIso e k = MkPartIso (bitsToNat e) (natToBits e k) tf ft
  where
    tf n = (btn_ntb k n e)
    ft v = (ntb_btn k e v)

nat : Syntax d Bool => Endianness -> Nat -> d Nat Bool
nat endianness size = natIso endianness size <$> rep size item


module VecTk

import Data.Vect
import Data.Fin

tk : (k : Nat) -> Vect (k + n) a -> Vect n a
tk Z xs = xs
tk (S k) (x::xs) = tk k xs


import Data.Vect

myReverse : Vect n elem -> Vect n elem
myReverse [] = []
myReverse (x :: xs) = reverseProof (myReverse xs ++ [x]) where
                      reverseProof : Vect (len + 1) elem -> Vect (S len) elem
                      reverseProof result = rewrite plusCommutative 1 len in result


module Main

import Data.List

%default total

data RegExp: Type -> Type where
  Atom: a -> RegExp a
  Disj: RegExp a -> RegExp a -> RegExp a
  Seq: RegExp a -> RegExp a -> RegExp a
  Star: RegExp a -> RegExp a
  Empty: RegExp a
  Nothing: RegExp a

data RegExpSpec: RegExp a -> List a -> Type where
  AtomSpec: (x : a) -> RegExpSpec (Atom x) [x]
  DisjSpec1: (r1 : RegExp a) ->
             (r2: RegExp a) -> (xs : List a) ->
             (RegExpSpec r1 xs) ->
             RegExpSpec (Disj r1 r2) xs
  DisjSpec2: (r1 : RegExp a) ->
             (r2: RegExp a) -> (xs : List a) ->
             (RegExpSpec r2 xs) ->
             RegExpSpec (Disj r1 r2) xs
  SeqSpec: (xs : List a) -> (ys : List a) -> (zs : List a) ->
           (r1 : RegExp a) -> (r2 : RegExp a) ->
           RegExpSpec r1 xs ->
           RegExpSpec r2 ys ->
           zs = xs ++ ys ->
           RegExpSpec (Seq r1 r2) zs
  StarSpec0: (r: RegExp a) ->
             RegExpSpec (Star r) []
  StarSpecS: (xs : List a) -> (ys : List a) ->
             (zs : List a) ->
             (r : RegExp a) ->
             RegExpSpec r xs ->
             RegExpSpec (Star r) ys ->
             (zs = xs ++ ys) ->
             RegExpSpec (Star r) zs
  EmptySpec: RegExpSpec Empty []

isEmpty : RegExp a -> RegExp a
isEmpty (Atom x) = Nothing
isEmpty (Disj x y) = Disj (isEmpty x) (isEmpty y)
isEmpty (Seq x y) = Seq (isEmpty x) (isEmpty y)
isEmpty (Star x) = Empty
isEmpty Empty = Empty
isEmpty Nothing = Nothing

atom_case : (x : a) -> RegExpSpec (Atom x) [] -> Void
atom_case _ _ impossible

disj_case : (x: RegExp a) -> (y: RegExp a) ->
            (contra1: RegExpSpec x [] -> Void) ->
            (contra2: RegExpSpec y [] -> Void) ->
            RegExpSpec (Disj x y) [] -> Void
disj_case x y contra1 contra2 (DisjSpec1 x y [] z) = contra1 z
disj_case x y contra1 contra2 (DisjSpec2 x y [] z) = contra2 z

seq_yes_case : (x : RegExp a) -> (y : RegExp a) ->
               RegExpSpec x [] -> RegExpSpec y [] ->
               RegExpSpec (Seq x y) []
seq_yes_case x y prf1 prf2 = SeqSpec [] [] [] x y prf1 prf2 Refl

about_list1 : (xs : List a) -> (ys : List a) ->
              [] = xs ++ ys -> [] = xs
about_list1 [] ys prf = Refl
about_list1 (_ :: _) _ Refl impossible

about_list2 : (xs : List a) -> (ys : List a) ->
              [] = xs ++ ys -> [] = ys
about_list2 [] [] Refl = Refl
about_list2 (_ :: _) _ Refl impossible

about_list3 : (x : a) -> (y : a) -> (xs : List a) ->
              (ys : List a) -> (zs : List a) -> x :: xs = (y :: ys) ++ zs ->
              (x = y, xs = ys ++ zs)
about_list3 y y (ys ++ zs) ys zs Refl = (Refl, Refl)

about_list4 : (x : a) -> (xs : List a) -> (ys : List a) ->
              (zs : List a) -> x :: xs = ys ++ zs ->
                Either (DPair (List a) (\ys' => (ys = x :: ys', xs = ys' ++ zs)))
                       (ys = [], zs = x :: xs)
about_list4 x xs [] zs prf = Right (Refl, sym prf)
about_list4 x xs (y :: ys) zs prf =
  let (Refl, h2) = about_list3 x y xs ys zs prf in (Left (MkDPair ys (Refl, h2)))

seq_no_case1: (x : RegExp a) -> (y : RegExp a) ->
              (RegExpSpec x [] -> Void) -> RegExpSpec (Seq x y) [] -> Void
seq_no_case1 x y f (SeqSpec xs ys [] x y z w prf) =
  let h = about_list1 xs ys prf in
  f (rewrite h in z)

seq_no_case2: (x : RegExp a) -> (y : RegExp a) ->
              (RegExpSpec y [] -> Void) -> RegExpSpec (Seq x y) [] -> Void
seq_no_case2 x y f (SeqSpec xs ys [] x y z w prf) =
  let h = about_list2 xs ys prf in
  f (rewrite h in w)

match_nothing_is_false : (xs : List a) ->
                         RegExpSpec Nothing xs -> Void
match_nothing_is_false _ _ impossible

decEmpty : (r : RegExp a) -> Dec (RegExpSpec r [])
decEmpty (Atom x) = No (atom_case x)
decEmpty (Disj x y) =
  case (decEmpty x, decEmpty y) of
    (Yes prf, _) => Yes (DisjSpec1 x y [] prf)
    (_, Yes prf) => Yes (DisjSpec2 x y [] prf)
    (No contra1, No contra2) => No (disj_case x y contra1 contra2)
decEmpty (Seq x y) =
  case (decEmpty x, decEmpty y) of
    (Yes prf1, Yes prf2) => Yes (seq_yes_case x y prf1 prf2)
    (No contra, _) => No (seq_no_case1 x y contra)
    (_, No contra) =>  No (seq_no_case2 x y contra)
decEmpty (Star x) = Yes (StarSpec0 x)
decEmpty Empty = Yes EmptySpec
decEmpty Nothing = No (match_nothing_is_false [])

derive : DecEq a => (r : RegExp a) -> (x : a) -> RegExp a
derive (Atom y) x = case decEq y x of
                      Yes _ => Empty
                      No _ => Nothing
derive (Disj y z) x = Disj (derive y x) (derive z x)
derive (Seq y z) x = Disj (Seq (derive y x) z) (Seq (isEmpty y) (derive z x))
derive (Star y) x = Seq (derive y x) (Star y)
derive Empty x = Nothing
derive Nothing x = Nothing

empty_match_implies_empty_list : RegExpSpec Empty xs -> xs = []
empty_match_implies_empty_list EmptySpec = Refl

is_empty_match_implies_empty_list :
  (r : RegExp a) ->
  (xs : List a) -> RegExpSpec (isEmpty r) xs -> xs = []
is_empty_match_implies_empty_list (Atom y) xs x =
  void (match_nothing_is_false xs x)
is_empty_match_implies_empty_list (Disj y z) xs (DisjSpec1 (isEmpty y) (isEmpty z) xs x) =
  is_empty_match_implies_empty_list y xs x
is_empty_match_implies_empty_list (Disj y z) xs (DisjSpec2 (isEmpty y) (isEmpty z) xs x) =
  is_empty_match_implies_empty_list z xs x
is_empty_match_implies_empty_list (Seq y z) xs (SeqSpec ys zs xs (isEmpty y) (isEmpty z) x w prf) =
  rewrite prf in
    (let h1 = is_empty_match_implies_empty_list y ys x
         h2 = is_empty_match_implies_empty_list z zs w
     in rewrite h1 in rewrite h2 in Refl)
is_empty_match_implies_empty_list (Star y) xs x = empty_match_implies_empty_list x
is_empty_match_implies_empty_list Empty xs x = empty_match_implies_empty_list x
is_empty_match_implies_empty_list Nothing xs x = void (match_nothing_is_false xs x)

is_empty_is_sound : (r : RegExp a) -> (xs : List a) ->
         RegExpSpec (isEmpty r) xs -> RegExpSpec r []
is_empty_is_sound (Atom y) xs x = void (match_nothing_is_false xs x)
is_empty_is_sound (Disj y z) xs (DisjSpec1 (isEmpty y) (isEmpty z) xs x) =
  let h = is_empty_is_sound y xs x in (DisjSpec1 y z [] h)
is_empty_is_sound (Disj y z) xs (DisjSpec2 (isEmpty y) (isEmpty z) xs x) =
  let h = is_empty_is_sound z xs x in (DisjSpec2 y z [] h)
is_empty_is_sound (Seq y z) xs (SeqSpec ys zs xs (isEmpty y) (isEmpty z) x w prf) =
    let h1 = is_empty_is_sound y ys x in
    let h2 = is_empty_is_sound z zs w in SeqSpec [] [] [] y z h1 h2 Refl
is_empty_is_sound (Star y) xs x = StarSpec0 y
is_empty_is_sound Empty xs x = EmptySpec
is_empty_is_sound Nothing xs x = void (match_nothing_is_false xs x)

derivative_is_sound: DecEq a => (r : RegExp a) ->
                     (x : a) -> (xs : List a) ->
                     RegExpSpec (derive r x) xs -> RegExpSpec r (x :: xs)
derivative_is_sound (Atom z) x xs y with (decEq z x)
  derivative_is_sound (Atom x) x xs y | (Yes Refl) =
    rewrite (empty_match_implies_empty_list y) in AtomSpec x
  derivative_is_sound (Atom z) x xs y | (No contra) =
    void (match_nothing_is_false xs y)
derivative_is_sound (Disj z w) x xs y =
  case y of
    (DisjSpec1 (derive z x) _ xs y) =>
      let z' = (derivative_is_sound z x xs y)
      in DisjSpec1 z w (x :: xs) z'
    (DisjSpec2 _ (derive w x) xs y) =>
      let z' = (derivative_is_sound w x xs y)
      in DisjSpec2 z w (x :: xs) z'
derivative_is_sound (Seq r1 r2) x xs (DisjSpec1 (Seq _ _) (Seq _ _) xs (SeqSpec ys zs xs _ r2 y z prf)) =
  let h' = derivative_is_sound r1 x ys y
  in rewrite prf in
  SeqSpec (x :: ys) zs (x :: ys ++ zs) r1 r2 h' z Refl
derivative_is_sound (Seq r1 r2) x xs (DisjSpec2 (Seq _ r2) (Seq _ _) xs (SeqSpec ys zs xs (isEmpty r1) _ y s prf)) =
  rewrite prf in
  rewrite (is_empty_match_implies_empty_list r1 ys y) in
  let h1 = derivative_is_sound r2 x zs s in
  let h2 = is_empty_is_sound r1 ys y in
  SeqSpec [] (x :: zs) (x :: zs) r1 r2 h2 h1 Refl
derivative_is_sound (Star z) x _ (SeqSpec xs ys zs _ (Star z) y w prf) =
  rewrite prf in
  let h = derivative_is_sound z x xs y in
  StarSpecS (x :: xs) ys (x :: xs ++ ys) z h w Refl
derivative_is_sound Empty _ _ _ impossible
derivative_is_sound Nothing _ _ _ impossible

atom_match_implies: (x : a) -> (xs : List a) ->
                    RegExpSpec (Atom x) (x :: xs) -> xs = []
atom_match_implies x [] (AtomSpec x) = Refl

atom_match_implies2: (x : a) -> (y : a) -> (xs : List a) ->
                     RegExpSpec (Atom x) (y :: xs) -> x = y
atom_match_implies2 y y [] (AtomSpec y) = Refl

cons_is_not_nil : (x : a) -> (xs : List a) -> x :: xs = [] -> Void
cons_is_not_nil _ _ Refl impossible

is_empty_is_complete : (r : RegExp a) -> RegExpSpec r [] ->
                       RegExpSpec (isEmpty r) []
is_empty_is_complete (Atom _) _ impossible
is_empty_is_complete (Disj y z) (DisjSpec1 y z [] x) =
  let h = is_empty_is_complete y x in
  DisjSpec1 (isEmpty y) (isEmpty z) [] h
is_empty_is_complete (Disj y z) (DisjSpec2 y z [] x) =
  let h = is_empty_is_complete z x in
  DisjSpec2 (isEmpty y) (isEmpty z) [] h
is_empty_is_complete (Seq y z) (SeqSpec xs ys [] y z x w prf) =
  let h1 = about_list1 xs ys prf in
  let h2 = about_list2 xs ys prf in
  let ih1 = is_empty_is_complete y (rewrite h1 in x) in
  let ih2 = is_empty_is_complete z (rewrite h2 in w) in
  SeqSpec [] [] [] (isEmpty y) (isEmpty z) ih1 ih2 Refl
is_empty_is_complete (Star y) x = EmptySpec
is_empty_is_complete Empty x = x
is_empty_is_complete Nothing x = x

append_nil_neutral : (xs : List a) -> xs ++ [] = xs
append_nil_neutral [] = Refl
append_nil_neutral (x :: xs) =
  let h = append_nil_neutral xs in
  rewrite h in Refl

about_list5 : (x : a) -> (y : a) -> (xs : List a) -> (ys : List a) -> (zs : List a) ->
              x :: xs = (y :: ys) ++ zs -> (x = y, xs = ys ++ zs)
about_list5 x _ (ys ++ zs) ys zs Refl = (Refl, Refl)

mutual {
star_case : DecEq a => (r : RegExp a) -> (x : a) ->
            (xs : List a) -> RegExpSpec (Star r) xs ->
            (xs' : List a) ->
            xs = x :: xs' ->
            RegExpSpec (Seq (derive r x) (Star r)) xs'
star_case r x [] (StarSpec0 r) = \xs', contra => void (cons_is_not_nil x xs' (sym contra))
star_case r x _ (StarSpecS [] zs _ r y z Refl) = \xs', Refl =>
  star_case r x (x :: xs') z xs' Refl
star_case r x xs (StarSpecS (w :: ys) zs xs r y z prf) = \xs', Refl =>
  let (Refl, Refl) = about_list5 x w xs' ys zs prf in
  let h = derivative_is_complete r x ys y in
  SeqSpec ys zs (ys ++ zs) (derive r x) (Star r) h z Refl

derivative_is_complete : (DecEq a) => (r : RegExp a) -> (x : a) -> (xs : List a) -> RegExpSpec r (x :: xs) -> RegExpSpec (derive r x) xs
derivative_is_complete (Atom z) x xs y with (decEq z x)
  derivative_is_complete (Atom x) x xs y | (Yes Refl) =
    rewrite (atom_match_implies x xs y) in EmptySpec
  derivative_is_complete (Atom z) x xs y | (No contra) =
   void (contra (atom_match_implies2 z x xs y))
derivative_is_complete (Disj z w) x xs (DisjSpec1 z w (x :: xs) y) =
  let h = derivative_is_complete z x xs y in
  DisjSpec1 (derive z x) (derive w x) xs h
derivative_is_complete (Disj z w) x xs (DisjSpec2 z w (x :: xs) y) =
  let h = derivative_is_complete w x xs y in
  DisjSpec2 (derive z x) (derive w x) xs h
derivative_is_complete (Seq z w) x xs (SeqSpec ys zs (x :: xs) z w y s prf) =
  case about_list4 x xs ys zs prf of
    Left (ys' ** (h1, h2)) =>
      rewrite h2 in
      let h = derivative_is_complete z x ys' (rewrite sym h1 in y) in
      DisjSpec1 (Seq (derive z x) w) (Seq (isEmpty z) (derive w x)) (ys' ++ zs)
        (SeqSpec ys' zs (ys' ++ zs) (derive z x) w h s Refl)
    Right (h1, h2) =>
      let h = derivative_is_complete w x xs (rewrite sym h2 in s) in
      DisjSpec2 (Seq (derive z x) w) (Seq (isEmpty z) (derive w x)) xs
        (SeqSpec [] xs xs (isEmpty z) (derive w x) (is_empty_is_complete z (rewrite sym h1 in y)) h Refl)
derivative_is_complete (Star r) x xs prf =
  star_case r x (x :: xs) prf xs Refl
derivative_is_complete Empty x xs y =
  let h = empty_match_implies_empty_list y in void (cons_is_not_nil x xs h)
derivative_is_complete Nothing x xs y = void (match_nothing_is_false (x :: xs) y)
}

match : DecEq a => (xs : List a) -> (r : RegExp a) -> Dec (RegExpSpec r xs)
match [] r = decEmpty r
match (x :: xs) r =
  case match xs (derive r x) of
    Yes prf => Yes (derivative_is_sound r x xs prf)
    No contra => No (contra . (derivative_is_complete r x xs))


import Control.Monad.State

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

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                      (Node Empty "Sheila" Empty)) "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right

treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
treeLabelWith Empty = pure Empty
treeLabelWith (Node left val right)
     = do left_labelled <- treeLabelWith left
          (this :: rest) <- get
          put rest
          right_labelled <- treeLabelWith right
          pure (Node left_labelled (this, val) right_labelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = evalState [1..] (treeLabelWith tree)


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

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                      (Node Empty "Sheila" Empty)) "Alice"
                (Node Empty "Bob" (Node Empty "Eve" Empty))

flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right

treeLabelWith : Stream labelType -> Tree a ->
                (Stream labelType, Tree (labelType, a))
treeLabelWith lbls Empty = (lbls, Empty)
treeLabelWith lbls (Node left val right)
     = let (this :: lblsLeft, left_labelled) = treeLabelWith lbls left
           (lblsRight, right_labelled) = treeLabelWith lblsLeft right
                in
           (lblsRight, Node left_labelled (this, val) right_labelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = snd (treeLabelWith [1..] tree)


= ImpCEvalFun : Evaluation Function for Imp

> module ImpCEvalFun

We saw in the `Imp` chapter how a naive approach to defining a function
representing evaluation for Imp runs into difficulties. There, we adopted the
solution of changing from a functional to a relational definition of evaluation.
In this optional chapter, we consider strategies for getting the functional
approach to work.

> import Logic
> import Maps
> import Imp

> %access public export
> %default total

== A Broken Evaluator

Here was our first try at an evaluation function for commands, omitting
\idr{WHILE}.

> ceval_step1 : (st : State) -> (c : Com) -> State
> ceval_step1 st CSkip = st
> ceval_step1 st (CAss l a1) = t_update l (aeval st a1) st
> ceval_step1 st (CSeq c1 c2) =
>   let st' = ceval_step1 st c1
>   in ceval_step1 st' c2
> ceval_step1 st (CIf b c1 c2) =
>   if beval st b
>     then ceval_step1 st c1
>     else ceval_step1 st c2
> ceval_step1 st (CWhile b c) = st   -- bogus

As we remarked in chapter `Imp`, in a traditional functional programming
language like ML or Haskell we could write the WHILE case as follows:

```idris
...
ceval_step1 st (CWhile b c) =
  if (beval st b)
    then ceval_step1 st (CSeq c $ CWhile b c)
    else st
```

Idris doesn't accept such a definition (\idr{ImpCEvalFun.ceval_step1 is possibly
not total due to recursive path ImpCEvalFun.ceval_step1 -->
ImpCEvalFun.ceval_step1 --> ImpCEvalFun.ceval_step1}) because the function we
want to define is not guaranteed to terminate. Indeed, the changed
\idr{ceval_step1} function applied to the \idr{loop} program from `Imp.lidr`
would never terminate. Since Idris is not just a functional programming
language, but also a consistent logic, any potentially non-terminating function
needs to be rejected. Here is an invalid(!) Idris program showing what would go
wrong if Idris allowed non-terminating recursive functions:

```idris
loop_false : (n : Nat) -> Void
loop_false n = loop_false n
```

That is, propositions like \idr{Void} would become provable (e.g.,
\idr{loop_false 0} would be a proof of \idr{Void}), which would be a disaster
for Idris's logical consistency.

Thus, because it doesn't terminate on all inputs, the full version of
\idr{ceval_step1} cannot be written in Idris -- at least not without one
additional trick...

== A Step-Indexed Evaluator

The trick we need is to pass an _additional_ parameter to the evaluation
function that tells it how long to run. Informally, we start the evaluator with
a certain amount of "gas" in its tank, and we allow it to run until either it
terminates in the usual way _or_ it runs out of gas, at which point we simply
stop evaluating and say that the final result is the empty memory. (We could
also say that the result is the current state at the point where the evaluator
runs out fo gas -- it doesn't really matter because the result is going to be
wrong in either case!)

> ceval_step2 : (st : State) -> (c : Com) -> (i : Nat) -> State
> ceval_step2 _ _ Z = empty_state
> ceval_step2 st CSkip (S i') = st
> ceval_step2 st (CAss l a1) (S i') = t_update l (aeval st a1) st
> ceval_step2 st (CSeq c1 c2) (S i') =
>   let st' = ceval_step2 st c1 i'
>   in ceval_step2 st' c2 i'
> ceval_step2 st (CIf b c1 c2) (S i') =
>   if beval st b
>     then ceval_step2 st c1 i'
>     else ceval_step2 st c2 i'
> ceval_step2 st c@(CWhile b1 c1) (S i') =
>   if (beval st b1)
>     then let st' = ceval_step2 st c1 i' in
>          ceval_step2 st' c i'
>     else st

_Note_: It is tempting to think that the index \idr{i} here is counting the
"number of steps of evaluation." But if you look closely you'll see that this
is not the case: for example, in the rule for sequencing, the same \idr{i} is
passed to both recursive calls. Understanding the exact way that \idr{i} is
treated will be important in the proof of \idr{ceval__ceval_step}, which is
given as an exercise below.

One thing that is not so nice about this evaluator is that we can't tell, from
its result, whether it stopped because the program terminated normally or
because it ran out of gas.  Our next version returns an \idr{Maybe State}
instead of just a \idr{State}, so that we can distinguish between normal and
abnormal termination.

> ceval_step3 : (st : State) -> (c : Com) -> (i : Nat) -> Maybe State
> ceval_step3 _ _ Z = Nothing
> ceval_step3 st CSkip (S i') = Just st
> ceval_step3 st (CAss l a1) (S i') = Just $ t_update l (aeval st a1) st
> ceval_step3 st (CSeq c1 c2) (S i') =
>   case ceval_step3 st c1 i' of
>     Just st' => ceval_step3 st' c2 i'
>     Nothing => Nothing
> ceval_step3 st (CIf b c1 c2) (S i') =
>   if beval st b
>     then ceval_step3 st c1 i'
>     else ceval_step3 st c2 i'
> ceval_step3 st c@(CWhile b1 c1) (S i') =
>   if (beval st b1)
>     then case ceval_step3 st c1 i' of
>            Just st' => ceval_step3 st' c i'
>            Nothing => Nothing
>     else Just st

We can improve the readability of this version by using the fact that /idr{Maybe} forms a monad to hide the plumbing involved in repeatedly matching against optional
states.

```idris
Monad Maybe where
    Nothing  >>= k = Nothing
    (Just x) >>= k = k x
```

> ceval_step : (st : State) -> (c : Com) -> (i : Nat) -> Maybe State
> ceval_step _ _ Z = Nothing
> ceval_step st CSkip (S i') = Just st
> ceval_step st (CAss l a1) (S i') = Just $ t_update l (aeval st a1) st
> ceval_step st (CSeq c1 c2) (S i') =
>   do st' <- ceval_step st c1 i'
>      ceval_step st' c2 i'
> ceval_step st (CIf b c1 c2) (S i') =
>   if beval st b
>     then ceval_step st c1 i'
>     else ceval_step st c2 i'
> ceval_step st c@(CWhile b1 c1) (S i') =
>   if (beval st b1)
>     then do st' <- ceval_step st c1 i'
>             ceval_step st' c i'
>     else Just st

> test_ceval : (st : State) -> (c : Com) -> Maybe (Nat, Nat, Nat)
> test_ceval st c  = case ceval_step st c 500 of
>   Nothing => Nothing
>   Just st => Just (st X, st Y, st Z)

\todo[inline]{Syntax sugar for IF breaks down here}

```idris
λΠ> test_ceval Imp.empty_state (CSeq (X ::= ANum 2) (CIf (BLe (AId X) (ANum 1)) (Y ::= ANum 3) (Z ::= ANum 4)))
Just (2, 0, 4) : Maybe (Nat, Nat, Nat)
```

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

Write an Imp program that sums the numbers from \idr{1} to \idr{X} (inclusive:
\idr{1 + 2 + ... + X}) in the variable \idr{Y}. Make sure your solution
satisfies the test that follows.

> pup_to_n : Com
> pup_to_n = ?pup_to_n_rhs

> pup_to_n_1 : test_ceval (t_update X 5 $ Imp.empty_state) ImpCEvalFun.pup_to_n = Just (0, 15, 0)
> pup_to_n_1 = ?pup_to_n_1 -- replace with Refl when done

$\square$

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

Write a \idr{While} program that sets \idr{Z} to \idr{0} if \idr{X} is even and
sets \idr{Z} to \idr{1} otherwise. Use \idr{test_ceval} to test your program.

> -- FILL IN HERE

$\square$

== Relational vs. Step-Indexed Evaluation

As for arithmetic and boolean expressions, we'd hope that the two alternative
definitions of evaluation would actually amount to the same thing in the end.
This section shows that this is the case.

> ceval_step__ceval : (c : Com) -> (st, st' : State) -> (i ** ceval_step st c i = Just st') -> c / st \\ st'
> ceval_step__ceval c st st' (Z ** prf) = absurd prf
> ceval_step__ceval CSkip st st (S i ** Refl) = E_Skip
> ceval_step__ceval (CAss l a) st st' (S i ** prf) =
>  rewrite sym $ justInjective prf in
>  E_Ass {n=aeval st a} Refl
> ceval_step__ceval (CSeq c1 c2) st st' (S i ** prf) with (ceval_step st c1 i) proof c1prf
>   ceval_step__ceval (CSeq c1 c2) st st' (S i ** prf) | Just st1 =
>     E_Seq (ceval_step__ceval c1 st st1 (i**sym c1prf))
>           (ceval_step__ceval c2 st1 st' (i**prf))
>   ceval_step__ceval (CSeq c1 c2) st st' (S i ** prf) | Nothing = absurd prf
> ceval_step__ceval (CIf b c1 c2) st st' (S i ** prf) with (beval st b) proof bprf
>   ceval_step__ceval (CIf b c1 c2) st st' (S i ** prf) | True  =
>     E_IfTrue (sym bprf) (ceval_step__ceval c1 st st' (i**prf))
>   ceval_step__ceval (CIf b c1 c2) st st' (S i ** prf) | False =
>     E_IfFalse (sym bprf) (ceval_step__ceval c2 st st' (i**prf))
> ceval_step__ceval (CWhile b c) st st' (S i ** prf) with (beval st b) proof bprf
>   ceval_step__ceval (CWhile b c) st st' (S i ** prf) | True with (ceval_step st c i) proof cprf
>     ceval_step__ceval (CWhile b c) st st' (S i ** prf) | True | Just st1 =
>       E_WhileLoop (sym bprf) (ceval_step__ceval c st st1 (i**sym cprf))

\todo[inline]{Idris can't see sigma is decreasing, use WellFounded here?}

>                              (assert_total $ ceval_step__ceval (CWhile b c) st1 st' (i**prf))
>     ceval_step__ceval (CWhile b c) st st' (S i ** prf) | True | Nothing = absurd prf
>   ceval_step__ceval (CWhile b c) st st (S i ** Refl) | False = E_WhileEnd (sym bprf)

==== Exercise: 4 stars (ceval_step__ceval_inf)

Write an informal proof of \idr{ceval_step__ceval}, following the usual
template. (The template for case analysis on an inductively defined value should
look the same as for induction, except that there is no induction hypothesis.)
Make your proof communicate the main ideas to a human reader; do not simply
transcribe the steps of the formal proof.

> -- FILL IN HERE

$\square$

> ceval_step_more : (i1, i2 : Nat) -> (st, st' : State) -> (c : Com) -> LTE i1 i2 -> ceval_step st c i1 = Just st'
>                -> ceval_step st c i2 = Just st'
> ceval_step_more Z i2 st st' c lte prf = absurd prf
> ceval_step_more (S i1) Z st st' c lte prf = absurd lte
> ceval_step_more (S i1) (S i2) st st' CSkip lte prf = prf
> ceval_step_more (S i1) (S i2) st st' (CAss l a) lte prf = prf
> ceval_step_more (S i1) (S i2) st st' (CSeq c1 c2) lte prf with (ceval_step st c1 i1) proof cprf
>   ceval_step_more (S i1) (S i2) st st' (CSeq c1 c2) lte prf | Just st1 =
>     rewrite ceval_step_more i1 i2 st st1 c1 (fromLteSucc lte) (sym cprf) in
>     ceval_step_more i1 i2 st1 st' c2 (fromLteSucc lte) prf
>   ceval_step_more (S i1) (S i2) st st' (CSeq c1 c2) lte prf | Nothing = absurd prf
> ceval_step_more (S i1) (S i2) st st' (CIf b c1 c2) lte prf with (beval st b) proof bprf
>   ceval_step_more (S i1) (S i2) st st' (CIf b c1 c2) lte prf | True =
>     ceval_step_more i1 i2 st st' c1 (fromLteSucc lte) prf
>   ceval_step_more (S i1) (S i2) st st' (CIf b c1 c2) lte prf | False =
>     ceval_step_more i1 i2 st st' c2 (fromLteSucc lte) prf
> ceval_step_more (S i1) (S i2) st st' (CWhile b c) lte prf with (beval st b)
>   ceval_step_more (S i1) (S i2) st st' (CWhile b c) lte prf | True with (ceval_step st c i1) proof cprf
>     ceval_step_more (S i1) (S i2) st st' (CWhile b c) lte prf | True | Just st1 =
>       rewrite ceval_step_more i1 i2 st st1 c (fromLteSucc lte) (sym cprf) in
>       ceval_step_more i1 i2 st1 st' (CWhile b c) (fromLteSucc lte) prf
>     ceval_step_more (S i1) (S i2) st st' (CWhile b c) lte prf | True | Nothing = absurd prf
>   ceval_step_more (S i1) (S i2) st st' (CWhile b c) lte prf | False = prf

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

Finish the following proof. You'll need \idr{ceval_step_more} in a few places,
as well as some basic facts about \idr{LTE} and \idr{S}.

> ceval__ceval_step : (c : Com) -> (st, st' : State) -> (c / st \\ st') -> (i ** ceval_step st c i = Just st')
> ceval__ceval_step c st st' prf = ?ceval__ceval_step_rhs

$\square$

> ceval_and_ceval_step_coincide : (c : Com) -> (st, st' : State) -> (c / st \\ st') <-> (i ** ceval_step st c i = Just st')
> ceval_and_ceval_step_coincide c st st' = (ceval__ceval_step c st st', ceval_step__ceval c st st')

== Determinism of Evaluation Again

Using the fact that the relational and step-indexed definition of evaluation are
the same, we can give a slicker proof that the evaluation _relation_ is
deterministic.

> ceval_deterministic' : (c : Com) -> (st, st1, st2 : State) -> (c / st \\ st1) -> (c / st \\ st2) -> st1 = st2
> ceval_deterministic' c st st1 st2 prf1 prf2 =
>   let
>     (i1**e1) = ceval__ceval_step c st st1 prf1
>     (i2**e2) = ceval__ceval_step c st st2 prf2
>     plus1 = ceval_step_more i1 (i1+i2) st st1 c (lteAddRight i1) e1
>     plus2 = ceval_step_more i2 (i1+i2) st st2 c (rewrite plusCommutative i1 i2 in lteAddRight i2) e2
>     in
>   justInjective $ trans (sym plus1) plus2


module Dijkstra

-- Based on https://www.fstar-lang.org/papers/dm4free/slides.pdf

data Unit : Type -> Type where
  U : Unit a

STwp : Type -> Type -> Type
STwp s a = s -> (a -> s -> Type) -> Type

ST : (s : Type) -> (a : Type) -> STwp s a -> Type
ST s a p  = (st : s) -> (k : (a -> s -> Type)) -> Unit (p st k) -> Type

returnwp : a -> STwp s a
returnwp v st k = k v st

getwp : () -> STwp s s
getwp () st k = k st st

setwp : s -> STwp s ()
setwp st _ k = k () st

bindwp : STwp s a -> (a -> STwp s b) -> STwp s b
bindwp wp f st k = wp st (\b, st' => f b st' k)

return : (v : a) -> ST s a (returnwp v)
return v st k _ = returnwp v st k

get : ST s s (getwp ())
get st k _ = (getwp ()) st k

set : (st : s) -> ST s () (setwp st)
set st st' k _ = (setwp st) st' k

(>>=) : {wa : STwp s a} -> {wb : a -> STwp s b} ->
        ST s a wa -> ((x : a) -> ST s b (wb x)) -> ST s b (bindwp wa wb)
(>>=) m f st k _ = m st (\v, st' => f v st' k U) U

incr : ST Nat () (\s, post => post () (S s))
incr = do x <- get
          set (S x)

test : incr 0 (\x, s => 1 = s) U
test = Refl


module Main

import Common.Abbrev
import Common.Util
import Common.Interfaces
import Specifications.Semigroup
import Specifications.Monoid
import Specifications.Group
import Specifications.Order
import Specifications.Ring
import Specifications.TranslationInvariance
import Specifications.OrderedGroup
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Symmetry.Opposite
import Symmetry.Abelian
import Proofs.OrderTheory
import Proofs.SemigroupTheory
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory
import Proofs.GroupCancelMisc
import Proofs.TranslationInvarianceTheory
import Proofs.DiscreteOrderTheory
import Proofs.Interval
import Proofs.RingTheory
import Instances.Notation
import Instances.TrustInteger
import Instances.OrderZZ
import Instances.ZZ
import Applications.Example

%default total

testAbsoluteValue : Integer -> Integer
testAbsoluteValue x = fst $
  absoluteValue (orderedGroup integerDiscreteOrderedGroup) x

testAbsoluteValueZZ : ZZ -> ZZ
testAbsoluteValueZZ x = fst $ absoluteValue zzOrderedGroup x

main : IO ()
main = do printLn $ map testAbsoluteValue [(-5)..5]
          printLn $ map testAbsoluteValueZZ (map fromInteger [(-10)..10])


import Data.Vect

myZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
myZipWith f [] [] = []
myZipWith f (x :: xs) (y :: ys) = f x y :: myZipWith f xs ys

-- ctrl alt a on zipWith
-- ctrl alt c on first Vect argument
-- ctrl alt c on second Vect argument
-- ctrl alt s on first hole
-- ctrl alt c on second Vect argument in second pattern
-- ctrl alt s on last hole
-- DONE

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

-- type: write or extract a top-level function signature
-- define: doing stuff on the left
-- refine: doing stuff on the right

myTake : (m : Nat) -> Vect (m + n) a -> Vect m a
myTake Z xs = []
myTake (S k) (x :: xs) = x :: (myTake k xs) -- findet Idris nicht automatisch

myDrop : (m : Nat) -> Vect (m + n) a -> Vect n a
myDrop Z xs = xs
myDrop (S k) (x :: xs) = ?hole_2

myReplicate : (n : Nat) -> a -> Vect n a
myReplicate Z x = []
myReplicate (S k) x = x :: myReplicate k x -- wird automatisch gefunden


module NonDet

-- Non-determinism, based on http://okmij.org/ftp/tagless-final/nondet-paper.pdf

import Control.Monad.Identity

interface NDet (rep : Type -> Type) (val : Type -> Type) | rep where
  nil : rep a
  cons : val a -> rep a -> rep a
  list : List a -> rep a
  decon : rep a -> (() -> rep a) -> (val a -> rep a -> rep a) -> rep a
  foldr : (val a -> rep a -> rep a) -> rep a -> rep a -> rep a
  fail : rep a
  (||) : rep a -> rep a -> rep a

data Lists : Type -> Type where
  In : List (List a) -> Lists a

NDet Lists Identity where
  nil = In [[]]
  cons (Id y) (In xss) = In $ map (\xs => y :: xs) xss
  list xs = In [xs]
  decon (In xss) onnil oncons = In $ xss >>= (\xs => case xs of
                                                      [] => let (In yss) = onnil () in yss
                                                      h :: t => let (In yss) = oncons (Id h) (In [t]) in yss)

  foldr f seed (In xss) = In $ xss >>= (\xs => let (In yss) = foldr (\x, acc => f (Id x) acc) seed xs in yss)

  fail = In []
  (||) (In xs) (In ys) = In (xs ++ ys)

insert : NDet rep val => val a -> rep a -> rep a
insert x l = cons x l || decon l (\() => fail) (\h, t => cons h (insert x t))

perm : NDet rep val => List a -> rep a
perm xs = foldr (\x, xs => insert x xs) nil (list xs)

test : Lists Int
test = perm [1, 2, 3]


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Abs num, Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
    negate x = 0 - x
    (-) = Sub

Abs ty => Abs (Expr ty) where
    abs = Abs


||| Implements verified regular expressions.
|||
||| Implementation is based on https://www.ccs.neu.edu/home/turon/re-deriv.pdf
module RegExp

import Data.List
import Decidable.Equality

import RegExp.Equivalences
import public RegExp.Types

||| Given a regular expression `r` and a string `xs`, determines whether `r` _matches_ `[]` (i.e.
||| whether empty is in the language of `r`).
matchEmpty : (r : RegExp a) -> Dec (Matches r [])
matchEmpty Null = No absurd
matchEmpty Empty = Yes InEmpty
matchEmpty (Lit x) = No absurd
matchEmpty (Cat r s) = case (matchEmpty r, matchEmpty s) of
                            (Yes pr, Yes ps) => Yes $ InCat Refl pr ps
                            (No contra, _)   => No  $ contra . fst . catNotEmpty
                            (_, No contra)   => No  $ contra . snd . catNotEmpty
matchEmpty (Disj r s) = case (matchEmpty r, matchEmpty s) of
                             (Yes p, _)               => Yes $ InDisjL p
                             (_, Yes p)               => Yes $ InDisjR p
                             (No contraR, No contraS) => No  $ absurd . either contraR contraS . disjNotEmpty
matchEmpty (Conj r s) = case (matchEmpty r, matchEmpty s) of
                             (Yes pr, Yes ps) => Yes $ InConj pr ps
                             (No contra, _)   => No  $ contra . fst . conjNotEmpty
                             (_, No contra)   => No  $ contra . snd . conjNotEmpty
matchEmpty (Star r) = Yes InStarZ

||| Computes the derivative of a regular expression `r` with respect to a symbol `x`.
derive : (DecEq a) => (r : RegExp a) -> (x : a) -> RegExp a
derive Null _ = Null
derive Empty _ = Null
derive (Lit y) x with (decEq y x)
  derive (Lit x) x | (Yes Refl) = Empty
  derive (Lit y) x | (No _)     = Null
derive (Cat r s) x with (matchEmpty r)
  derive (Cat r s) x | (Yes _) = normDisj (normCat (derive r x) s) (derive s x)
  derive (Cat r s) x | (No _) = normCat (derive r x) s
derive (Disj r s) x = normDisj (derive r x) (derive s x)
derive (Conj r s) x = normConj (derive r x) (derive s x)
derive (Star r) x = normCat (derive r x) (Star r)

||| Proof that the derivation-based match algorithm is sound
derive_isSound : DecEq a =>
                 {r : RegExp a} ->
                 {x : a} ->
                 {xs : List a} ->
                 Matches (derive r x) xs ->
                 Matches r (x::xs)
derive_isSound {r=Null}  _ impossible
derive_isSound {r=Empty} _ impossible
derive_isSound {r=(Lit y)} {x} p with (decEq y x)
  derive_isSound {r=(Lit x)} {x} p | (Yes Refl) = rewrite emptyMatch_implies_emptyList p in InLit
  derive_isSound {r=(Lit y)} {x} p | (No _)     = absurd p
derive_isSound {r=(Cat r s)} {x} p with (matchEmpty r)
  derive_isSound {r=(Cat r s)} {x} p | (Yes pEmpty) with (normDisj_isSound p)
    derive_isSound {r=(Cat r s)} {x} p | (Yes pEmpty) | (InDisjL t) with (normCat_isSound t)
      derive_isSound {r=(Cat r s)} {x} p | (Yes pEmpty) | (InDisjL t) | (InCat pCat u v) = rewrite pCat in InCat Refl (derive_isSound u) v
    derive_isSound {r=(Cat r s)} {x} p | (Yes pEmpty) | (InDisjR t) = InCat Refl pEmpty (derive_isSound t)
  derive_isSound {r=(Cat r s)} {x} p | (No contra) with (normCat_isSound p)
    derive_isSound {r=(Cat r s)} {x} p | (No contra) | (InCat prf t u) = InCat (cong (x::) prf) (derive_isSound t) u
derive_isSound {r=(Disj r s)}  p with (normDisj_isSound p)
  derive_isSound {r=(Disj r s)} p | (InDisjL pr) = InDisjL $ derive_isSound pr
  derive_isSound {r=(Disj r s)} p | (InDisjR ps) = InDisjR $ derive_isSound ps
derive_isSound {r=(Conj r s)} p with (normConj_isSound p)
  derive_isSound {r=(Conj r s)} p | (InConj pr ps) = InConj (derive_isSound pr) (derive_isSound ps)
derive_isSound {r=(Star r)} p with (normCat_isSound {s=(Star r)} p)
  derive_isSound {r=(Star r)} p | (InCat prf pr prs) = rewrite prf in InStarS (cong (x::) prf) (derive_isSound pr) prs

mutual
  ||| Proof that the derivation-based match algorithm is complete for `Star`
  deriveStar_isComplete : DecEq a =>
                          {r: RegExp a} ->
                          {xs' : List a} ->
                          (x : a) ->
                          (xs : List a) ->
                          xs = x :: xs' ->
                          Matches (Star r) xs ->
                          Matches (normCat (derive r x) (Star r)) xs'
  deriveStar_isComplete _ [] p _ = absurd p
  deriveStar_isComplete {xs'} x _ p (InStarS {xs=[]} {ys} Refl pr ps) =
    deriveStar_isComplete x ys p ps
  deriveStar_isComplete x _ p (InStarS {xs=y::ys} pCat pr ps) =
    let (Refl, Refl) = consInjective p in
        normCat_isComplete $ InCat Refl (derive_isComplete pr) ps

  ||| Proof that the derivation-based match algorithm is complete
  derive_isComplete : DecEq a =>
                      {r : RegExp a} ->
                      {x : a} ->
                      {xs : List a} ->
                      Matches r (x::xs) ->
                      Matches (derive r x) xs
  derive_isComplete {r=Null}       p               = absurd p
  derive_isComplete {r=Empty}      p               = absurd p
  derive_isComplete {r=(Lit y)}    p with (decEq y x)
    derive_isComplete {r=(Lit x)} p | (Yes Refl)  = rewrite litMatchesCons_implies_restEmpty p in InEmpty
    derive_isComplete {r=(Lit y)} p | (No contra) = absurd $ contra $ litMatches_implies_headEqual p
  derive_isComplete {r=(Cat r s)} {x} {xs} p with (matchEmpty r)
    derive_isComplete {r=(Cat r s)} {x} {xs}         (InCat {xs=[]}    {ys=x::xs} Refl pr ps) | (Yes pEmpty) =
      normDisj_isComplete $ InDisjR $ derive_isComplete ps
    derive_isComplete {r=(Cat r s)} {x} {xs=xs++ys'} (InCat {xs=x::xs} {ys=ys'}   Refl pr ps) | (Yes pEmpty) =
      normDisj_isComplete $ InDisjL $ normCat_isComplete $ InCat Refl (derive_isComplete pr) ps
    derive_isComplete {r=(Cat r s)} {x} {xs}         (InCat {xs=[]}    {ys=x::xs} Refl pr ps) | (No contra)  =
      normCat_isComplete $ absurd $ contra pr
    derive_isComplete {r=(Cat r s)} {x} {xs=xs++ys'} (InCat {xs=x::xs} {ys=ys'}   Refl pr ps) | (No contra)  =
      normCat_isComplete $ InCat Refl (derive_isComplete pr) ps
  derive_isComplete {r=(Disj r s)} (InDisjL p) =
    normDisj_isComplete $ InDisjL $ derive_isComplete p
  derive_isComplete {r=(Disj r s)} (InDisjR p) =
    normDisj_isComplete $ InDisjR $ derive_isComplete p
  derive_isComplete {r=(Conj r s)} (InConj pr ps) =
    normConj_isComplete $ InConj (derive_isComplete pr) (derive_isComplete ps)
  derive_isComplete {r=(Star r)} {x} {xs} p = deriveStar_isComplete x (x::xs) Refl p

||| Given a regular expression `r` and a string `xs`, determines whether `r` _matches_ `u` (i.e.
||| whether `xs` is in the language of `r`).
export
matches : DecEq a => (r : RegExp a) -> (xs : List a) -> Dec (Matches r xs)
matches r [] = matchEmpty r
matches r (x::xs) =
  case matches (derive r x) xs of
    Yes prf => Yes $ derive_isSound prf
    No contra => No $ contra . derive_isComplete


module Decidable.Decidable.Extra

import Data.Rel
import Data.Rel.Complement
import Data.Fun
import Data.Vect
import Data.HVect
import Data.Fun.Extra
import Decidable.Decidable

%default total

public export
NotNot : {n : Nat} -> {ts : Vect n Type} -> (r : Rel ts) -> Rel ts
NotNot r = map @{Nary} (Not . Not) r

[DecidablePartialApplication] {x : t} -> (tts : Decidable (S n) (t :: ts) r) => Decidable n ts (r x) where
  decide = decide @{tts} x

public export
doubleNegationElimination : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable n ts r =>
  (witness : HVect ts) ->
  uncurry (NotNot {ts} r) witness ->
  uncurry              r  witness
doubleNegationElimination {ts = []} @{dec} [] prfnn =
  case decide @{dec} of
    Yes prf  => prf
    No  prfn => absurd $ prfnn prfn
doubleNegationElimination {ts = t :: ts} @{dec} (w :: witness) prfnn =
  doubleNegationElimination {ts} {r = r w} @{ DecidablePartialApplication @{dec} } witness prfnn

doubleNegationForall : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable n ts r =>
  All ts (NotNot {ts} r) -> All ts r
doubleNegationForall @{dec} forall_prf =
  let prfnn : (witness : HVect ts) -> uncurry (NotNot {ts} r) witness
      prfnn = uncurryAll forall_prf
      prf   : (witness : HVect ts) -> uncurry              r  witness
      prf witness = doubleNegationElimination @{dec} witness (prfnn witness)
  in curryAll prf

public export
doubleNegationExists : {n : Nat} -> {0 ts : Vect n Type} -> {r : Rel ts} -> Decidable n ts r =>
  Ex ts (NotNot {ts} r) ->
  Ex ts r
doubleNegationExists @{dec} nnxs =
  let witness : HVect ts
      witness = extractWitness nnxs
      witnessingnn : uncurry (NotNot {ts} r) witness
      witnessingnn = extractWitnessCorrect nnxs
      witnessing   : uncurry              r  witness
      witnessing   = doubleNegationElimination @{dec} witness witnessingnn
  in introduceWitness witness witnessing

decideTransform :
  {n : Nat}
  -> {ts : Vect n Type}
  -> {r : Rel ts}
  -> {t : Type -> Type}
  -> (tDec : {a : Type} -> Dec a -> Dec (t a))
  -> (posDec : IsDecidable n ts r)
  -> IsDecidable n ts (chain {ts} t r)
decideTransform tDec posDec =
  curryAll $ \xs =>
    replace {p = id} (chainUncurry (chain t r) Dec xs) $
      replace {p = Dec} (chainUncurry r t xs) $
        tDec $ replace {p = id} (sym $ chainUncurry r Dec xs) $
          uncurryAll posDec xs

||| Convert a decision about a decidable property into one about its negation.
public export
negateDec : (dec : Dec a) -> Dec (Not a)
negateDec (Yes pf) = No ($ pf)
negateDec (No npf) = Yes npf

||| We can turn (Not (Exists Not)) into Forall for decidable types
public export
notExistsNotForall :
  {0 p : a -> Type}
  -> ((x : a) -> Dec (p x))
  -> Dec (x : a ** Not (p x))
  -> Dec ((x : a) -> p x)
notExistsNotForall dec decEx =
  case decEx of
    Yes (x ** nx) => No $ \f => nx $ f x
    No notNot => Yes $ \x => case (dec x) of
      Yes px => px
      No nx => void $ notNot $ (x ** nx)

||| If a relation is decidable, then so is its complement
public export
[DecidableComplement] {n : Nat} -> {ts : Vect n Type} -> {r : Rel ts} -> (posDec : Decidable n ts r) =>
  Decidable n ts (complement {ts} r) where
    decide = decideTransform negateDec (decide @{posDec})


module Naperian

-- Naperian Functors, based on https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/aplicative.pdf

import Data.Vect
import Data.Fin

interface Functor f => Naperian (f : Type -> Type) where
  Log : {f : Type} -> Type
  lookup' : f a -> (Log -> a)
  positions : f Log
  tabulate : (Log -> a) -> f a

  positions = tabulate id

Naperian (Vect n) where
  Log {n} = Fin n

  lookup' [] FZ impossible
  lookup' [] (FS _) impossible
  lookup' (x :: xs) FZ = x
  lookup' (x :: xs) (FS y) = lookup' xs y

  tabulate h = map h positions
    where
      positions = positions' (replicate _ ())
        where
          positions' : Vect n () -> Vect n (Fin n)
          positions' [] = []
          positions' (() :: xs) = FZ :: map FS (positions' xs)

transpose' : (Naperian f, Naperian g) => f (g a) -> g (f a)
transpose' source = (map tabulate . tabulate . flip . lookup' . map lookup') source

example : Vect 2 (Vect 3 Integer)
example = [[1, 2, 3], [4, 5, 6]]

transposedExample : Vect 3 (Vect 2 Integer)
transposedExample = transpose' example


||| Ugly code for calculating and rendering a dragon curve
||| in SVG. TODO: Cleanup, document.
module Examples.Fractals.Dragon

import Data.DPair
import Data.List
import Data.List.TR
import Data.String

record Point where
  constructor P
  x,y : Int32

Num Point where
  fromInteger n = P (fromInteger n) 0
  P x1 y1 + P x2 y2 = P (x1 + x2) (y1 + y2)
  P x1 y1 * P x2 y2 = P (x1 * x2 - y1 * y2) (x1 * y2 + x2 * y1)

Neg Point where
  negate (P x y) = P (-x) (-y)
  P x1 y1 - P x2 y2 = P (x1 - x2) (y1 - y2)

rotate90 : Point -> Point
rotate90 (P x y) = P y (-x)

rotateAround90 : (origin : Point) -> Point -> Point
rotateAround90 o p = rotate90 (p - o) + o

Dragon : Type
Dragon = Subset (List Point) NonEmpty

0 lemma :  (as : List a)
        -> (v : a)
        -> (as2 : List a)
        -> NonEmpty (as ++ v :: as2)
lemma []       v as2 = IsNonEmpty
lemma (h :: t) v as2 = IsNonEmpty

firstDragon : Dragon
firstDragon = Element [0,800] IsNonEmpty

nextDragon : Dragon -> Dragon
nextDragon (Element (h :: t) prf) =
  let new = mapTR (rotateAround90 h) (reverse t)
   in Element (new ++ h :: t) (lemma new h t)

dragonSVG : (n : Nat) -> Dragon -> String
dragonSVG n (Element ps _) =
  let fact = pow 2 (cast (n + 2) / 2.0)
      scale = 1.0 / fact

      attr = fastConcat $ mapTR (\(P x y) => #"\#{show x}, \#{show y} "#) ps
      header =
        the String #"""
                   <svg version="1.1"
                        width="100%"
                        viewBox="0 0 1000 1000"
                        xmlns="http://www.w3.org/2000/svg">
                   """#
   in #"""
      \#{header}
        <polyline points="\#{attr}"
                  fill="none"
                  stroke="red"
                  vector-effect="non-scaling-stroke"
                  transform="translate (500,500) scale(\#{show scale})"
                  stroke-width="1"/>
      </svg>
      """#

export
mkDragons : (n : Nat) -> Subset (List String) NonEmpty
mkDragons n =
  let fd   = firstDragon
   in Element (dragonSVG 0 fd :: go fd n 1) IsNonEmpty
  where go : Dragon -> (rem : Nat) -> (iter : Nat) -> List String
        go _  0     _ = Nil
        go dr (S k) n =
          let nextDr = nextDragon dr
           in dragonSVG n nextDr :: go nextDr k (n+1)


module SMTLib

import Data.Vect

%access public export

data NumTyp = IntT | RealT

data TypeT : Type where
  BoolT : TypeT
  NumT : NumTyp -> TypeT
  BitVecT : Nat -> TypeT

Show TypeT where
  show BoolT = "Bool"
  show (NumT IntT) = "Int"
  show (NumT RealT) = "Real"
  show (BitVecT n) = "BitVec " ++ show n

data Expr : TypeT -> Type where
  VarExpr : String -> (t : TypeT) -> Expr t
  BoolExpr : Bool -> Expr BoolT
  BvExpr : Int -> (n : Nat) -> Expr (BitVecT n)
  BvAddExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvMulExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvAndExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvOrExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvNotExpr : Expr (BitVecT n) -> Expr (BitVecT n)
  IntExpr : Int -> Expr (NumT IntT)
  RealExpr : Double -> Expr (NumT RealT)
  AddExpr : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
  MulExpr : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
  EqualExpr : Expr a -> Expr a -> Expr BoolT
  DistinctExpr : Vect n (Expr a) -> Expr BoolT
  LessOrEqualExpr : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
  AndExpr : Vect n (Expr BoolT) -> Expr BoolT
  OrExpr : Vect n (Expr BoolT) -> Expr BoolT
  NotExpr : Expr BoolT -> Expr BoolT
  IteExpr : Expr BoolT -> Expr a -> Expr a -> Expr a

bool : Bool -> Expr BoolT
bool x = BoolExpr x

bv : Int -> (n : Nat) -> Expr (BitVecT n)
bv x n = BvExpr x n

int : Int -> Expr (NumT IntT)
int x = IntExpr x

real : Double -> Expr (NumT RealT)
real x = RealExpr x

bvadd : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvadd l r = BvAddExpr l r

bvmul : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvmul l r = BvMulExpr l r

bvand : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvand l r = BvAndExpr l r

bvor : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvor l r = BvOrExpr l r

bvnot : Expr (BitVecT n) -> Expr (BitVecT n)
bvnot x = BvNotExpr x

(+) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
(+) l r = AddExpr l r

(*) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
(*) l r = MulExpr l r

(==) : Expr a -> Expr a -> Expr BoolT
(==) l r = EqualExpr l r

distinct : Vect n (Expr a) -> Expr BoolT
distinct xs = DistinctExpr xs

(<=) : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
(<=) l r = LessOrEqualExpr l r

(&&) : Expr BoolT -> Expr BoolT -> Expr BoolT
(&&) l r = AndExpr [l, r]

(||) : Expr BoolT -> Expr BoolT -> Expr BoolT
(||) l r = OrExpr [l, r]

and : Vect n (Expr BoolT) -> Expr BoolT
and xs = AndExpr xs

or : Vect n (Expr BoolT) -> Expr BoolT
or xs = OrExpr xs

not : Expr BoolT -> Expr BoolT
not x = NotExpr x

ite : Expr BoolT -> Expr a -> Expr a -> Expr a
ite p l r = IteExpr p l r

data Cmd : Type -> Type where
  DeclareVarCmd : String -> (t : TypeT) -> Cmd (Expr t)
  DeclareVarsCmd : Traversable f => f String -> (t : TypeT) -> Cmd (f (Expr t))
  AssertCmd : Expr BoolT -> Cmd ()
  CheckSatCmd : Cmd ()
  GetModelCmd : Cmd ()

declareVar : String -> (t : TypeT) -> Cmd (Expr t)
declareVar v t = DeclareVarCmd v t

declareVars : Traversable f => f String -> (t : TypeT) -> Cmd (f (Expr t))
declareVars vs t = DeclareVarsCmd vs t

assert : Expr BoolT -> Cmd ()
assert e = AssertCmd e

checkSat : Cmd ()
checkSat = CheckSatCmd

getModel : Cmd ()
getModel = GetModelCmd

data Smt : Type -> Type where
  Pure : a -> Smt a
  Bind : Cmd a -> (a -> Smt b) -> Smt b

pure : a -> Smt a
pure x = Pure x

(>>=) : Cmd a -> (a -> Smt b) -> Smt b
(>>=) cmd f = Bind cmd f

end : Smt ()
end = Pure ()

compileExpr : Expr t -> String
compileExpr (VarExpr x t) = x
compileExpr (BoolExpr x) = if x then "true" else "false"
compileExpr (BvExpr x n) = "(_ bv" ++ show x ++ " " ++ show n ++ ")"
compileExpr (IntExpr x) = show x
compileExpr (RealExpr x) = show x
compileExpr (BvAddExpr l r) = "(bvadd " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvMulExpr l r) = "(bvmul " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvAndExpr l r) = "(bvand " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvOrExpr l r) = "(bvor " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvNotExpr x) = "(bnot " ++ compileExpr x ++ ")"
compileExpr (AddExpr l r) = "(+ " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (MulExpr l r) = "(* " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (EqualExpr l r) = "(= " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (DistinctExpr xs) = "(distinct " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (LessOrEqualExpr l r) = "(<= " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (AndExpr xs) = "(and " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (OrExpr xs) = "(or " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (NotExpr x) = "(not " ++ compileExpr x ++ ")"
compileExpr (IteExpr p l r) = "(if " ++ compileExpr p ++ " " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"

compileCmd : Cmd a -> (a, String)
compileCmd (DeclareVarCmd x t) = (VarExpr x t, "(declare-const " ++ x ++ " " ++ show t ++ ")")
compileCmd (DeclareVarsCmd xs t) = (map (\x => VarExpr x t) xs,
                                    (unlines . toList . map (\x => "(declare-const " ++ x ++ " " ++ show t ++ ")")) xs)
compileCmd (AssertCmd e) = ((), "(assert " ++ compileExpr e ++ ")")
compileCmd CheckSatCmd = ((), "(check-sat)")
compileCmd GetModelCmd = ((), "(get-model)")

compile : Smt () -> String
compile (Pure ()) = ""
compile (Bind cmd f) = let (a, s) = compileCmd cmd in
                       let s' = compile $ f a in
                       unlines [s, s']

example0 : Expr BoolT
example0 = (bool True) && (bool True)

example1 : Expr BoolT
example1 = (bv 1 8) == (bv 1 8)

example2 : Cmd ()
example2 = checkSat

example3 : Smt ()
example3 = do x <- declareVar "x" BoolT
              y <- declareVar "y" BoolT
              assert $ x && y
              checkSat
              getModel
              end

example4 : Smt ()
example4 = do [x, y] <- declareVars {f = Vect 2} ["x", "y"] BoolT
              assert $ not (x && y) == (not x || not y)
              checkSat
              getModel
              end

print : Smt () -> IO ()
print smt = putStrLn $ compile smt