module Himp

import Assn
import Expr
import Logic
import Maps

%access public export

%default total

data HCom : Type where
  HCSkip : HCom
  HCAss : (x : Id) -> (a : AExp) -> HCom
  HCSeq : (c1 : HCom) -> (c2 : HCom) -> HCom
  HCIf : (b : BExp) -> (ct : HCom) -> (cf : HCom) -> HCom
  HCWhile : (b : BExp) -> (c : HCom) -> HCom
  HCHavoc : (x : Id) -> HCom

SKIP : HCom
SKIP = HCSkip

infix 5 ::=

(::=) : Id -> AExp -> HCom
(::=) = HCAss

(>>=) : HCom -> (() -> HCom) -> HCom
(>>=) c f = HCSeq c (f ())

WHILE : BExp -> HCom -> HCom
WHILE = HCWhile

syntax IFB [b] THEN [ct] ELSE [cf] FI = HCIf b ct cf

HAVOC : Id -> HCom
HAVOC = HCHavoc

data HCEval : HCom -> State -> State -> Type where
  E_Skip : HCEval HCSkip st st
  E_Ass : aeval st a1 = n -> HCEval (HCAss x a1) st (t_update x n st)
  E_Seq : HCEval c1 st1 st2 -> HCEval c2 st2 st3 ->
          HCEval (HCSeq c1 c2) st1 st3
  E_IfTrue : beval st b = True -> HCEval c1 st st1 ->
             HCEval (HCIf b c1 c2) st st1
  E_IfFalse : beval st b = False -> HCEval c2 st st1 ->
              HCEval (HCIf b c1 c2) st st1
  E_WhileEnd : beval st b = False -> HCEval (HCWhile b c) st st
  E_WhileLoop : beval st b = True ->
                HCEval c st st1 -> HCEval (HCWhile b c) st1 st2 ->
                HCEval (HCWhile b c) st st2
  E_Havoc : (n : Nat) -> HCEval (HCHavoc x) st (t_update x n st)

syntax [c1] "/" [st1] "\\\\" [st2] = HCEval c1 st1 st2

havoc_example_1 : (HAVOC X) / Expr.empty_state \\ (t_update X 0 Expr.empty_state)
havoc_example_1 = E_Havoc 0

havoc_example_2 : (do SKIP; HAVOC Z)
                  / Expr.empty_state \\ (t_update Z 42 Expr.empty_state)
havoc_example_2 = E_Seq E_Skip (E_Havoc 42)

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

havoc_property : Not (x = y) -> st x = n -> ((HAVOC y) / st \\ st') -> st' x = n
havoc_property contra prf (E_Havoc _) =
  rewrite snd beq_id_false_iff $ neqSym contra
  in prf

pXY : HCom
pXY = do HAVOC X
         HAVOC Y

pYX : HCom
pYX = do HAVOC Y
         HAVOC X

x_neq_y : Not (Expr.X = Expr.Y)
x_neq_y Refl impossible

pXY_equiv_pYX : Either (HCEquiv Himp.pXY Himp.pYX)
                       (Not (HCEquiv Himp.pXY Himp.pYX))
pXY_equiv_pYX = Left $ \st, st' =>
  (forward st st', backward st st')
where forward : (st, st' : State) ->
                (Himp.pXY / st \\ st') -> (Himp.pYX / st \\ st')
      forward st _ (E_Seq (E_Havoc n) (E_Havoc m)) =
        rewrite t_update_permute {x1=Y} {v1=m} {x2=X} {v2=n} {m=st}
                                 x_neq_y
        in E_Seq (E_Havoc m) (E_Havoc n)
      backward : (st, st' : State) ->
                 (Himp.pYX / st \\ st') -> (Himp.pXY / st \\ st')
      backward st _ (E_Seq (E_Havoc n) (E_Havoc m)) =
        rewrite t_update_permute {x1=X} {v1=m} {x2=Y} {v2=n} {m=st}
                                 (neqSym x_neq_y)
        in E_Seq (E_Havoc m) (E_Havoc n)

ptwice : HCom
ptwice = do HAVOC X
            HAVOC Y

pcopy : HCom
pcopy = do HAVOC X
           Y ::= X

ptwice_inequiv_pcopy : Either (HCEquiv Himp.ptwice Himp.pcopy)
                              (Not (HCEquiv Himp.ptwice Himp.pcopy))
ptwice_inequiv_pcopy = Right $ \equiv =>
  let st' = t_update Y 1 $ t_update X 0 empty_state
  in case fst (equiv empty_state st') (E_Seq (E_Havoc 0) (E_Havoc 1)) of
       E_Seq _ E_Skip impossible
       E_Seq _ (E_Ass _) impossible
       E_Seq _ (E_Seq _ _) impossible
       E_Seq _ (E_IfTrue _ _) impossible
       E_Seq _ (E_IfFalse _ _) impossible
       E_Seq _ (E_WhileEnd _) impossible
       E_Seq _ (E_WhileLoop _ _ _) impossible
       E_Seq _ (E_Havoc _) impossible

p1 : HCom
p1 = WHILE (not (X == 0)) $ do
       HAVOC Y
       X ::= X + 1

p2 : HCom
p2 = WHILE (not (X == 0)) $
       SKIP

p1_may_diverge : Not (st X = 0) -> Not (Himp.p1 / st \\ st')
p1_may_diverge {st'} contra (E_WhileEnd prf) with (st' X)
  p1_may_diverge {st'} contra (E_WhileEnd prf) | Z = contra Refl
  p1_may_diverge {st'} contra (E_WhileEnd prf) | S _ = absurd prf
p1_may_diverge contra (E_WhileLoop _ (E_Seq {st2} _ (E_Ass prf)) next) =
  let h_prf = sym $ trans (plusCommutative 1 (st2 X)) prf
  in p1_may_diverge {st=t_update X _ _}
                    (n_eq_succ__n_neq_0 {k=st2 X} h_prf) next

p2_may_diverge : Not (st X = 0) -> Not (Himp.p2 / st \\ st')
p2_may_diverge {st'} contra (E_WhileEnd prf) =
  let st_X_beq_0 = trans (sym (notInvolutive (st' X == 0)))
                         (cong {f=Bool.not} prf)
  in contra (fst (nat_beq_iff (st' X) 0) st_X_beq_0)
p2_may_diverge contra (E_WhileLoop _ E_Skip next) = p2_may_diverge contra next

p1_p2_equiv : HCEquiv Himp.p1 Himp.p2
p1_p2_equiv st st' = (forward, backward)
where forward : (Himp.p1 / st \\ st') -> (Himp.p2 / st \\ st')
      forward rel = case rel of
        E_WhileEnd prf => E_WhileEnd prf
        E_WhileLoop prf _ _ =>
          let st_X_neq_0 = fst (nat_nbeq_iff (st X) 0)
                               (trans (sym (notInvolutive (st X == 0)))
                                      (cong {f=Bool.not} prf))
          in absurd $ p1_may_diverge st_X_neq_0 rel
      backward : (Himp.p2 / st \\ st') -> (Himp.p1 / st \\ st')
      backward rel = case rel of
        E_WhileEnd prf => E_WhileEnd prf
        E_WhileLoop prf _ _ =>
          let st_X_neq_0 = fst (nat_nbeq_iff (st X) 0)
                               (trans (sym (notInvolutive (st X == 0)))
                                      (cong {f=Bool.not} prf))
          in absurd $ p2_may_diverge st_X_neq_0 rel

p3 : HCom
p3 = do Z ::= 1
        WHILE (not (X == 0)) $ do
          HAVOC X
          HAVOC Z

p4 : HCom
p4 = do X ::= 0
        Z ::= 1

p3_p4_inequiv : Not (HCEquiv Himp.p3 Himp.p4)
p3_p4_inequiv equiv =
  let st = t_update X 1 empty_state
      st' = t_update Z 2 $ t_update X 0 $ t_update Z 1 st
  in case fst (equiv st st')
              (E_Seq (E_Ass Refl)
                     (E_WhileLoop Refl
                                  (E_Seq (E_Havoc 0) (E_Havoc 2))
                                  (E_WhileEnd Refl))) of
       (E_Seq (E_Ass _) E_Skip) impossible
       (E_Seq (E_Ass _) (E_Ass _)) impossible
       (E_Seq (E_Ass _) (E_Seq _ _)) impossible
       (E_Seq (E_Ass _) (E_IfTrue _ _)) impossible
       (E_Seq (E_Ass _) (E_IfFalse _ _)) impossible
       (E_Seq (E_Ass _) (E_WhileEnd _)) impossible
       (E_Seq (E_Ass _) (E_WhileLoop _ _ _)) impossible
       (E_Seq (E_Ass _) (E_Havoc _)) impossible

p5 : HCom
p5 = WHILE (not (X == 1)) $
       HAVOC X

p6 : HCom
p6 = X ::= 1

overwriting_write : ((x ::= ANum n) / (t_update x v st) \\ st') ->
                    ((x ::= ANum n) / st \\ st')
overwriting_write {x} {n} {v} {st} (E_Ass prf) =
  rewrite sym prf
  in rewrite t_update_shadow {x=x} {v2=n} {v1=v} {m=st}
  in E_Ass {n=n} Refl

p5_p6_equiv : HCEquiv Himp.p5 Himp.p6
p5_p6_equiv st st' = (forward st st', backward st st')
where forward : (st, st' : State) ->
                (Himp.p5 / st \\ st') -> (Himp.p6 / st \\ st')
      forward st st' rel = case rel of
        E_WhileEnd prf =>
          let st_X_eq_1 = fst (nat_beq_iff (st X) 1)
                              (trans (sym (notInvolutive (st X == 1)))
                                     (cong {f=Bool.not} prf))
              st_prf = replace {P=\v => t_update X v st = st}
                               st_X_eq_1 (t_update_same {m=st} {x=X})
          in replace {P=\x => HCEval (HCAss X 1) st x}
                     st_prf (Himp.E_Ass Refl)
        E_WhileLoop {st1 = (t_update Expr.X n st)} _ (E_Havoc n) next =>
          overwriting_write $ forward (t_update X n st) st' next
      backward : (st, st' : State) ->
                 (Himp.p6 / st \\ st') -> (Himp.p5 / st \\ st')
      backward st st' rel with (st X) proof st_X_prf
        backward st st' rel | Z = case rel of
          E_Ass prf => let pf = cong {f=Bool.not . (==1)} $ sym st_X_prf
                       in rewrite sym prf
                       in E_WhileLoop pf (E_Havoc 1) (E_WhileEnd Refl)
        backward st st' rel | S Z = case rel of
          E_Ass prf => let pf = cong {f=Bool.not . (==1)} $ sym st_X_prf
                       in rewrite sym prf
                       in rewrite st_X_prf
                       in rewrite t_update_same {m=st} {x=X}
                       in rewrite sym st_X_prf
                       in E_WhileEnd pf
        backward st st' rel | S (S k) = case rel of
          E_Ass prf => let pf = cong {f=Bool.not . (== 1)} $ sym st_X_prf
                       in rewrite sym prf
                       in E_WhileLoop pf (E_Havoc 1) (E_WhileEnd Refl)

HoareTriple : (p : Assertion) -> (c : HCom) -> (q : Assertion) -> Type
HoareTriple p c q = (st, st' : State) -> (c / st \\ st') -> p st -> q st'

HavocPre : (x : Id) -> (q : Assertion) -> Assertion
HavocPre x q = \st => (n : Nat) -> q (t_update x n st)

hoare_havoc : (q : Assertion) -> (x : Id) ->
              HoareTriple (HavocPre x q) (HAVOC x) q
hoare_havoc q x st _ (E_Havoc n) p_st = p_st n

IsWP : (p : Assertion) -> (c : HCom) -> (q : Assertion) -> Type
IsWP p c q = ( HoareTriple p c q
             , (p' : Assertion) -> HoareTriple p' c q -> p' ->> p )

hoare_havoc_weakest : IsWP (HavocPre x q) (HAVOC x) q
hoare_havoc_weakest {x} {q} = (hoare_havoc q x, imp)
where imp : (p' : Assertion) -> HoareTriple p' (HAVOC x) q -> p' ->> HavocPre x q
      imp p' ht st p'_st n = ht st _ (E_Havoc n) p'_st


module Data.Tree

%default total
%access public export

||| A key-value tree data structure.
|||
||| This structure doesn't encode the invariants of the tree and is
||| *simply* a container. This structure ideally shouldn't be exposed
||| to the user at all. This structure should be used to build other
||| data structures.  See the modules alongside this for appropriate
||| interfaces for using the tree.
|||
||| @keyTy The type associated with the key.
||| @valTy The type associated with the value.
data Tree : (keyTy : Type)
         -> (valTy : Type)
         -> Type
  where
    ||| An empty Tree node.
    Empty : Tree k v

    ||| A Key Value node in the Tree.
    |||
    ||| @key   The key.
    ||| @val   The value associated with the key.
    ||| @left  The left child of the Node
    ||| @right THe right child of the Node.
    Node : (key   : k)
        -> (val   : v)
        -> (left  : Tree k v)
        -> (right : Tree k v)
        -> Tree k v

%name Tree t, tree

namespace Keys

  ||| A proof that some key is found in a Tree
  data IsKeyIn : k -> Tree k v -> Type where
    Here : IsKeyIn key (Node key _ _ _)
    InRight : (later : IsKeyIn key r) -> IsKeyIn key (Node not_key _ _ r)
    InLeft :  (later : IsKeyIn key l) -> IsKeyIn key (Node not_key _ l _)

  ||| An empty tree has no key
  emptyTreeHasNoKey : {key : k} -> IsKeyIn key Empty -> Void
  emptyTreeHasNoKey Here impossible
  emptyTreeHasNoKey (InRight _) impossible
  emptyTreeHasNoKey (InLeft _) impossible

  Uninhabited (IsKeyIn key Empty) where
    uninhabited = emptyTreeHasNoKey

  ||| An item that is not in the root, not in the left child and not in the
  ||| right child is not in the Tree at all
  noKeyFound : {key : k}
            -> {val : v}
            -> {key' : k}
            -> {l : Tree k v}
            -> {r : Tree k v}
            -> Not (key = key')
            -> Not (IsKeyIn key l)
            -> Not (IsKeyIn key r)
            -> Not (IsKeyIn key (Node key' val l r))
  noKeyFound notHere notInLeft notInRight Here = notHere Refl
  noKeyFound notHere notInLeft notInRight (InLeft later) = notInLeft later
  noKeyFound notHere notInLeft notInRight (InRight later) = notInRight later

  ||| A decision procedure for Key
  isKey : DecEq k
       => (key : k)
       -> (tree : Tree k v)
       -> Dec (IsKeyIn key tree)
  isKey key Empty = No emptyTreeHasNoKey
  isKey key (Node key' _ l r) with (decEq key key')
    isKey key (Node key  _ l r) | (Yes Refl) = Yes Here
    isKey key (Node key' _ l r) | (No notHere) with (isKey key l)
      isKey key (Node key' _ l r) | (No notHere) | (Yes inLeft) = Yes (InLeft inLeft)
      isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) with (isKey key r)
        isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) | (Yes inRight) = Yes (InRight inRight)
        isKey key (Node key' _ l r) | (No notHere) | (No notInLeft) | (No notInRight) = No (noKeyFound notHere notInLeft notInRight)

  public export
  data All : (predicate : typeKey -> Type)
          -> (tree      : Tree typeKey typeValue)
          -> Type
    where
      Leaf : All p Empty
      Node : (prf : p key)
          -> (leftBranch  : All p left)
          -> (rightBranch : All p right)
          -> All p (Node key _ left right)

namespace Values
  public export
  data IsValueIn : (value : typeValue)
                -> (tree  : Tree typeKey typeValue)
                -> Type
    where
      Here    : IsValueIn value (Node _ value _ _)
      InRight : (later : IsValueIn value r) -> IsValueIn value (Node _ not_value _ r)
      InLeft  : (later : IsValueIn value l) -> IsValueIn value (Node _ not_value l _)

  emptyTreeHasNoValue : IsValueIn value Empty -> Void
  emptyTreeHasNoValue Here impossible
  emptyTreeHasNoValue (InRight _) impossible
  emptyTreeHasNoValue (InLeft _) impossible

  Uninhabited (IsValueIn value Empty) where
    uninhabited Here impossible
    uninhabited (InRight _) impossible
    uninhabited (InLeft _) impossible

  ||| A decision procedure for Value
  valueNotFound : (notHere : (value = val) -> Void)
               -> (isNotLeft : IsValueIn value left -> Void)
               -> (isNotRight : IsValueIn value right -> Void)
               -> IsValueIn value (Node key val left right)
               -> Void
  valueNotFound notHere isNotLeft isNotRight Here = notHere Refl
  valueNotFound notHere isNotLeft isNotRight (InRight later) = isNotRight later
  valueNotFound notHere isNotLeft isNotRight (InLeft later) = isNotLeft later

  isValue : DecEq typeValue
         => (value : typeValue)
         -> (tree : Tree typeKey typeValue)
         -> Dec (IsValueIn value tree)
  isValue value Empty = No emptyTreeHasNoValue
  isValue value (Node key val left right) with (decEq value val)
    isValue val (Node key val left right) | (Yes Refl) = Yes Here
    isValue value (Node key val left right) | (No notHere) with (isValue value left)
      isValue value (Node key val left right) | (No notHere) | (Yes prf) = Yes (InLeft prf)
      isValue value (Node key val left right) | (No notHere) | (No isNotLeft) with (isValue value right)
              isValue value (Node key val left right) | (No notHere) | (No isNotLeft) | (Yes prf) = Yes (InRight prf)
              isValue value (Node key val left right) | (No notHere) | (No isNotLeft) | (No isNotRight) = No (valueNotFound notHere isNotLeft isNotRight)

  public export
  data All : (predicate : typeValue -> Type)
          -> (tree      : Tree typeKey typeValue)
          -> Type
    where
      Leaf : Values.All p Empty
      Node : (prf : p value)
          -> (leftBranch  : Values.All p left)
          -> (rightBranch : Values.All p right)
          -> Values.All p (Node _ value left right)

namespace KVPairs
  public export
  data All : (predicate : typeKey -> typeValue -> Type)
          -> (tree      : Tree typeKey typeValue)
          -> Type
    where
      Leaf : KVPairs.All p Empty
      Node : (prf : p key value)
          -> (leftBranch  : KVPairs.All p left)
          -> (rightBranch : KVPairs.All p right)
          -> KVPairs.All p (Node key value left right)


||| Vertical composition of morphisms
module VertComp

import Data.Vect
import VectHelp
import ProcessLib
import Util
import Proto

%default total

-- TODO: we aren't handling any errors here
||| Connect two process
makeConnection: (w: DTy) ->
                (loc: Elem w cut_b) ->
                ProcPID (MkNiche cut_a cut_b) ->
                ProcPID (MkNiche cut_b cut_c) ->
                Process (ProcIF (MkNiche cut_a cut_c)) () Ready Ready
makeConnection (Down a) loc pid_f pid_g = do r <- Request pid_f (Conn (BotOutWire loc) pid_g (TopInWire loc))
                                             Action $ putStrLn $ "CONN: Down: " ++ show r
makeConnection (Up a)   loc pid_f pid_g = do r <- Request pid_g (Conn (TopOutWire loc) pid_f (BotInWire loc))
                                             Action $ putStrLn $ "CONN: Up  : " ++ show r

||| Connect two process that have a common cut
makeConnections: (cut_b: Cut m1) ->
                 ProcPID (MkNiche cut_a cut_b) ->
                 ProcPID (MkNiche cut_b cut_c) ->
                 Process (ProcIF (MkNiche cut_a cut_c)) () Ready Ready
makeConnections cut_b pid_f pid_g = let locs = allElems cut_b
  in sequence (map (\(dt ** loc) => makeConnection dt loc pid_f pid_g) locs)

||| Handle incoming requests
||| Just reroutes the requests to the appropriate morphism
resp: ProcPID (MkNiche cut_a cut_b) ->
      ProcPID (MkNiche cut_b cut_c) ->
      (msg : Req (MkNiche cut_a cut_c)) ->
      Process (ProcIF (MkNiche cut_a cut_c))
              (ProcIF (MkNiche cut_a cut_c) msg)
              Ready
              Ready
resp pid_f pid_g con@(Conn (TopOutWire _) _ _) = Request pid_f con
resp pid_f pid_g con@(Conn (BotOutWire _) _ _) = Request pid_g con
resp pid_f pid_g val@(Val (TopInWire _) _)     = do r <- Request pid_f val
                                                    --Action $ putStrLn $ "vert: reroute top val: " ++ show r
                                                    Pure r
resp pid_f pid_g val@(Val (BotInWire _) _)     = do r <- Request pid_g val
                                                    --Action $ putStrLn $ "vert: reroute bot val: " ++ show r
                                                    Pure r

infixl 3 -*-

||| Vertical composition of morphisms in the category of processes
public export partial
(-*-): {l,m,n: Nat} -> {cut_a: Cut l} -> {cut_b: Cut m} -> {cut_c: Cut n} ->
       Hom cut_a cut_b -> Hom cut_b cut_c -> Hom cut_a cut_c
(-*-) {cut_b} f g = do Just pid_f <- Spawn f | _ => do Action $ putStrLn "ERROR: (-*-): failed spawn 1"
                                                       f -*- g
                       Just pid_g <- Spawn g | _ => do Action $ putStrLn "ERROR: (-*-): failed spawn 2"
                                                       f -*- g
                       makeConnections cut_b pid_f pid_g
                       looper pid_f pid_g
  where
    looper : ProcPID (MkNiche cut_a cut_b) ->
             ProcPID (MkNiche cut_b cut_c) ->
             Process (ProcIF (MkNiche cut_a cut_c)) () Ready Looping
    looper pid_f pid_g = do --Action $ putStrLn $ "(-*-): normal loop"
                            Respond (resp pid_f pid_g)
                            Loop (looper pid_f pid_g)


module Main

data Format = End | FInt Format | FStr Format | FChar Char Format

fromList : List Char -> Format
fromList Nil                = End
fromList ('%' :: 'd' :: cs) = FInt    (fromList cs)
fromList ('%' :: 's' :: cs) = FStr (fromList cs)
fromList (c :: cs)          = FChar c (fromList cs)

PrintfType : Format -> Type
PrintfType End            = String
PrintfType (FInt rest)    = Int -> PrintfType rest
PrintfType (FStr rest) = String -> PrintfType rest
PrintfType (FChar c rest) = PrintfType rest

printf : (fmt: String) -> PrintfType (fromList $ unpack fmt)
printf fmt = printFormat (fromList $ unpack fmt) where
 printFormat : (fmt: Format) -> PrintfType fmt
 printFormat fmt = rec fmt "" where
   rec : (f: Format) -> String -> PrintfType f
   rec End acc            = acc
   rec (FInt rest) acc    = \i: Int => rec rest (acc ++ (show i))
   rec (FStr rest) acc = \s: String => rec rest (acc ++ s)
   rec (FChar c rest) acc = rec rest (acc ++ (strCons c ""))

test : String
test = printf "The %s is %d" "answer" 42

main : IO ()
main = putStrLn test


module Chapter6

import Data.Vect

%default total

-- type synonyms

Position : Type
Position = (Double, Double)

tri : Vect 3 Position
tri = [(0.0, 0.0), (1.0, 2.0), (-23.22, -11.089)]

-- type-level functions
-- type-level functions are merely functions that return a Type

-- defining functions with a variable number of arguments