open import Structures
open import SacTy

module ExtractSac where
open import Data.String as S hiding (_++_) renaming (_≟_ to _≟s_)
open import Data.List as L hiding (_++_)
open import Data.List.Categorical
open import Data.List.Properties as L
open import Data.Nat as N
open import Agda.Builtin.Nat using (div-helper; mod-helper)

open import Data.Nat.Properties as N
open import Data.Nat.Show renaming (show to showNat)
open import Data.Product as Σ hiding (map)
open import Data.Sum hiding (map)
open import Data.Vec as V using (Vec; [] ; _∷_)
open import Data.Char using (Char) renaming (_≈?_ to _c≈?_)
open import Data.Bool
open import Data.Fin as F using (Fin; zero; suc; inject₁; fromℕ<; #_)
open import Data.Maybe as M using (Maybe; just; nothing)
open import Data.Unit

open import Category.Monad
open import Category.Monad.State

open import Relation.Binary.PropositionalEquality as Eq hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Decidable hiding (map)

open import Reflection hiding (return; _>>=_; _>>_)
open import Reflection.Term
import      Reflection.Name as RN
open import Reflection.Annotated
open import Reflection.Universe
open import Reflection.Annotated.Free

open import Function

open import Array.Base
open import Array.Properties
open import APL2 using (reduce-1d; _↑_; _↓_; ▴_; ▾_; _-↑⟨_⟩_; _↑⟨_⟩_)

open import Agda.Builtin.Float

open RawMonad ⦃ ... ⦄

-- Glorified sigma type for variable-type pairs
record VarTy : Set where
  constructor _∈_~_
  field v : String
        s : Err SacTy
        t : Arg Type

-- Glorified sigma type for variable-assertion pairs
record Assrt : Set where
  constructor mk
  field v : String
        a : String

Assrts = List Assrt

-- The state used when traversing a Pi type.
record PS : Set where
  field
    cnt : ℕ           -- The source of unique variable names
    cur : String      -- Current variable name (used to collect assertions from its type)
    ctx : List VarTy  -- Names in the telscopes to resolve deBruijn indices
    ret : String      -- Variable that the function returns as a result.
                      -- We assume that there is always a single variable and its name
                      -- is known upfront.  We need this to generate assertions from the
                      -- return type.
    assrts : Assrts   -- Assertions that we generate per each variable.
    kst : KS          -- Compilation state (in case we have to extract some functions used in types)

defaultPS : PS
defaultPS = record { cnt = 1
                   ; cur = ""
                   ; ctx = []
                   ; ret = "__ret"
                   ; assrts = []
                   ; kst = defaultKS
                   }

-- Pack the information about new variables generated
-- by patterns in the clause, assignments to these,
-- and the list of conditions for "getting into" the
-- clause.  E.g.
--   foo : List ℕ → ℕ
--   foo (x ∷ xs) 2 = ...
--
-- Assume that we named top-level arguments [a, b]
-- Then, new variables for this clause are going to be
--     [x, xs]
-- Assignments are:
--     [x = hd a, xs = tl a]
-- Conditions are:
--     [is-cons a, b == 2]
--
-- `cnt` is merely a source of fresh variables.
record PatSt : Set where
  constructor mk
  field
    vars    : List (String × ℕ) --Strings
    assigns : Strings
    conds   : Strings
    cnt     : ℕ

defaultPatSt : PatSt
defaultPatSt = mk [] [] [] 1

SPS = State PS

-- The main function kit to extract sac functions.
kompile-fun    : Type → Term → Name → SKS Prog
kompile-pi     : Type → SPS (Err SacTy) --Prog
kompile-cls    : Clauses → (vars : Strings) → (ret : String) → SKS Prog
kompile-clpats : Telescope → (pats : List $ Arg Pattern) → (vars : Strings) → PatSt → Err PatSt
{-# TERMINATING #-}
kompile-term   : Term → {- (varctx : Strings) -} {- List VarTy -} Telescope → SKS Prog

-- Normalise the name of the symbols (functions, constructors, ...)
-- that we obtain from showName, i.e. remove dots, replace weird
-- symbols with ascii.
nnorm : String → String
nnorm s = replace '.' "_"
        $ replace '-' "_"
        $ replace '+' "plus"
        $ replace 'α' "alpha"
        $ replace 'ω' "omega"
        $ replace '→' "to"
        $ s
  where
    repchar : (from : Char) (to : String) (x : Char) → String
    repchar from to x with does $ x c≈? from
    ... | true  = to
    ... | false = fromList (x ∷ [])

    replace : (from : Char) (to : String) → String → String
    replace f t s = "" ++/ L.map (repchar f t) (toList s)

private
  kf : String → Prog
  kf x = error $ "kompile-fun: " ++ x

  validate-ty : Err SacTy → Prog
  validate-ty (error x) = error x
  validate-ty (ok τ) = let τ′ = sacty-normalise τ in
                       case nested? τ′ of λ where
                         hom → ok $ sacty-to-string τ′
                         nes → error $ "sac does not support nested types, but `"
                                    ++ sacty-to-string τ′ ++ "` found"

  module R = RawMonadState (StateMonadState KS)

kompile-fun ty (pat-lam [] []) n =
  return $ kf "got zero clauses in a lambda term"
kompile-fun ty (pat-lam cs []) n = do
  kst ← R.get
  let (rt , ps) = kompile-pi ty $ record defaultPS{ kst = kst }
      rt = validate-ty rt
      rv = PS.ret ps
      ns = showName n
      args = ok ", " ++/ L.map (λ where (v ∈ t ~ _) → validate-ty t ⊕ " " ⊕ v) (PS.ctx ps)
      ret-assrts = list-filter (λ where (mk v _) → v ≈? rv) $ PS.assrts ps
      arg-assrts = list-filter (dec-neg λ where (mk v _) → v ≈? rv) $ PS.assrts ps
      assrt-to-code = ("/* " ++_) ∘ (_++ " */") ∘ Assrt.a
  R.put $ PS.kst ps
  --b ← if does (showName n S.≟ "Example-02.testn") then kompile-cls cs (L.map (λ where (v ∈ _ ~ _) → v) $ PS.ctx ps) rv else (return $ ok "XX")
  b ← kompile-cls cs (L.map (λ where (v ∈ _ ~ _) → v) $ PS.ctx ps) rv
  return $ "// Function " ⊕ ns ⊕ "\n"
         ⊕ rt ⊕ "\n"
         ⊕ nnorm ns ⊕ "(" ⊕ args ⊕ ") {\n"
         ⊕ "\n" ++/ L.map assrt-to-code arg-assrts
         ⊕ rt ⊕ " " ⊕ rv ⊕ ";\n"
         ⊕ b -- function body
         ⊕ "\n" ++/ L.map assrt-to-code ret-assrts
         ⊕ "return " ⊕ rv ⊕ ";\n"
         ⊕ "}\n\n"

kompile-fun _ _ _ =
  return $ kf "expected pattern-matching lambda"

private
  kp : ∀ {X} → String → SPS (Err X)
  kp x = return $ error $ "kompile-pi: " ++ x

  ke : ∀ {X} → String → SPS (Err X)
  ke x = return $ error x

  module P = RawMonadState (StateMonadState PS)

  infixl 10 _p+=c_ _p+=a_
  _p+=c_ : PS → ℕ → PS
  ps p+=c n = record ps{ cnt = PS.cnt ps + n }

  _p+=a_ : PS → Assrt → PS
  ps p+=a a = record ps{ assrts = a ∷ PS.assrts ps }

  ps-fresh : String → SPS String
  ps-fresh x = do
    ps ← P.get
    P.modify (_p+=c 1)
    return $ x ++ showNat (PS.cnt ps)

  lift-ks : ∀ {X} → SKS X → SPS X
  lift-ks xf sps = let (x , sks) = xf (PS.kst sps) in x , record sps {kst = sks}

  sps-kompile-term : Term → SPS Prog
  sps-kompile-term t = do
    ps ← P.get
    lift-ks $ kompile-term t $ (L.map (λ where (v ∈ _ ~ t) → (v , t)) $ PS.ctx ps)

kompile-ty : Type → (pi-ok : Bool) → SPS (Err SacTy)
kompile-ty (Π[ s ∶ arg i x ] y) false = kp "higher-order functions are not supported"
kompile-ty (Π[ s ∶ arg i x ] y) true  = do
    v ← ps-fresh "x_"
    P.modify λ k → record k { cur = v }
    (ok t) ← kompile-ty x false
      where e → return e
    P.modify λ k → record k { cur = PS.ret k  -- In case this is a return type
                            ; ctx = PS.ctx k ++ [ v ∈ ok t ~ arg i x ] }
    kompile-ty y true

kompile-ty (con c args) pi-ok =
  kp $ "don't know how to handle `" ++ showName c ++ "` constructor"
kompile-ty (def (quote ℕ) args) _ = return $ ok int
kompile-ty (def (quote Bool) args) _ = return $ ok bool
kompile-ty (def (quote Float) args) _ = return $ ok float
kompile-ty (def (quote Fin) (arg _ x ∷ [])) _ = do
  ok p ← sps-kompile-term x where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v $′ "assert (" ++ v ++ " < " ++ p ++ ")")
  return $ ok int

kompile-ty (def (quote L.List) (_ ∷ arg _ ty ∷ _)) _ = do
  el ← ps-fresh "el_"
  v , as ← < PS.cur , PS.assrts > <$> P.get
  -- Any constraints that the subsequent call would
  -- generate will be constraints about the elements
  -- of the list.
  P.modify λ k → record k { cur = el ; assrts = [] }
  ok τ ← kompile-ty ty false where e → return e
  P.modify λ k → record k {
    cur = v;
    assrts = as ++ (L.map {B = Assrt} (λ where (mk _ a) → mk v ("foreach-v " ++ el ++ " in " ++ v ++ ": " ++ a)) $ PS.assrts k)
    -- No need to modify context, as we don't allow higher order functions, so it stays the same.
    }
  return $ ok $ akd nes τ (error "lists do not have static shape") 1

kompile-ty (def (quote V.Vec) (_ ∷ arg _ ty ∷ arg _ n ∷ [])) _ = do
  el ← ps-fresh "el_"
  v , as ← < PS.cur , PS.assrts > <$> P.get
  ok p ← sps-kompile-term n where error x → ke x
  P.modify λ k → record k { cur = el ; assrts = [] }
  ok τ ← kompile-ty ty false where e → return e
  P.modify λ k → record k {
    cur = v;
    assrts = as ++ (L.map {B = Assrt} (λ where (mk _ a) → mk v ("foreach-v " ++ el ++ " in " ++ v ++ ": " ++ a)) $ PS.assrts k)
                ++ [ mk v $′ "assert (shape (" ++ v ++ ")[[0]] == " ++ p ++ ")" ]
    }
  let sh = "[" ⊕ p ⊕ "]"
  case n of λ where
    -- XXX can we possibly miss on any constant expressions?
    (lit (nat n′)) → return $ ok $ aks hom τ sh 1 V.[ n′ ]
    _              → return $ ok $ akd hom τ sh 1

kompile-ty (def (quote Ar) (_ ∷ arg _ el-ty ∷ arg _ dim ∷ arg _ sh ∷ [])) _ = do
  el ← ps-fresh "el_"
  v , as ← < PS.cur , PS.assrts > <$> P.get
  ok d ← sps-kompile-term dim where error x → ke x
  ok s ← sps-kompile-term sh where error x → ke x
  P.modify λ k → record k { cur = el ; assrts = [] }
  ok τ ← kompile-ty el-ty false where e → return e
  P.modify λ k → record k {
    cur = v;
    assrts = as ++ (L.map {B = Assrt} (λ where (mk _ a) → mk v ("foreach-a sh=" ++ s ++ " " ++ el ++ " in " ++ v ++ ": " ++ a)) $ PS.assrts k)
                ++ [ mk v $′ "assert (take (" ++ d ++ ", shape (" ++ v ++ ")) == " ++ s ++ ")" ]
                -- XXX do we want to assert stuff about rank?
    }
  case dim of λ where
    -- XXX can we possibly miss on any constant expressions?
    -- FIXME consider AKS case here!
    (lit (nat d′)) → return $ ok $ akd hom τ (ok s) d′
    _ → return $ ok $ aud hom τ (ok s)

kompile-ty (def (quote Ix) (arg _ dim ∷ arg _ s ∷ [])) _ = do
  v ← PS.cur <$> P.get
  ok d ← sps-kompile-term dim where error x → ke x
  ok s ← sps-kompile-term s where error x → ke x
  P.modify $ _p+=a (mk v $′ "assert (dim (" ++ v ++ ") == " ++ d ++ ")")
           ∘ _p+=a (mk v $′ "assert (" ++ v ++ " < " ++ s ++ ")")

  case dim of λ where
    (lit (nat d′)) → return $ ok $ aks hom int (ok s) 1 V.[ d′ ]
    _              → return $ ok $ akd hom int (ok s) 1

kompile-ty (def (quote _≡_) (_ ∷ arg _ ty ∷ arg _ x ∷ arg _ y ∷ [])) _ = do
  ok x ← sps-kompile-term x where error x → ke x
  ok y ← sps-kompile-term y where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v $′ "assert (" ++ x ++ " == " ++ y ++ ")")
  return $ ok unit

kompile-ty (def (quote _≥a_) (_ ∷ _ ∷ arg _ x ∷ arg _ y ∷ [])) _ = do
  ok x ← sps-kompile-term x where error x → ke x
  ok y ← sps-kompile-term y where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v $′ "assert (" ++ x ++ " >= " ++ y ++ ")")
  return $ ok unit

kompile-ty (def (quote _<a_) (_ ∷ _ ∷ arg _ x ∷ arg _ y ∷ [])) _ = do
  ok x ← sps-kompile-term x where error x → ke x
  ok y ← sps-kompile-term y where error x → ke x
  v ← PS.cur <$> P.get
  P.modify $ _p+=a (mk v $′ "assert (" ++ x ++ " < " ++ y ++ ")")
  return $ ok unit

kompile-ty (def (quote Dec) (_ ∷ arg _ p ∷ [])) _ = do
  _ ← kompile-ty p false
  return $ ok bool

kompile-ty (def n _) _ = kp $ "cannot handle `" ++ showName n ++ "` type"

kompile-ty t _ =
  kp $ "failed with the term `" ++ showTerm t ++ "`"

kompile-pi x = kompile-ty x true

-- The names in the telescopes very oftern are not unique, which
-- would be pretty disasterous if the code generation relies on them.
-- see https://github.com/agda/agda/issues/5048 for more details.
--
-- This function simply ensures that variable names are unique in
-- in the telescope.
tel-rename : Telescope → (db : List (String × ℕ)) → Telescope
tel-rename [] db = []
tel-rename ((v , ty) ∷ tel) db with list-find-el ((_≟s v) ∘ proj₁) db
... | just (_ , n) = (v ++ "_" ++ showNat n , ty)
                     ∷ tel-rename tel (list-update-fst ((_≟s v) ∘ proj₁) db (Σ.map₂ suc))
... | nothing      = (v , ty)
                     ∷ tel-rename tel ((v , 1) ∷ db)

private
  kc : String → SKS Prog
  kc x = return $ error $ "kompile-cls: " ++ x

  _>>=e_ : ∀ {a}{X : Set a} → Err X → (X → SKS Prog) → SKS Prog
  (error s) >>=e _ = return $ error s
  (ok x)    >>=e f = f x

  -- sort in increasing order
  list-sort : ∀ {a}{X : Set a} → (acc l : List (X × ℕ)) → List (X × ℕ)
  list-sort acc [] = acc
  list-sort acc (x ∷ l) = list-sort (insert acc x) l
    where
      insert : _ → _ → _
      insert [] y = y ∷ []
      insert (x ∷ xs) y with proj₂ y N.<? proj₂ x
      ... | yes y<x = y ∷ x ∷ xs
      ... | no  y≥x = x ∷ insert xs y

  isperm : ∀ {a}{X : Set a} → (n max : ℕ) → (db : List ℕ) → List (X × ℕ) → Bool
  isperm 0 0   [] [] = true
  isperm n max db [] = does (1 + max N.≟ n) ∧ does (L.length db N.≟ n)
  isperm n max db ((_ , x) ∷ xs) with list-has-el (N._≟ x) db
  ...                      | true = false
  ...                      | false = isperm n (max N.⊔ x) (x ∷ db) xs

  perm : Telescope → List (String × ℕ) → Err (List String)
  perm tel vs with isperm (L.length tel) 0 [] vs
  ... | false = error $ ", " ++/ L.map (λ where (x , y) → "(" ++ x ++ ", " ++ showNat y ++ ")") vs
                     ++ " is not a permutation of the telescope "
                     ++ showTel tel
  ... | true = ok $ L.reverse $ L.map proj₁ $ list-sort [] vs

  module test-perm where
    test₀ : isperm {X = ℕ} 0 0 [] [] ≡ true
    test₀ = refl

    test₁ : isperm 1 0 [] (("" , 0) ∷ []) ≡ true
    test₁ = refl

    test₂′ : isperm 2 0 [] (("" , 1) ∷ ("" , 0) ∷ []) ≡ true
    test₂′ = refl

    test₃ : isperm 3 0 [] (("" , 2) ∷ ("" , 0) ∷ ("" , 1) ∷ []) ≡ true
    test₃ = refl

    test₄ : isperm 4 0 [] (("" , 2) ∷ ("" , 2) ∷ ("" , 1) ∷ ("" , 3) ∷ []) ≡ false
    test₄ = refl

kompile-tel : Telescope → SPS (Err ⊤)
kompile-tel [] = return $ ok tt
kompile-tel ((v , t@(arg i x)) ∷ tel) = do
  --(ok τ) ← kompile-ty x false where (error x) → return $ error x
  P.modify λ k → record k{ ctx = PS.ctx k ++ [ v ∈ error "?" ~ t ] }
  kompile-tel tel

kompile-cls [] ctx ret = kc "zero clauses found"
kompile-cls (clause tel ps t ∷ []) ctx ret =
  -- Make telscope names unique.
  let tel = (tel-rename $! tel) $! [] in
  kompile-clpats tel ps ctx defaultPatSt >>=e λ pst → do
  let (mk vars assgns _ _) = pst --in
  t ← kompile-term t $! tel
  let as = "\n" ++/ assgns
  return $ as ⊕ "\n"
      ⊕ ret ⊕ " = " ⊕ t ⊕ ";\n"

kompile-cls (absurd-clause tel ps ∷ []) ctx ret =
  -- Exactly the same as above
  -- We don't really need to make this call, but we keep it
  -- for sanity checks.  I.e. if we'll get an error in the
  -- patterns, it will bubble up to the caller.
  kompile-clpats ((tel-rename $! tel) $! []) ps ctx defaultPatSt >>=e λ pst → do
  return $ ok "unreachable ();"

kompile-cls (absurd-clause tel ps ∷ ts@(_ ∷ _)) ctx ret =
  kompile-clpats ((tel-rename $! tel) $! []) ps ctx defaultPatSt >>=e λ pst → do
  let (mk vars _ conds _) = pst
      cs = " && " ++/ (if L.length conds N.≡ᵇ 0 then [ "true" ] else conds)
  r ← kompile-cls ts ctx ret
  return $ "if (" ⊕ cs ⊕ ") {\n"
         ⊕ "unreachable();\n"
         ⊕ "} else {\n"
         ⊕ r ⊕ "\n"
         ⊕ "}\n"

kompile-cls (clause tel ps t ∷ ts@(_ ∷ _)) ctx ret =
  kompile-clpats ((tel-rename $! tel) $! []) ps ctx defaultPatSt >>=e λ pst → do
  let (mk vars assgns conds _) = pst
      cs = " && " ++/ (if L.length conds N.≡ᵇ 0 then [ "true" ] else conds)
      as = "\n" ++/ assgns
  t ← kompile-term t $! tel --telv --{!!} --PS.ctx ps
  r ← kompile-cls ts ctx ret
  return $ "if (" ⊕ cs ⊕ ") {\n"
         ⊕ as ⊕ "\n"
         ⊕ ret ⊕ " = " ⊕ t ⊕ ";\n"
         ⊕ "} else {\n"
         ⊕ r ⊕ "\n"
         ⊕ "}\n"

tel-lookup-name : Telescope → ℕ → Prog
tel-lookup-name tel n with n N.<? L.length (reverse tel)
... | yes n<l = ok $ proj₁ $ lookup (reverse tel) $ fromℕ< n<l
... | no _ = error "Variable lookup in telescope failed"

private
  kcp : String → Err PatSt
  kcp x = error $ "kompile-clpats: " ++ x

  infixl 10 _+=c_ _+=a_ _+=v_ _+=n_
  _+=c_ : PatSt → String → PatSt
  p +=c c = record p { conds = PatSt.conds p ++ [ c ] }

  _+=a_ : PatSt → String → PatSt
  p +=a a = record p { assigns = PatSt.assigns p ++ [ a ] }

  _+=v_ : PatSt → String × ℕ → PatSt
  p +=v v = record p { vars = PatSt.vars p ++ [ v ] }

  _+=n_ : PatSt → ℕ → PatSt
  p +=n n = record p { cnt = PatSt.cnt p + 1 }

  pst-fresh : PatSt → String → Err $ String × PatSt
  pst-fresh pst x =
    return $ x ++ showNat (PatSt.cnt pst) , pst +=n 1

kompile-clpats tel (arg i (con (quote true) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c (v {- == true -})
kompile-clpats tel (arg i (con (quote false) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c ("!" ++ v)

kompile-clpats tel (arg i (con (quote N.zero) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c (v ++ " == 0")
kompile-clpats tel (arg i (con (quote N.suc) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (ps ++ l) ((v ++ " - 1") ∷ ctx) $ pst +=c (v ++ " > 0")

kompile-clpats tel (arg i (con (quote F.zero) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c (v ++ " == 0")
kompile-clpats tel (arg i (con (quote F.suc) ps@(_ ∷ _ ∷ [])) ∷ l) (v ∷ ctx) pst = do
  (ub , pst) ← pst-fresh pst "ub_"
  -- XXX here we are not using `ub` in conds.  For two reasons:
  -- 1) as we have assertions, we should check the upper bound on function entry
  -- 2) typically, the value of this argument would be Pat.dot, which we ignore
  --    right now.  It is possible to capture the value of the dot-patterns, as
  --    they carry the value when reconstructed.
  kompile-clpats tel (ps ++ l) (ub ∷ (v ++ " - 1") ∷ ctx) $ pst +=c (v ++ " > 0")

kompile-clpats tel (arg i (con (quote L.List.[]) []) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c ("emptyvec_p (" ++ v ++ ")")
kompile-clpats tel (arg i (con (quote L.List._∷_) ps@(_ ∷ _ ∷ [])) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (ps ++ l) (("hd (" ++ v ++ ")") ∷ ("tl (" ++ v ++ ")") ∷ ctx)
                 $ pst +=c ("nonemptyvec_p (" ++ v ++ ")")

-- Almost the same as List (extra parameter in cons)
kompile-clpats tel (arg i (con (quote V.Vec.[]) []) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c ("emptyvec_p (" ++ v ++ ")")
kompile-clpats tel (arg i (con (quote V.Vec._∷_) ps@(_ ∷ _ ∷ _ ∷ [])) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (ps ++ l) (("len (" ++ v ++ ") - 1") ∷ ("hd (" ++ v ++ ")") ∷ ("tl (" ++ v ++ ")") ∷ ctx)
                 $ pst +=c ("nonemptyvec_p (" ++ v ++ ")")

-- Patterns for Ix constructors
kompile-clpats tel (arg i (con (quote Ix.[]) []) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel l ctx $ pst +=c ("emptyvec_p (" ++ v ++ ")")

kompile-clpats tel (arg i (con (quote Ix._∷_) ps@(d ∷ arg _ (dot s) ∷ arg _ (dot x) ∷ finx ∷ tailix ∷ [])) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (d ∷ finx ∷ tailix ∷ l) (("len (" ++ v ++ ") - 1") ∷ ("hd (" ++ v ++ ")") ∷ ("tl (" ++ v ++ ")") ∷ ctx)
                 $ pst +=c ("nonemptyvec_p (" ++ v ++ ")")
kompile-clpats tel (arg i (con (quote Ix._∷_) _) ∷ l) (v ∷ ctx) pst =
  kcp $ "matching on `s` and `x` in the Ix._∷_ is not supported, please rewrite the pattern"

kompile-clpats tel (arg _ (con (quote imap) (arg _ (var i) ∷ [])) ∷ l) (v ∷ ctx) pst = do
  (ub , pst) ← pst-fresh pst $ "IMAP_" ++ v ++ "_"
  -- The only thing that `x` could be is a variable, and since
  -- we don't have higher-order functions in sac, we define a local
  -- macro.  Note that we do not pass x further, to avoid assignment.
  kompile-clpats tel l ctx $ pst +=v (ub , i) +=a ("#define " ++ ub ++ "(__x) (" ++ v ++ ")[__x]")

kompile-clpats tel (arg i (con (quote imap) (arg _ (dot _) ∷ [])) ∷ l) (v ∷ ctx) pst =
  -- We simply ignore this inner function entirely.
  kompile-clpats tel l ctx $ pst

kompile-clpats tel (arg i (con (quote imap) (arg _ (absurd _) ∷ [])) ∷ l) (v ∷ ctx) pst =
  kcp "don't know how to handle absurd pattern as an argument to imap"

kompile-clpats tel (arg i (con (quote refl) ps) ∷ l) (v ∷ ctx) pst =
  -- No constraints, as there could only be a single value.
  kompile-clpats tel l ctx pst

kompile-clpats tel (arg i (con (quote _because_) ps) ∷ l) (v ∷ ctx) pst = do
  pf , pst ← pst-fresh pst $ "pf_"
  kompile-clpats tel (ps ++ l) (v ∷ pf ∷ ctx) pst
kompile-clpats tel (arg i (con (quote Reflects.ofʸ) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (ps ++ l) ("true" ∷ ctx) pst
kompile-clpats tel (arg i (con (quote Reflects.ofⁿ) ps) ∷ l) (v ∷ ctx) pst =
  kompile-clpats tel (ps ++ l) ("false" ∷ ctx) pst

-- End of constructors here.

kompile-clpats tel (arg (arg-info _ r) (var i) ∷ l) (v ∷ vars) pst = do
  -- Note that we do not distinguish between hidden and visible variables
  s ← tel-lookup-name tel i
  let s = nnorm s
  -- If the order of variable binding doesn't match the order
  -- of the variables in the telescope, we have to consider `i` as well.
  -- This changed with https://github.com/agda/agda/issues/5075
  let pst = pst +=v (s , i)
  let pst = if does (s ≈? "_")
            then pst
            else pst +=a (s ++ " = " ++ v ++ ";")
  {-
  -- XXX If I replace the above if with this one, I end up with
  -- the unsolved meta in the test₂ in Example.agda.  Is this a bug?
  let pst = case (s ≈? "_") of λ where
             (yes _) → pst
             (no _)  → pst +=a (s ++ " = " ++ v ++ ";")
  -}
  kompile-clpats tel l vars pst

kompile-clpats tel (arg i (dot t) ∷ l) (v ∷ vars) pst =
  -- For now we just skip dot patterns.
  kompile-clpats tel l vars pst

kompile-clpats tel (arg i (absurd _) ∷ l) (v ∷ ctx) pst =
  -- If have met the absurd pattern, we are done, as
  -- we have accumulated enough conditions to derive
  -- impossibility.  So we are simply done.
  ok pst

kompile-clpats _ [] [] pst = ok pst
kompile-clpats tel ps ctx patst = kcp $ "failed on pattern: ["
                                     ++ (", " ++/ L.map (λ where (arg _ x) → showPattern x) ps)
                                     ++ "], ctx: [" ++ (", " ++/ ctx) ++ "]"

private
  kt : String → SKS Prog
  kt x = return $ error $ "kompile-term: " ++ x

  kt-fresh : String → SKS String
  kt-fresh x = do
    ps ← R.get
    R.modify λ k → record k{ cnt = 1 + KS.cnt k }
    return $ x ++ showNat (KS.cnt ps)

var-lookup : List VarTy → ℕ → SKS Prog
var-lookup []       _       = kt "Variable lookup failed"
var-lookup (v ∈ _ ~ _ ∷ xs) zero    = return $ ok v
var-lookup (x ∷ xs) (suc n) = var-lookup xs n

vty-lookup : List VarTy → ℕ → Err (VarTy)
vty-lookup []       _       = error "Variable lookup failed"
vty-lookup (x ∷ xs) zero    = ok x
vty-lookup (x ∷ xs) (suc n) = vty-lookup xs n

mk-mask : (n : ℕ) → List $ Fin n
mk-mask zero =    []
mk-mask (suc n) = L.reverse $ go n (suc n) N.≤-refl
  where
    sa<b⇒a<b : ∀ a b → suc a N.< b → a N.< b
    sa<b⇒a<b zero    (suc b) _        = s≤s z≤n
    sa<b⇒a<b (suc a) (suc n) (s≤s pf) = s≤s $ sa<b⇒a<b a n pf

    go : (m n : ℕ) → m N.< n → List $ Fin n
    go 0       (suc _) _  = zero ∷ []
    go (suc m) n       pf = F.fromℕ< pf ∷ go m n (sa<b⇒a<b m n pf)

te-to-lvt : Telescope → List VarTy
te-to-lvt tel = L.map (λ where (v , t) → v ∈ error "?" ~ t) tel

-- TODO lift it up
SAC-funs : List (Name × String)
SAC-funs = (quote _+_ , "_add_SxS_")
         ∷ (quote _*_ , "_mul_SxS_")
         ∷ (quote primFloatPlus , "_add_SxS_")
         ∷ (quote primFloatMinus , "_sub_SxS_")
         ∷ (quote primFloatTimes , "_mul_SxS_")
         ∷ (quote primFloatDiv , "_div_SxS_")
         ∷ (quote primFloatExp , "Math::exp")
         ∷ (quote primFloatNegate , "_neg_S_")
         ∷ []

private
  module mask-tests where
    test-mk-mask₁ : mk-mask 0 ≡ []
    test-mk-mask₁ = refl

    test-mk-mask₂ : mk-mask 1 ≡ # 0 ∷ []
    test-mk-mask₂ = refl

    test-mk-mask₃ : mk-mask 2 ≡ # 0 ∷ # 1 ∷ []
    test-mk-mask₃ = refl

kompile-arglist : (n : ℕ) → List $ Arg Term → List $ Fin n → Telescope → SKS Prog
kompile-arglist n args mask varctx with L.length args N.≟ n | V.fromList args
... | yes p | vargs rewrite p = do
                 l ← mapM (λ where (arg _ x) → kompile-term x varctx)
                          $ L.map (V.lookup vargs) mask
                 return $ ok ", " ++/ l
              where open TraversableM (StateMonad KS)

... | no ¬p | _ = kt "Incorrect argument mask"

kompile-term (var x []) vars =
  return $ tel-lookup-name vars x

kompile-term (var x args@(_ ∷ _)) vars = do
  let f = tel-lookup-name vars x
      l = L.length args
  args ← kompile-arglist l args (mk-mask l) vars
  return $ f ⊕ "(" ⊕ args ⊕ ")"

kompile-term (lit l@(float _)) vars = return $ showLiteral l ⊕ "f"
kompile-term (lit l) vars = return $ ok $ showLiteral l

kompile-term (con (quote N.zero) _) _ =
  return $ ok "0"
kompile-term (con (quote N.suc) args) vars = do
  args ← kompile-arglist 1 args [ # 0 ] vars
  return $ "(1 + " ⊕ args ⊕ ")"

kompile-term (con (quote Fin.zero) _) _ =
  return $ ok "0"
kompile-term (con (quote Fin.suc) args) vars = do
  args ← kompile-arglist 2 args [ # 1 ] vars
  return $ "(1 + " ⊕ args ⊕ ")"

kompile-term (con (quote L.List.[]) (_ ∷ (arg _ ty) ∷ [])) vars = do
  -- We want to call kompile-ty, and we need a context that "should"
  -- contain vars with their types.  But, we never actually access these
  -- types in the context, we only refer to variables, therefore the
  -- following hack is justified.
  kst ← R.get
  let ctx = L.map (λ where (v , t) → v ∈ error "?" ~ t) $ vars
      (rt , ps) = kompile-ty ty false $ record defaultPS{ kst = kst; ctx = ctx }
      in-sh = sacty-shape =<< rt
  --R.put (PS.kst ps)
  return $ "empty (" ⊕ in-sh ⊕ ")" --ok "[]"

kompile-term (con (quote L.List._∷_) args) vars = do
  args ← kompile-arglist 4 args (# 2 ∷ # 3 ∷ []) vars
  return $ "cons (" ⊕ args ⊕ ")"

-- Almost the same as List
kompile-term (con (quote V.Vec.[]) (_ ∷ (arg _ ty) ∷ [])) vars = do
  kst ← R.get
  let ctx = L.map (λ where (v , t) → v ∈ error "?" ~ t) $ vars
      (rt , ps) = kompile-ty ty false $ record defaultPS{ kst = kst; ctx = ctx }
      in-sh = sacty-shape =<< rt
  R.put (PS.kst ps)
  return $ "empty (" ⊕ in-sh ⊕ ")"

kompile-term (con (quote V.Vec._∷_) args) vars = do
  args ← kompile-arglist 5 args (# 3 ∷ # 4 ∷ []) vars
  return $ "cons (" ⊕ args ⊕ ")"

-- Ix constructors
kompile-term (con (quote Ix.[]) []) vars =
  return $ ok "[]"

kompile-term (con (quote Ix._∷_) args) vars = do
  args ← kompile-arglist 5 args (# 3 ∷ # 4 ∷ []) vars
  return $ "cons (" ⊕ args ⊕ ")"

kompile-term (con (quote refl) _) _ =
  return $ ok "tt"

-- Imaps with explicit lambdas
kompile-term (con (quote Array.Base.imap) (_ ∷ arg _ ty ∷ arg _ d ∷ X@(arg _ s) ∷ arg _ (vLam x e) ∷ [])) vars = do
  kst ← R.get
  let ctx = L.map (λ where (v , t) → v ∈ error "?" ~ t) $ vars
      (rt , ps) = kompile-ty ty false $ record defaultPS{ kst = kst; ctx = ctx }
      in-sh = sacty-shape =<< rt
      bt = bt <$> rt
  R.put (PS.kst ps)
  iv ← kt-fresh "iv_"
  let iv-type = vArg (def (quote Ix) ((vArg d) ∷ vArg s ∷ []))
  s ← kompile-term s vars
  b ← kompile-term e $! vars ++ [ (iv , iv-type) ]
  return $! "with { (. <= " ⊕ iv ⊕ " <= .): " ⊕ b ⊕ "; }: genarray (" ⊕ s ⊕ ", zero_" ⊕ bt ⊕ " (" ⊕ in-sh ⊕ "))"

-- Imaps with an expression
kompile-term (con (quote Array.Base.imap) (_ ∷ arg _ ty ∷ _ ∷ arg _ s ∷ arg _ e ∷ [])) vars = do
  kst ← R.get
  let ctx = L.map (λ where (v , t) → v ∈ error "?" ~ t) $ vars
      (rt , ps) = kompile-ty ty false $ record defaultPS{ kst = kst; ctx = ctx }
      in-sh = sacty-shape =<< rt
      bt = bt <$> rt
  R.put (PS.kst ps)
  iv ← kt-fresh "iv_"
  s ← kompile-term s vars
  b ← kompile-term e $ vars
  return $ "with { (. <= " ⊕ iv ⊕ " <= .): " ⊕ b ⊕ " (" ⊕ iv ⊕ "); }: genarray (" ⊕ s ⊕ ", zero_" ⊕ bt ⊕ " (" ⊕ in-sh ⊕ "))"

kompile-term (con c _) vars  = kt $ "don't know constructor " ++ (showName c)

-- Definitions

-- From Agda.Builtin.Nat: div-helper k m n j = k + (n + m - j) div (1 + m)
kompile-term (def (quote div-helper) (arg _ k ∷ arg _ m ∷ arg _ n ∷ arg _ j ∷ [])) vars = do
  k ← kompile-term k vars
  m ← kompile-term m vars
  n ← kompile-term n vars
  j ← kompile-term j vars
  return $ "_div_SxS_ (" ⊕ k ⊕ " + (" ⊕ n ⊕ " + " ⊕ m ⊕ " - " ⊕ j ⊕ "), 1 + " ⊕ m ⊕ ")"

kompile-term (def (quote N._≟_) (arg _ a ∷ arg _ b ∷ [])) vars = do
  a ← kompile-term a vars
  b ← kompile-term b vars
  return $ a ⊕ " == " ⊕  b

kompile-term (def (quote V._++_) args) vars = do
  args ← kompile-arglist 6 args (# 4 ∷ # 5 ∷ []) vars
  return $ "concat (" ⊕ args ⊕ ")"

kompile-term (def (quote V.tabulate) (_ ∷ arg _ ty ∷ X@(arg _ l) ∷ arg _ (vLam x e) ∷ [])) vars = do
  kst ← R.get
  let ctx = te-to-lvt vars --L.map (λ where (v , t) → v ∈ error "?" ~ t) $ TelView.tel vars
      (rt , ps) = kompile-ty ty false $ record defaultPS{ kst = kst; ctx = ctx }
      in-sh = sacty-shape =<< rt
      bt = bt <$> rt
  R.put (PS.kst ps)
  iv ← kt-fresh "iv_"
  let iv-type = vArg (def (quote Fin) (vArg l ∷ []))
  l ← kompile-term l vars
  b ← kompile-term e $ vars ++ [(iv , iv-type)]
  return $ "with { (. <= " ⊕ iv ⊕ " <= .): " ⊕ b ⊕ "; }: genarray ([" ⊕ l ⊕ "], zero_" ⊕ bt ⊕ " (" ⊕ in-sh ⊕ "))"

kompile-term (def (quote ix-tabulate) (arg _ d ∷ X ∷ arg _ (vLam x e) ∷ [])) vars = do
  iv ← kt-fresh "iv_"
  let iv-type = vArg (def (quote Fin) (vArg d ∷ []))
  d ← kompile-term d vars
  b ← kompile-term e $ vars ++ [(iv , iv-type)]
  return $ "with { (. <= " ⊕ iv ⊕ " <= .): " ⊕ b ⊕ "; }: genarray ([" ⊕ d ⊕ "], 0)"

-- Array stuff
kompile-term (def (quote sel) (_ ∷ _ ∷ _ ∷ _ ∷ arg _ a ∷ arg _ iv ∷ [])) vars = do
  a ← kompile-term a vars
  iv ← kompile-term iv vars
  return $ a ⊕ "[" ⊕ iv ⊕ "]"

kompile-term (def (quote ix-lookup) (_ ∷ _ ∷ arg _ iv ∷ arg _ el ∷ [])) vars = do
  iv ← kompile-term iv vars
  el ← kompile-term el vars
  return $ iv ⊕ "[" ⊕ el ⊕ "]"

kompile-term (def (quote V.lookup) (_ ∷ _ ∷ _ ∷ arg _ v ∷ arg _ i ∷ [])) vars = do
  v ← kompile-term v vars
  i ← kompile-term i vars
  return $ v ⊕ "[" ⊕ i ⊕ "]"

kompile-term (def (quote V.foldr) (_ ∷ _ ∷ ty₁ ∷ arg _ (vLam _ ty₂) ∷ arg _ len ∷ arg _ (hLam _ (def f args)) ∷ arg _ neut ∷ arg _ arr ∷ [])) vars = do
  let f = case list-find-el ((RN._≟ f) ∘ proj₁) SAC-funs of λ where
            (just (_ , f)) → f
            _ → nnorm $ showName f
  len ← kompile-term len vars
  neut ← kompile-term neut vars
  arr ← kompile-term arr vars
  iv ← kt-fresh "iv_"
  return $ "with { ([0] <= " ⊕ iv ⊕ " < [" ⊕ len ⊕ "]): " ⊕ arr ⊕ "[" ⊕ iv ⊕ "]; }: fold (" ⊕ f ⊕ ", " ⊕ neut ⊕ ")"

kompile-term (def (quote reduce-1d) (_ ∷ _ ∷ arg _ s ∷ arg _ (def f args) ∷ arg _ ε ∷ arg _ a ∷ [])) vars = do
  let f = case list-find-el ((RN._≟ f) ∘ proj₁) SAC-funs of λ where
            (just (_ , f)) → f
            _ → nnorm $ showName f
  ε ← kompile-term ε vars
  a ← kompile-term a vars
  s ← kompile-term s vars
  iv ← kt-fresh "iv_"
  return $ "with { ([0] <= " ⊕ iv ⊕ " < " ⊕ s ⊕ "): " ⊕ a ⊕ "[" ⊕ iv ⊕ "]; }: fold (" ⊕ f ⊕ ", " ⊕ ε ⊕ ")"

kompile-term (def (quote reduce-1d) (Xa@(arg _ X) ∷ Ya@(arg _ Y) ∷ arg _ s ∷ arg _ L@(vLam a (vLam b e)) ∷ arg _ ε ∷ arg _ arr ∷ [])) vars = do
  a ← kt-fresh "a"
  b ← kt-fresh "b"

  kst ← R.get
  let (Xs , ps) = kompile-ty X false $ record defaultPS{ kst = kst; ctx = te-to-lvt vars }
      (Ys , ps) = kompile-ty Y false $ record ps { ctx = PS.ctx ps ++ [ a ∈ Xs ~ Xa ] }
  R.put $ PS.kst ps
  t ← kompile-term e $ vars ++ (a , Xa) ∷ (b , Ya) ∷ [] -- (PS.ctx ps ++ [ b ∈ Ys ~ Ya ])

  kst ← R.get
  fname ← kt-fresh "lifted_"
  let e , ps = kompile-ctx vars $ record defaultPS{ kst = kst }
      vs     = L.map {B = String × Prog} (λ where (v ∈ τ ~ _) → (v , (sacty-to-string <$> τ))) $′ PS.ctx ps
      vs     = vs ++ ((a , (sacty-to-string <$> Xs)) ∷ (b , (sacty-to-string <$> Ys)) ∷ [])
      vs     = ok ", " ++/ L.map (λ where (v , τ) → τ ⊕ " " ⊕ v) vs
      fun    = (sacty-to-string <$> Ys) ⊕ " " ⊕ fname ⊕ "(" ⊕ vs ⊕ ") "
             ⊕ "{ return " ⊕ t ⊕ "; }"

  -- error out in case our current context was broken
  (ok _) ← return e where (error x) → return (error x)

  --R.modify $! λ k → record k{ defs = (KS.defs k ⊕_) $! fun }
  kst ← R.get
  R.put $! record kst{ defs = KS.defs kst ⊕ fun }

  let part-app = fname ⊕ "(" ⊕ ", " ++/ L.map proj₁ vars ⊕ ")"
  ε ← kompile-term ε vars
  arr ← kompile-term arr vars
  s ← kompile-term s vars
  iv ← kt-fresh "iv_"
  return $! "with { ([0] <= " ⊕ iv ⊕ " < " ⊕ s ⊕ "): " ⊕ arr ⊕ "[" ⊕ iv ⊕ "]; }: fold (" ⊕ part-app ⊕ ", " ⊕ ε ⊕ ")"

  where
    kompile-ctx : Telescope → SPS (Err ⊤)
    kompile-ctx [] = return $ ok tt
    kompile-ctx ((v , t@(arg i x)) ∷ ctx) = do
      (ok τ) ← kompile-ty x false where (error x) → return $ error x
      P.modify λ k → record k{ ctx = PS.ctx k ++ [ v ∈ ok τ ~ t ] }
      kompile-ctx ctx

-- A bunch of functions that are mapped to id in sac
-- XXX get rid of id call, only keeping for debugging purposes.
kompile-term (def (quote F.fromℕ<) args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 3 args (# 0 ∷ []) vars
kompile-term (def (quote F.toℕ)    args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 2 args (# 1 ∷ []) vars
kompile-term (def (quote subst-ar) args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 7 args (# 6 ∷ []) vars
kompile-term (def (quote subst-ix) args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 5 args (# 4 ∷ []) vars
kompile-term (def (quote ▾_)       args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 6 args (# 5 ∷ []) vars
kompile-term (def (quote ▴_)       args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 6 args (# 5 ∷ []) vars
kompile-term (def (quote a→ix)     args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 4 args (# 1 ∷ []) vars
kompile-term (def (quote a→s)      args) vars = ("id (" ⊕_) ∘ (_⊕ ")") <$> kompile-arglist 2 args (# 1 ∷ []) vars

kompile-term (def (quote Array.Base.magic-fin) args) vars = return $ ok "unreachable ()"

kompile-term (def (quote Array.Base.off→idx) args) vars = do
  args ← kompile-arglist 3 args (# 1 ∷ # 2 ∷ []) vars
  return $ "off_to_idx (" ⊕ args ⊕ ")"
kompile-term (def (quote _↑_) args) vars = do
  args ← kompile-arglist 7 args (# 4 ∷ # 5 ∷ []) vars
  return $ "take (" ⊕ args ⊕ ")"
kompile-term (def (quote _↓_) args) vars = do
  args ← kompile-arglist 7 args (# 4 ∷ # 5 ∷ []) vars
  return $ "drop (" ⊕ args ⊕ ")"

kompile-term (def (quote _↑⟨_⟩_) args) vars = do
  args ← kompile-arglist 7 args (# 4 ∷ # 5 ∷ # 6 ∷ []) vars
  return $ "overtake (" ⊕ args ⊕ ")"
kompile-term (def (quote _-↑⟨_⟩_) args) vars = do
  args ← kompile-arglist 7 args (# 4 ∷ # 5 ∷ # 6 ∷ []) vars
  return $ "overtake_back (" ⊕ args ⊕ ")"

-- The last pattern in the list of `def` matches
kompile-term (def n []) _ =
  kt $ "attempting to compile `" ++ showName n ++ "` as function with 0 arguments"

kompile-term (def n args@(_ ∷ _)) vars with list-find-el ((RN._≟ n) ∘ proj₁) SAC-funs
... | just (_ , f) = do
  let l = L.length args
  args ← kompile-arglist l args (mk-mask l) vars
  return $ f ⊕ " (" ⊕ args ⊕ ")"

... | nothing  = do
  R.modify λ k → record k { funs = KS.funs k ++ [ n ] }
  let n = nnorm $ showName n
      l = L.length args
  args ← kompile-arglist l args (mk-mask l) vars
  return $ n ⊕ " (" ⊕ args ⊕ ")"

kompile-term t vctx = kt $ "failed to compile term `" ++ showTerm t ++ "`"


module Properties.Step where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Agda.Builtin.Float using (primFloatPlus; primFloatMinus; primFloatTimes; primFloatDiv)
open import FFI.Data.Maybe using (just; nothing)
open import Luau.Heap using (Heap; _[_]; alloc; ok; function_is_end)
open import Luau.Syntax using (Block; Expr; nil; var; addr; function_is_end; block_is_end; _$_; local_←_; return; done; _∙_; name; fun; arg; number; binexp; +)
open import Luau.OpSem using (_⊢_⟶ᴱ_⊣_; _⊢_⟶ᴮ_⊣_; app₁ ; app₂ ; beta; function; block; return; done; local; subst; binOpEval; evalBinOp; binOp₁; binOp₂)
open import Luau.RuntimeError using (RuntimeErrorᴱ; RuntimeErrorᴮ; TypeMismatch; UnboundVariable; SEGV; app₁; app₂; block; local; return; bin₁; bin₂)
open import Luau.RuntimeType using (function; number)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Luau.Value using (nil; addr; val; number)
open import Properties.Remember using (remember; _,_)

data StepResultᴮ {a} (H : Heap a) (B : Block a) : Set
data StepResultᴱ {a} (H : Heap a) (M : Expr a) : Set

data StepResultᴮ H B where
  step : ∀ H′ B′ → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → StepResultᴮ H B
  return : ∀ V {B′} → (B ≡ (return (val V) ∙ B′)) → StepResultᴮ H B
  done : (B ≡ done) → StepResultᴮ H B
  error : (RuntimeErrorᴮ H B) → StepResultᴮ H B

data StepResultᴱ H M where
  step : ∀ H′ M′ → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → StepResultᴱ H M
  value : ∀ V → (M ≡ val V) → StepResultᴱ H M
  error : (RuntimeErrorᴱ H M) → StepResultᴱ H M

stepᴱ : ∀ {a} H M → StepResultᴱ {a} H M
stepᴮ : ∀ {a} H B → StepResultᴮ {a} H B

stepᴱ H nil = value nil refl
stepᴱ H (var x) = error (UnboundVariable x)
stepᴱ H (addr a) = value (addr a) refl
stepᴱ H (number x) = value (number x) refl
stepᴱ H (M $ N) with stepᴱ H M
stepᴱ H (M $ N) | step H′ M′ D = step H′ (M′ $ N) (app₁ D)
stepᴱ H (_ $ N) | value V refl with stepᴱ H N
stepᴱ H (_ $ N) | value V refl | step H′ N′ s = step H′ (val V $ N′) (app₂ s)
stepᴱ H (_ $ _) | value nil refl | value W refl = error (app₁ (TypeMismatch function nil λ()))
stepᴱ H (_ $ _) | value (number n) refl | value W refl = error (app₁ (TypeMismatch function (number n) λ()))
stepᴱ H (_ $ _) | value (addr a) refl | value W refl with remember (H [ a ])
stepᴱ H (_ $ _) | value (addr a) refl | value W refl  | (nothing , p) = error (app₁ (SEGV a p))
stepᴱ H (_ $ _) | value (addr a) refl | value W refl  | (just(function F is B end) , p) = step H (block fun F is B [ W / name (arg F) ]ᴮ end) (beta p)
stepᴱ H (M $ N) | value V p | error E = error (app₂ E)
stepᴱ H (M $ N) | error E = error (app₁ E)
stepᴱ H (block b is B end) with stepᴮ H B
stepᴱ H (block b is B end) | step H′ B′ D = step H′ (block b is B′ end) (block D)
stepᴱ H (block b is (return _ ∙ B′) end) | return V refl = step H (val V) return
stepᴱ H (block b is done end) | done refl = step H nil done
stepᴱ H (block b is B end) | error E = error (block b E)
stepᴱ H (function F is C end) with alloc H (function F is C end)
stepᴱ H function F is C end | ok a H′ p = step H′ (addr a) (function p)
stepᴱ H (binexp x op y) with stepᴱ H x
stepᴱ H (binexp x op y) | value x′ refl with stepᴱ H y
stepᴱ H (binexp x op y) | value (number x′) refl | value (number y′) refl = step H (number (evalBinOp x′ op y′)) binOpEval
stepᴱ H (binexp x op y) | value (number x′) refl | step H′ y′ s = step H′ (binexp (number x′) op y′) (binOp₂ s)
stepᴱ H (binexp x op y) | value (number x′) refl | error E = error (bin₂ E)
stepᴱ H (binexp x op y) | value nil refl | _ = error (bin₁ (TypeMismatch number nil λ()))
stepᴱ H (binexp x op y) | _ | value nil refl = error (bin₂ (TypeMismatch number nil λ()))
stepᴱ H (binexp x op y) | value (addr a) refl | _ = error (bin₁ (TypeMismatch number (addr a) λ()))
stepᴱ H (binexp x op y) | _ | value (addr a) refl = error (bin₂ (TypeMismatch number (addr a) λ()))
stepᴱ H (binexp x op y) | step H′ x′ s = step H′ (binexp x′ op y) (binOp₁ s)
stepᴱ H (binexp x op y) | error E = error (bin₁ E)

stepᴮ H (function F is C end ∙ B) with alloc H (function F is C end)
stepᴮ H (function F is C end ∙ B) | ok a H′ p = step H′ (B [ addr a / fun F ]ᴮ) (function p)
stepᴮ H (local x ← M ∙ B) with stepᴱ H M
stepᴮ H (local x ← M ∙ B) | step H′ M′ D = step H′ (local x ← M′ ∙ B) (local D)
stepᴮ H (local x ← _ ∙ B) | value V refl = step H (B [ V / name x ]ᴮ) subst
stepᴮ H (local x ← M ∙ B) | error E = error (local x E)
stepᴮ H (return M ∙ B) with stepᴱ H M
stepᴮ H (return M ∙ B) | step H′ M′ D = step H′ (return M′ ∙ B) (return D)
stepᴮ H (return _ ∙ B) | value V refl = return V refl
stepᴮ H (return M ∙ B) | error E = error (return E)
stepᴮ H done = done refl


module Main where

open import Category.Functor
open import Category.Monad
open import Data.Unit
open import Data.Container.Indexed
open import Data.Maybe
open import Data.Product
open import IO.Primitive hiding (_>>=_)

open import Signature
open import Sodium
open import Model
open import View

------------------------------------------------------------------------

postulate
  eEvent : Event VtyEvent
  bMode  : Behaviour Mode

eCommand : Event (∃ (Command Hårss))
eCommand = filterJust (snapshot (λ v m → forget (vtyToCmd v m))
                                eEvent bMode)
  where
  forget : ∀ {m} → Maybe (Command Hårss m) → Maybe (∃ (Command Hårss))
  forget nothing  = nothing
  forget (just c) = just (_ , c)

eResponse : Event (∃₂ λ m (c : Command Hårss m) → Response Hårss c)
eResponse = executeAsyncIO (snapshot
  (λ c m → fmap (forget c) (cmdToResp (proj₂ c) m)) eCommand bModel)
  where
  forget : (c : ∃ (Command Hårss)) → Response Hårss (proj₂ c) →
           ∃₂ λ m (c : Command Hårss m) → Response Hårss c
  forget (m , c) r = m , (c , r)

  postulate
    fmap : ∀ {A B} → (A → B) → IO A → IO B
    bModel : Behaviour Model

bModel : Reactive (Behaviour Model)
bModel = accum initialModel (update <$> eResponse)
  where
  open RawFunctor eventFunctor

  update : (∃₂ λ m (c : Command Hårss m) →
           (Response Hårss c)) → Model → Model
  update (._ , moveP d    , _)        m = moveModel d m
  update (._ , promptP p  , _)        m = setMode (input p) m
  update (._ , putCharP c , _)        m = addCharToBuffer c m
  update (._ , doneP , (s , search))  m = searchModel s m
  update (._ , doneP , (s , addFeed)) m = addFeedToModel s m
  update (._ , fetchP     , f)        m = setCurrentFeed m f
  update (._ , searchNextP , s)       m = searchNextModel s m

setup : Reactive (IO ⊤)
setup =
  bModel >>= λ m →
  listen (updates m) view
  where
  open RawMonad reactiveMonad


module README where

------------------------------------------------------------------------
-- Core definitions
------------------------------------------------------------------------

import Generics.Prelude

-- Generics.Telescope introduces an encoding for telescopes,
-- along with functions to manipulate indexed functions and families.
import Generics.Telescope

-- Generics.Desc introduces the core universe of descriptions for datatypes.
import Generics.Desc

-- Generics.HasDesc defines the HasDesc record,
-- bridging the gap between descriptions of datatypes
-- and their concrete Agda counterpart.
import Generics.HasDesc

-- Generics.Reflection implements the deriveDesc macro
-- to automatically derive an instance of HasDesc for most datatypes.
import Generics.Reflection

------------------------------------------------------------------------
-- Generic constructions
------------------------------------------------------------------------

-- Generic show implemetation
import Generics.Constructions.Show

-- Datatype-generic case analysis principle
import Generics.Constructions.Case

-- Datatype-generic decidable equality
import Generics.Constructions.DecEq

-- Datatype-generic induction principle,
-- on described datatypes only
import Generics.Constructions.Induction

-- Datatype-generic elimination principle
import Generics.Constructions.Elim

-- WIP Datatype-generic injectivity of constructors
import Generics.Constructions.NoConfusion


-- An ATP conjecture must be used with postulates.

-- This error is detected by Syntax.Translation.ConcreteToAbstract.

module ATPBadConjecture1 where

data Bool : Set where
  false true : Bool

{-# ATP prove false #-}


{-# OPTIONS --cubical --sized-types --type-in-type #-} -- Oh my Nathaniel Hawthorne

module n2o.Network.Internal where

open import proto.Base
open import proto.Map
open import proto.IO

{-# FOREIGN GHC import Network.N2O.Types #-}

postulate
  Header : Set

data Event (A : Set) : Set where
  Init      :     Event A
  Message   : A → Event A
  Terminate :     Event A

data Result (A : Set) : Set where
  Reply   : A → Result A
  Ok      :     Result A
  Unknown :     Result A
  Empty   :     Result A

record Request : Set where
  constructor Req
  field
    reqPath : ByteString Strict
    reqMeth : ByteString Strict
    reqVers : ByteString Strict
    reqHead : List Header

mutual
  data N2OT (S : Set) (M : Set → Set) (A : Set) : Set where
    runN2O : S → M A → N2OT S M A

  N2O : (F : Set → Set) (A : Set) → Set → Set
  N2O F A = N2OT (State F A) IO
  -- N2O F A = ReaderT (IORef (Context F A)) IO

  {-# NO_POSITIVITY_CHECK #-}
  record Context (F : Set → Set) (A : Set) : Set where
    constructor mkCx
    field
      cxHandler    : Event A → N2O F A (Result A) → Context F A   -- TODO : Strict Positivity
      cxRequest    : Request
      cxMiddleware : List (Context F A → Context F A)             -- TODO : Strict Positivity
      cxProtos     : List (Proto F A)                             -- TODO : Strict Positivity
      cxActions    : ByteString Strict
      cxDict       : Map (ByteString Strict) (ByteString Strict)

  State : (F : Set → Set) (A : Set) → Set
  State F A = IORef (Context F A) -- TODO : comp

  record Proto (F : Set → Set) (A : Set) : Set where
    inductive
    constructor proto
    field
      protoInfo : F A → N2O F A (Result (F A))

{-# COMPILE GHC Context = data Network.N2O.Types.Context (mkCx)                                      #-}
{-# COMPILE GHC  Header = type Network.N2O.Types.Header                                              #-}
{-# COMPILE GHC    N2OT = data Network.N2O.Types.N2OT    ( runN2O                                  ) #-}
{-# COMPILE GHC   Proto = data Network.N2O.Types.Proto   ( protoInfo                               ) #-}
{-# COMPILE GHC   Event = data Network.N2O.Types.Event   ( Init      | Message | Terminate         ) #-}
{-# COMPILE GHC Request = data Network.N2O.Types.Request ( Req                                     ) #-}
{-# COMPILE GHC  Result = data Network.N2O.Types.Result  ( Reply     | Ok      | Unknown   | Empty ) #-}


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
-- This module defines an intermediate (between an implementation and Abstract) notion
-- of a system state.  The goal is to enable proving for a particular implementation
-- the properties required to provide to Abstract.Properties in order to get the high
-- level correctness conditions, while moving the obligations for the implementation
-- closer to notions more directly provable for an implementation.  However, as our
-- experience has developed with this, it seems that this was not a very effective
-- choice, as it leaves too much burden on the implementation (e.g., proving
-- ∈QC⇒HasBeenSent). Therefore, ...
--
-- TODO-3: Revisit assumptions of the IntermediateSystemState to enable more proof work
-- to be done under Concrete, which can be used by multiple implementations.  As it
-- currently stands, we have specific notions under LibraBFT.Impl that possibly should
-- be provided as module parameters to LibraBFT.Concrete (including IsValidVote and
-- α-ValidVote)

open import LibraBFT.Prelude
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open WithAbsVote

module LibraBFT.Concrete.Intermediate
    (𝓔 : EpochConfig)
    (𝓥 : VoteEvidence 𝓔)
   where
   open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 𝓥

   -- Since the invariants we want to specify (votes-once and preferred-round-rule),
   -- are predicates over a /System State/, we must factor out the necessary
   -- functionality.
   --
   -- An /IntermediateSystemState/ supports a few different notions; namely,
   record IntermediateSystemState (ℓ : Level) : Set (ℓ+1 ℓ) where
     field
       -- A notion of membership of records
       InSys : Record → Set ℓ

       -- A predicate about whether votes have been transfered
       -- amongst participants
       HasBeenSent : Vote → Set ℓ

       -- Such that, the votes that belong to honest participants inside a
       -- QC that exists in the system must have been sent
       ∈QC⇒HasBeenSent : ∀{q α} → InSys (Q q) → Meta-Honest-Member α
                       → (va : α ∈QC q) → HasBeenSent (∈QC-Vote q va)


open import Class.Listable
open import Data.List.Relation.Unary.All
open import Data.List.Relation.Unary.AllPairs
open import Data.List.Relation.Unary.Any
import Data.Vec.Recursive
import Data.Vec.Recursive.Categorical

open import Prelude

module Theory.PrimMeta where

private
  variable
    A B C : Set
    M : Set → Set

data PrimMeta : Set where
  EvalStmt      : PrimMeta
  ShellCmd      : PrimMeta
  CheckTerm     : PrimMeta
  Parse         : PrimMeta
  Normalize     : PrimMeta
  HeadNormalize : PrimMeta
  InferType     : PrimMeta

private
  variable
    m : PrimMeta

instance
  PrimMeta-Eq : Eq PrimMeta
  PrimMeta-Eq = Listable.Listable→Eq record
    { listing = EvalStmt ∷ ShellCmd ∷ CheckTerm ∷ Parse ∷ Normalize ∷ HeadNormalize ∷ InferType ∷ []
    ; unique = ((λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ []) ∷
                 ((λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ []) ∷
                 ((λ ()) ∷ (λ ()) ∷ (λ ()) ∷ (λ ()) ∷ []) ∷
                 ((λ ()) ∷ (λ ()) ∷ (λ ()) ∷ []) ∷
                 ((λ ()) ∷ (λ ()) ∷ []) ∷ ((λ ()) ∷ []) ∷ [] ∷ []
    ; complete = λ where
        EvalStmt      → here refl
        ShellCmd      → there (here refl)
        CheckTerm     → there (there (here refl))
        Parse         → there (there (there (here refl)))
        Normalize     → there (there (there (there (here refl))))
        HeadNormalize → there (there (there (there (there (here refl)))))
        InferType     → there (there (there (there (there (there (here refl)))))) }

  PrimMeta-EqB : EqB PrimMeta
  PrimMeta-EqB = Eq→EqB

  PrimMeta-Show : Show PrimMeta
  PrimMeta-Show = record { show = helper }
    where
      helper : PrimMeta → String
      helper EvalStmt      = "EvalStmt"
      helper ShellCmd      = "ShellCmd"
      helper CheckTerm     = "CheckTerm"
      helper Parse         = "Parse"
      helper Normalize     = "Normalize"
      helper HeadNormalize = "HeadNormalize"
      helper InferType     = "InferType"

primMetaArity : PrimMeta → ℕ
primMetaArity EvalStmt      = 1
primMetaArity ShellCmd      = 2
primMetaArity CheckTerm     = 2
primMetaArity Parse         = 3
primMetaArity Normalize     = 1
primMetaArity HeadNormalize = 1
primMetaArity InferType     = 1

primMetaArgs : Set → PrimMeta → Set
primMetaArgs A m  = A Data.Vec.Recursive.^ (primMetaArity m)

mapPrimMetaArgs : (A → B) → primMetaArgs A m → primMetaArgs B m
mapPrimMetaArgs f = Data.Vec.Recursive.map f _

traversePrimMetaArgs : {{Monad M}} → (A → M B) → primMetaArgs A m → M (primMetaArgs B m)
traversePrimMetaArgs {{mon}} = Data.Vec.Recursive.Categorical.mapM mon

primMetaArgs-Show : (A → String) → primMetaArgs A m → String
primMetaArgs-Show showA = Data.Vec.Recursive.foldr "" showA (λ _ a s → showA a + s) _

primMetaArgsZipWith : (A → B → C) → primMetaArgs A m → primMetaArgs B m → primMetaArgs C m
primMetaArgsZipWith f x y = Data.Vec.Recursive.zipWith f _ x y

primMetaArgsSequence : {{Monad M}} → primMetaArgs (M A) m → M (primMetaArgs A m)
primMetaArgsSequence {{mon}} = Data.Vec.Recursive.Categorical.sequenceM mon

primMetaArgsAnd : primMetaArgs Bool m → Bool
primMetaArgsAnd = Data.Vec.Recursive.foldr {P = const Bool} true id (const _∧_) _


module Agda.Builtin.TrustMe where

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Erase

private
  postulate
    unsafePrimTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y

primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y
primTrustMe = primEraseEquality unsafePrimTrustMe

{-# DISPLAY primEraseEquality unsafePrimTrustMe = primTrustMe #-}


open import Agda.Builtin.Nat

record R : Set where
  field
    x : Nat

open R {{...}}

f₁ f₂ : R

-- This is fine.
x ⦃ f₁ ⦄ = 0

-- THIS WORKS BUT MAKES NO SENSE!!!
f₂ ⦃ .x ⦄ = 0


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
import      LibraBFT.Impl.Consensus.ConsensusTypes.Properties.QuorumCert as QC
import      LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert            as QuorumCert
open import LibraBFT.Impl.Consensus.ConsensusTypes.SyncInfo as SI
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.Impl.Types.BlockInfo as BI
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

open Invariants
open RoundManagerTransProps

module LibraBFT.Impl.Consensus.ConsensusTypes.Properties.SyncInfo where

module verifyMSpec (self : SyncInfo) (validator : ValidatorVerifier) where

  epoch = self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biEpoch

  record SIVerifyProps (pre : RoundManager) : Set where
    field
      sivpEp≡       : epoch ≡ self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biEpoch
      sivpTcEp≡     : maybeS (self ^∙ siHighestTimeoutCert) Unit $ λ tc -> epoch ≡ tc ^∙ tcEpoch
      sivpHqc≥Hcc   : (self ^∙ siHighestQuorumCert) [ _≥_ ]L self ^∙ siHighestCommitCert at qcCertifiedBlock ∙ biRound
      sivpHqc≢empty : self ^∙ siHighestCommitCert ∙ qcCommitInfo ≢ BI.empty
      sivpHqcVer    : QC.Contract (self ^∙ siHighestQuorumCert) validator
      sivpHccVer    : maybeS (self ^∙ sixxxHighestCommitCert) Unit $ λ qc → QC.Contract qc validator
      -- Waiting on TimeoutCertificate Contract : sivpHtcVer    : maybeS (self ^∙ siHighestTimeoutCert  ) Unit $ λ tc → {!!}

  module _ (pre : RoundManager) where

   record Contract (r : Either ErrLog Unit) (post : RoundManager) (outs : List Output) : Set where
     constructor mkContract
     field
       -- General properties / invariants
       rmInv         : Preserves RoundManagerInv pre post
       noStateChange : pre ≡ post
       -- Output
       noMsgOuts     : OutputProps.NoMsgs outs
       -- Syncing
       syncResCorr   : r ≡ Right unit → SIVerifyProps pre
       -- NOTE: Since the output contains no messages and the state does not
       -- change, nothing needs to be said about the quorum certificats in the
       -- output and post state

   verifyCorrect : SI.verify self validator ≡ Right unit → SIVerifyProps pre
   verifyCorrect verify≡
      with epoch ≟ self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biEpoch
   ...| no  ep≢ = absurd (Left _ ≡ Right _) case verify≡ of λ ()
   ...| yes sivpEp≡
      with sivpTcEp≡ verify≡
      where
      sivpTcEp≡ : SI.verify.step₁ self validator ≡ Right unit
                  → maybeS (self ^∙ siHighestTimeoutCert) Unit (\tc -> epoch ≡ tc ^∙ tcEpoch)
                    × SI.verify.step₂ self validator ≡ Right unit
      sivpTcEp≡ verify≡₁
         with self ^∙ siHighestTimeoutCert
      ...| nothing = unit , verify≡₁
      ...| just tc
         with epoch ≟ tc ^∙ tcEpoch
      ...| yes tce≡ = tce≡ , verify≡₁
      ...| no  tce≢ = absurd (Left _ ≡ Right _) case verify≡₁ of λ ()
   ...| sivpTcEp≡ , verify≡₂
      with sivpHqc≥Hcc verify≡₂
      where
      sivpHqc≥Hcc : (SI.verify.step₂ self validator ≡ Right unit)
                    → (self ^∙ siHighestQuorumCert) [ _≥_ ]L self ^∙ siHighestCommitCert at qcCertifiedBlock ∙ biRound
                      × SI.verify.step₃ self validator ≡ Right unit
      sivpHqc≥Hcc verify≡₂
         with    self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biRound
              ≥? self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biRound
      ...| yes hqc≥hcc = hqc≥hcc , verify≡₂
      ...| no  hqc<hcc = absurd Left _ ≡ Right _ case verify≡₂ of λ ()
   ...| sivpHqc≥Hcc , verify≡₃
      with sivpHqc≢empty verify≡₃
      where
      sivpHqc≢empty : (SI.verify.step₃ self validator ≡ Right unit)
                      → self ^∙ siHighestCommitCert ∙ qcCommitInfo ≢ BI.empty
                        × SI.verify.step₄ self validator ≡ Right unit
      sivpHqc≢empty verify≡₃
         with self ^∙ siHighestCommitCert ∙ qcCommitInfo ≟ BI.empty
      ...| no  ≢empty = ≢empty , verify≡₃
      ...| yes ≡empty = absurd Left _ ≡ Right _ case verify≡₃ of λ ()
   ...| sivpHqc≢empty , verify≡₄
      with sivpHqcVer verify≡₄
      where
      sivpHqcVer : (SI.verify.step₄ self validator ≡ Right unit)
                   → QC.Contract (self ^∙ siHighestQuorumCert) validator
                     × SI.verify.step₅ self validator ≡ Right unit
      sivpHqcVer verify≡₄
         with  QuorumCert.verify (self ^∙ siHighestQuorumCert)  validator | inspect
              (QuorumCert.verify (self ^∙ siHighestQuorumCert)) validator
      ...| Left  _    | _ = absurd Left _ ≡ Right _ case verify≡₄ of λ ()
      ...| Right unit | [ R ]
         with QC.contract (self ^∙ siHighestQuorumCert) validator (Right unit) refl R
      ...| qcCon = qcCon , verify≡₄
   ...| sivpHqcVer , verify≡₅
      with sivpHccVer verify≡₅
      where
      sivpHccVer : (SI.verify.step₅ self validator ≡ Right unit)
                   → (maybeS (self ^∙ sixxxHighestCommitCert) Unit $ λ qc → QC.Contract qc validator)
                     × SI.verify.step₆ self validator ≡ Right unit
      sivpHccVer verify≡₅
         with self ^∙ sixxxHighestCommitCert
      ...| nothing = unit , verify≡₅
      ...| just qc
         with QuorumCert.verify  qc  validator | inspect
              (QuorumCert.verify qc) validator
      ...| Left _ | _ = absurd Left _ ≡ Right _ case verify≡₅ of λ ()
      ...| Right unit | [ R ] = QC.contract qc validator (Right unit) refl R , verify≡₅
   ...| sivpHccVer , verify≡₆ =
   -- TODO: continue case analysis for remaining fields
     record
     { sivpEp≡       = sivpEp≡
     ; sivpTcEp≡     = sivpTcEp≡
     ; sivpHqc≥Hcc   = sivpHqc≥Hcc
     ; sivpHqc≢empty = sivpHqc≢empty
     ; sivpHqcVer    = sivpHqcVer
     ; sivpHccVer    = sivpHccVer
     -- ; sivpHtcVer =
     }

   contract : ∀ Q → (RWS-Post-⇒ Contract Q) → LBFT-weakestPre (SI.verifyM self validator) Q pre
   contract Q pf = LBFT-⇒ (SI.verifyM self validator) pre (mkContract id refl refl verifyCorrect) pf


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.ImplShared.Base.Types

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open import LibraBFT.Concrete.Records as LCR
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Util.Crypto
open import Optics.All
open import Util.KVMap
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude
open import Yasm.Base

open        EpochConfig

-- This module contains placeholders for the future analog of the
-- corresponding VotesOnce property.  Defining the implementation
-- obligation and proving that it is an invariant of an implementation
-- is a substantial undertaking.  We are working first on proving the
-- simpler VotesOnce property to settle down the structural aspects
-- before tackling the harder semantic issues.
module LibraBFT.Concrete.Properties.PreferredRound (iiah : SystemInitAndHandlers ℓ-RoundManager ConcSysParms) (𝓔 : EpochConfig) where
 open        LibraBFT.ImplShared.Consensus.Types.EpochDep.WithEC
 import      LibraBFT.Abstract.Records         UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs
 import      LibraBFT.Abstract.Records.Extends UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Ext
 open import LibraBFT.Abstract.RecordChain     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Abstract.System          UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Concrete.Intermediate                      𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Concrete.Obligations.PreferredRound        𝓔 (ConcreteVoteEvidence 𝓔)
 open        SystemTypeParameters ConcSysParms
 open        SystemInitAndHandlers iiah
 open        ParamsWithInitAndHandlers iiah
 open import LibraBFT.ImplShared.Util.HashCollisions iiah
 open import LibraBFT.Concrete.Properties.Common iiah 𝓔
 open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms iiah PeerCanSignForPK PeerCanSignForPK-stable

 open PerEpoch    𝓔
 open WithAbsVote 𝓔
 open LCR.WithEC  𝓔
 open PerState
 open PerReachableState
 open IntermediateSystemState
 open All-InSys-props

 Block-RC-AllInSys : Abs.Vote → SystemState → Set
 Block-RC-AllInSys vabs st = ∃[ b ] ( Abs.bId b ≡ abs-vBlockUID vabs
                                    × Σ (RecordChain (Abs.B b)) (All-InSys (InSys (intSystemState st))))

 ImplObligation-RC : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation-RC =
   ∀{pid s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m} → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v ⊂Msg m → send m ∈ outs
   → (sig : WithVerSig pk v)
   → 0 < v ^∙ vRound
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre))
   → let post = StepPeer-post {pre = pre} (step-honest sps)
     in (pcs4 : PeerCanSignForPK post v pid pk)
        → ∃[ mbr ] ( getPubKey 𝓔 mbr ≡ pk
                   × Block-RC-AllInSys (α-ValidVote 𝓔 v mbr) post)

 -- For PreferredRound, we have two implementation obligations, one for when v is sent by the
 -- step and v' has been sent before, and one for when both are sent by the step.
 ImplObligation₁ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₁ =
   ∀{pid pid' s' outs pk}{pre : SystemState}
   → (r : ReachableSystemState pre)
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → let post = StepPeer-post {pre = pre} (step-honest sps) in
     ∀{mbr v vabs m v' v'abs m'}
   → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v'  ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig'))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre))
   → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk
   -- And if there exists another v' that has been sent before
   → v ⊂Msg m → (pid' , m) ∈ (msgPool pre)
   → (sig : WithVerSig pk v) → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig))
   -- If v and v' share the same epoch
   → v ^∙  vEpoch ≡ v' ^∙ vEpoch
   -- and v is for a smaller round
   → v ^∙ vRound < v' ^∙ vRound
   -- and vabs* are the abstract Votes for v and v'
   → α-ValidVote 𝓔 v  mbr ≡ vabs
   → α-ValidVote 𝓔 v' mbr ≡ v'abs
   → (c2 : Cand-3-chain-vote (intSystemState post) vabs)
   -- then the round of the block that v' votes for is at least the round of
   -- the grandparent of the block that v votes for (i.e., the preferred round rule)
   → Σ (VoteParentData (intSystemState post) v'abs)
           (λ vp → Cand-3-chain-head-round (intSystemState post) c2 ≤ Abs.round (vpParent vp))
     ⊎ (VoteForRound∈ pk (v' ^∙ vRound) (v' ^∙ vEpoch) (v' ^∙ vProposedId) (msgPool pre))

 -- Similarly in case the same step sends both v and v'
 ImplObligation₂ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₂ =
   ∀{pid s' outs pk}{pre : SystemState}
   → (r  : ReachableSystemState pre)
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → let post = StepPeer-post {pre = pre} (step-honest sps) in
     ∀{mbr v vabs m v' v'abs m'}
   → Meta-Honest-PK pk
   -- For every vote v represented in a message output by the call
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre))
   → PeerCanSignForPK post v pid pk
   -- And if there exists another v' that is also new and valid
   → v' ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig'))
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre))
   → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk
   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound < v' ^∙ vRound
   → α-ValidVote 𝓔 v  mbr ≡ vabs
   → α-ValidVote 𝓔 v' mbr ≡ v'abs
   → (c2 : Cand-3-chain-vote (intSystemState post) vabs)
   → Σ (VoteParentData (intSystemState post) v'abs)
           (λ vp → Cand-3-chain-head-round (intSystemState post) c2 ≤ Abs.round (vpParent vp))

 module _ where
   open InSys iiah

   stepPreservesVoteParentData : ∀ {st0 st1 v}
     → Step st0 st1
     → (vpd : VoteParentData (intSystemState st0) v)
     → Σ (VoteParentData (intSystemState st1) v)
         λ vpd' → vpParent vpd' ≡ vpParent vpd
   stepPreservesVoteParentData {st0} {st1} theStep vpd
      with vpd
   ...| (record { vpV4B        = vpV4B
                ; vpBlock∈sys  = vpBlock∈sys
                ; vpParent     = vpParent
                ; vpParent∈sys = vpParent∈sys
                ; vpExt        = vpExt
                ; vpMaybeBlock = vpMaybeBlock
                }) = (record
                     { vpV4B        = vpV4B
                     ; vpBlock∈sys  = stable theStep vpBlock∈sys
                     ; vpParent     = vpParent
                     ; vpParent∈sys = stable theStep vpParent∈sys
                     ; vpExt        = vpExt
                     ; vpMaybeBlock = transp-vpmb vpMaybeBlock
                     }) , refl
     where transp-vpmb : ∀ {r}
                         → VoteParentData-BlockExt (intSystemState st0) r
                         → VoteParentData-BlockExt (intSystemState st1) r
           transp-vpmb vpParent≡I = vpParent≡I
           transp-vpmb (vpParent≡Q x x₁) = vpParent≡Q x (stable theStep x₁)

 module Proof
   (sps-corr   : StepPeerState-AllValidParts)   -- Bring in newMsg⊎msgSentB4
   (Impl-bsvr  : ImplObl-bootstrapVotesRound≡0)
   (Impl-nvr≢0 : ImplObl-NewVoteRound≢0)
   (Impl-∈BI?  : (sig : Signature) → Dec (∈BootstrapInfo bootstrapInfo sig))
   (Impl-RC    : ImplObligation-RC)
   (Impl-IRO   : IncreasingRoundObligation)
   (Impl-PR1   : ImplObligation₁)
   (Impl-PR2   : ImplObligation₂)
    where
  module _ {st : SystemState}(r : ReachableSystemState st) (𝓔-∈sys : EpochConfig∈Sys st 𝓔) where
   open        Structural sps-corr
   open        ConcreteCommonProperties st r sps-corr Impl-bsvr Impl-nvr≢0

   α-ValidVote-trans : ∀ {pk mbr vabs pool} (v : Vote)
                     → α-ValidVote 𝓔 v mbr ≡ vabs
                     → (vfr : VoteForRound∈ pk (v ^∙ vRound) (v ^∙ vEpoch)
                                            (v ^∙ vProposedId) pool)
                     → α-ValidVote 𝓔 (msgVote vfr) mbr ≡ vabs
   α-ValidVote-trans v₁ refl vfr
     with msgRound≡ vfr | msgEpoch≡ vfr | msgBId≡ vfr
   ...| refl | refl | refl = refl

   0<rnd⇒¬BootStrap : ∀ {pk rnd bid pool}
                      → (v4r : VoteForRound∈ pk rnd (epoch 𝓔) bid pool)
                      → 0 < rnd
                      → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature $ msgSigned v4r))
   0<rnd⇒¬BootStrap v4r 0<r rewrite sym (msgRound≡ v4r) = ⊥-elim ∘ (<⇒≢ 0<r) ∘ sym ∘ Impl-bsvr (msgSigned v4r)

   -- To prove this, we observe that cheaters can't introduce a VoteForRound∈ for an honest PK.  We
   -- will also require an additional implementation obligation.  It may simply be that Votes sent
   -- satisy IsValidVote, but the question is where do we maintain evidence that such a RecordChain
   -- exists for any Block we may vote for?
   voteForRound-RC : ∀ {pk vabs}{st : SystemState}
                     → Meta-Honest-PK pk
                     → ReachableSystemState st
                     → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool st))
                     → 0 < abs-vRound vabs
                     → Block-RC-AllInSys vabs st

   voteForRound-RC-mws : ∀ {pk vabs pre pid st' outs}
                       → Meta-Honest-PK pk
                       → ReachableSystemState pre
                       → (sp : StepPeer pre pid st' outs)
                       → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool $ StepPeer-post sp))
                       → MsgWithSig∈ pk (ver-signature $ msgSigned v4r) (msgPool pre)
                       → 0 < abs-vRound vabs
                       → Block-RC-AllInSys vabs (StepPeer-post sp)
   voteForRound-RC-mws {pk} {vabs} {pre} hpk preReach sps v4r mwsb4 0<r
      with sameSig⇒sameVoteData (msgSigned mwsb4) (msgSigned v4r) (msgSameSig mwsb4)
   ...| inj₁ hb = ⊥-elim $ meta-no-collision preReach hb -- TODO-2: refine sameSig⇒samevotedata to
                                                         -- enable tying collision to specific state
                                                         -- so we can use meta-no-collision-in-sys
   ...| inj₂ svd
      with msgSentB4⇒VoteRound∈ (msgSigned v4r) mwsb4'
         where
           mwsb4' : _
           mwsb4' rewrite
                    trans (cong (_^∙ vdProposed ∙ biEpoch) $ sym svd) (msgEpoch≡ v4r) |
                    msgBId≡ v4r |
                    msgSameSig mwsb4 = mwsb4
   ...| v4r' , refl
      with voteForRound-RC {pk} {vabs} hpk preReach v4r'' 0<r
         where
           v4r'' : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool pre)
           v4r'' rewrite sym (msgEpoch≡ v4r) | sym (msgRound≡ v4r) | sym (msgBId≡ v4r) = v4r'
   ...| b , refl , rc , ais = b , refl , rc , InSys.ais-stable iiah (step-peer sps) rc ais

   voteForRound-RC {pk} {vabs} {st} hpk (step-s preReach (step-peer (step-honest sps))) v4r 0<r
      with newMsg⊎msgSentB4 {sndr = msgSender v4r} preReach sps hpk (msgSigned v4r)
                            (0<rnd⇒¬BootStrap v4r 0<r)
                            (msg⊆ v4r)
                            (msg∈pool v4r)
   ...| inj₂ mwsb4 = voteForRound-RC-mws {vabs = vabs} hpk preReach (step-honest sps) v4r mwsb4 0<r
   ...| inj₁ (send∈outs , pcs4 , ¬sentb4) rewrite sym (msgRound≡ v4r)
      with Impl-RC preReach sps hpk (msg⊆ v4r) send∈outs (msgSigned v4r) 0<r ¬sentb4 pcs4
   ...| mbr , refl , b , bid≡ , rc∈sys  = b , (trans bid≡ $ msgBId≡ v4r) , rc∈sys
   voteForRound-RC {pk} {vabs} {st} hpk (step-s {pre = pre} preReach (step-peer (step-cheat {pid} x))) v4r 0<r
      with VoteRound∈⇒msgSent v4r
   ...| msgb4 , refl , refl
      with ¬cheatForgeNew {st = pre} (step-cheat x) refl unit hpk msgb4
                          (0<rnd⇒¬BootStrap v4r 0<r)
   ...| mwsb4 = voteForRound-RC-mws {vabs = vabs} hpk preReach (step-cheat x) v4r mwsb4 0<r

   open _α-Sent_
   open _BlockDataInjectivityProps_

   Abs2ImplCollision : ∀ {ab1 ab2 : Abs.Block}{post}
                     → (rPost : ReachableSystemState post)
                     → InSys (intSystemState post) (Abs.B ab1)
                     → InSys (intSystemState post) (Abs.B ab2)
                     → ab1 ≢ ab2
                     → Abs.bId ab1 ≡ Abs.bId ab2
                     → HashCollisionFound rPost
   Abs2ImplCollision rPost (ws ep≡1 m1∈pool (b∈NM {cb1} {pm1} refl refl bidcorr1))
                           (ws ep≡2 m2∈pool (b∈NM {cb2} {pm2} refl refl bidcorr2)) neq absIds≡ =
     msgmsgHC {r = rPost} (inP m1∈pool (inPM (inB {b = cb1}))) (inP m2∈pool (inPM (inB {b = cb2}))) hashes≡ bsls≢
     where
       -- TODO-2: Some of the properties should be factored out for reuse, maybe into Common?
       bIds≡ : _
       bIds≡ = trans (trans (α-Block-bid≡ cb1) absIds≡) (sym (α-Block-bid≡ cb2))

       hashes≡ : _
       hashes≡ = trans (trans bidcorr1 bIds≡) (sym bidcorr2)

       rnds≡ : ∀ {cb1 cb2} → (cb1 ^∙ bBlockData) BlockDataInjectivityProps (cb2 ^∙ bBlockData)
               → Abs.bRound (α-Block cb1) ≡ Abs.bRound (α-Block cb2)
       rnds≡ {cb1} {cb2} injprops = trans (sym (α-Block-rnd≡ cb1)) (trans (bdInjRound injprops) (α-Block-rnd≡ cb2))

       propBlock : ∀ {cb pm} → pm ^∙ pmProposal ≡ cb
                   → cb ^∙ bId ≡ pm ^∙ pmProposal ∙ bId
       propBlock refl = refl

       prevQCs≡ : ∀ {cb1 cb2}
                  → (cb1 ^∙ bBlockData) BlockDataInjectivityProps (cb2 ^∙ bBlockData)
                  → Abs.bPrevQC (α-Block cb1) ≡ Abs.bPrevQC (α-Block cb2)
       prevQCs≡ {cb1} {cb2} injprops
          with cb1 ^∙ bBlockData ∙ bdBlockType | inspect
               (cb1 ^∙_) (bBlockData ∙ bdBlockType)
       ...| Genesis      | [ R ] rewrite R                    = sym (α-Block-prevqc≡-Gen  {cb2} (bdInjBTGen injprops R))
       ...| Proposal _ _ | [ R ] rewrite R | bdInjVD injprops = sym (α-Block-prevqc≡-Prop {cb2} (trans (sym $ bdInjBTProp injprops R) R))
       ...| NilBlock     | [ R ] rewrite R | bdInjBTNil injprops R | bdInjVD injprops = refl

       bsls≢ : _
       bsls≢ _
          with hashBD-inj hashes≡
       ...| injprops = neq (Abs.Block-η
                              (rnds≡ {cb1} {cb2} injprops)
                              absIds≡
                              (prevQCs≡ {cb1} {cb2} injprops))

   Cand-3-chain-vote-b4 : ∀ {pk vabs}{pre : SystemState}{pid st' outs sp}
                          → Meta-Honest-PK pk
                          → ReachableSystemState pre
                          → let post = StepPeer-post {pid}{st'}{outs}{pre} sp in
                            (c2 : Cand-3-chain-vote (intSystemState post) vabs)
                            → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool pre))
                            → Σ (Cand-3-chain-vote (intSystemState pre) vabs)
                                 λ c2' → Cand-3-chain-head-round (intSystemState post) c2
                                       ≡ Cand-3-chain-head-round (intSystemState pre ) c2'
   Cand-3-chain-vote-b4 {pk} {vabs} {pre} {pid} {st'} {outs} {sp} pkH r
                        c3@(mkCand3chainvote (mkVE veBlock refl refl) c3Blk∈sys₁ qc₁ qc←b₁ rc₁ rc∈sys₁ n₁ is-2chain₁) v4r
      with v-cand-3-chain⇒0<roundv  (intSystemState $ StepPeer-post {pid}{st'}{outs}{pre} sp)
   ...| 0<r
      with voteForRound-RC {vabs = vabs} pkH r v4r (0<r c3)
   ...| b , refl , rcb , ais
      with veBlock Abs.≟Block b
   ...| no   neq = ⊥-elim (meta-no-collision-in-sys postR hcf)
        where
          post    = StepPeer-post sp
          theStep = step-peer sp
          postR   = step-s r theStep
          hcf = Abs2ImplCollision postR c3Blk∈sys₁ (InSys.stable iiah theStep (ais here)) neq refl
   ...| yes refl
      with RecordChain-irrelevant rcb (step rc₁ qc←b₁)
   ...| inj₁ (((b1 , b2) , neq , absIds≡) , b1∈rcb , b2∈rc1ext) = ⊥-elim (meta-no-collision-in-sys postR (hcf b2∈rc1ext))
      where
         post    = StepPeer-post sp
         theStep = step-peer sp
         postR   = step-s r theStep

         inSys1  = InSys.stable iiah theStep $ ais b1∈rcb
         inSys2 : _ → _
         inSys2 here = c3Blk∈sys₁
         inSys2 (there .qc←b₁ b2∈rc1ext) = rc∈sys₁ b2∈rc1ext

         hcf : _ → _
         hcf b2∈rc1ext = Abs2ImplCollision postR inSys1 (inSys2 b2∈rc1ext) neq absIds≡
   ...| inj₂ (eq-step {r₀ = .(Abs.B b)} {r₁ = .(Abs.B b)} rc0 rc1 b≈b
                      ext0@(Ext.I←B _ prevNothing)
                      ext1@(Ext.Q←B _ prevJust)
                      rcrest≈) = absurd just _ ≡ nothing case trans prevJust prevNothing of λ ()
   ...| inj₂ (eq-step {r₀ = .(Abs.B b)} {r₁ = .(Abs.B b)} rc0 rc1 b≈b
                      ext0@(Ext.Q←B {qc0} {.b} _ _)
                      ext1@(Ext.Q←B {qc1} {.b} _ _) rcrest≈) = newc3 , rnds≡
          where

            newc3 = mkCand3chainvote (mkVE b refl refl)
                                     (ais here)
                                     qc0
                                     ext0
                                     rc0
                                     (ais ∘ (_∈RC-simple_.there ext0))
                                     n₁
                                     (transp-𝕂-chain (≈RC-sym rcrest≈) is-2chain₁)
            rnds≡ = cong Abs.bRound $ kchainBlock-≈RC is-2chain₁ (suc zero) (≈RC-sym rcrest≈)

   PreferredRoundProof :
      ∀ {pk round₁ round₂ bId₁ bId₂ v₁abs v₂abs mbr} {st : SystemState}
      → ReachableSystemState st
      → Meta-Honest-PK pk
      → (v₁ : VoteForRound∈ pk round₁ (epoch 𝓔) bId₁ (msgPool st))
      → (v₂ : VoteForRound∈ pk round₂ (epoch 𝓔) bId₂ (msgPool st))
      → round₁ < round₂
      → α-ValidVote 𝓔 (msgVote v₁) mbr ≡ v₁abs
      → α-ValidVote 𝓔 (msgVote v₂) mbr ≡ v₂abs
      → (c3 : Cand-3-chain-vote (intSystemState st) v₁abs)
      → Σ (VoteParentData (intSystemState st) v₂abs)
            (λ vp → Cand-3-chain-head-round (intSystemState st) c3 ≤ Abs.round (vpParent vp))
   PreferredRoundProof {pk}{round₁}{round₂}{bId₁}{bId₂}{v₁abs}{v₂abs}{mbr}{st = post}
                       step@(step-s {pre = pre} r theStep) pkH v₁ v₂ r₁<r₂ refl refl c3
      with msgRound≡ v₁ | msgEpoch≡ v₁ | msgBId≡ v₁
         | msgRound≡ v₂ | msgEpoch≡ v₂ | msgBId≡ v₂
   ...| refl | refl | refl | refl | refl | refl
      with Impl-∈BI? (_vSignature (msgVote v₁)) | Impl-∈BI? (_vSignature (msgVote v₂))
   ...| yes init₁  | yes init₂  = let r₁≡0 = Impl-bsvr (msgSigned v₁) init₁
                                      r₂≡0 = Impl-bsvr (msgSigned v₂) init₂
                                  in ⊥-elim (<⇒≢ r₁<r₂ (trans r₁≡0 (sym r₂≡0)))
   ...| yes init₁  | no  ¬init₂ = let 0≡rv = sym (Impl-bsvr (msgSigned v₁) init₁)
                                      0<rv = v-cand-3-chain⇒0<roundv (intSystemState post) c3
                                  in ⊥-elim (<⇒≢ 0<rv 0≡rv)
   ...| no  ¬init₁ | yes init₂  = let 0≡r₂ = sym (Impl-bsvr (msgSigned v₂) init₂)
                                      r₁   = msgVote v₁ ^∙ vRound
                                  in ⊥-elim (<⇒≱ r₁<r₂ (subst (r₁ ≥_) 0≡r₂ z≤n))
   ...| no  ¬init₁ | no ¬init₂
      with theStep
   ...| step-peer {pid} {st'} {outs} cheat@(step-cheat c) = vpdPres
      where
              m₁sb4 = ¬cheatForgeNewSig r cheat unit pkH (msgSigned v₁) (msg⊆ v₁) (msg∈pool v₁) ¬init₁
              m₂sb4 = ¬cheatForgeNewSig r cheat unit pkH (msgSigned v₂) (msg⊆ v₂) (msg∈pool v₂) ¬init₂
              v₁sb4 = msgSentB4⇒VoteRound∈ (msgSigned v₁) m₁sb4
              v₂sb4 = msgSentB4⇒VoteRound∈ (msgSigned v₂) m₂sb4
              v₁abs' = α-ValidVote-trans {pk} {mbr} {pool = msgPool pre} (msgVote v₁) refl (proj₁ v₁sb4)
              v₂abs' = α-ValidVote-trans {pk} {mbr} {pool = msgPool pre} (msgVote v₂) refl (proj₁ v₂sb4)

              vpdPres : Σ (VoteParentData (intSystemState post) v₂abs)
                          (λ vp → Cand-3-chain-head-round (intSystemState post) c3 ≤ Abs.round (vpParent vp))
              vpdPres
                 with Cand-3-chain-vote-b4 {sp = step-cheat c} pkH r c3 (proj₁ v₁sb4)
              ...| c2' , c2'rnd≡
                 with PreferredRoundProof r pkH (proj₁ v₁sb4) (proj₁ v₂sb4) r₁<r₂ v₁abs' v₂abs' c2'
              ...| vpd , rnd≤
                 with stepPreservesVoteParentData theStep vpd
              ...| res , rnds≡ rewrite sym rnds≡ = res , ≤-trans (≤-reflexive c2'rnd≡) rnd≤
   ...| step-peer (step-honest stP)
      with ⊎-map₂ (msgSentB4⇒VoteRound∈ (msgSigned v₁))
                  (newMsg⊎msgSentB4 r stP pkH (msgSigned v₁) ¬init₁  (msg⊆ v₁) (msg∈pool v₁))
         | ⊎-map₂ (msgSentB4⇒VoteRound∈ (msgSigned v₂))
                  (newMsg⊎msgSentB4 r stP pkH (msgSigned v₂) ¬init₂ (msg⊆ v₂) (msg∈pool v₂))
   ...| inj₂ (v₁sb4 , refl) | inj₂ (v₂sb4 , refl)
        = vpdPres
          where
            v₁abs' = α-ValidVote-trans (msgVote v₁) refl v₁sb4
            v₂abs' = α-ValidVote-trans (msgVote v₂) refl v₂sb4

            vpdPres : _
            vpdPres
               with Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4
            ...| c2' , c2'rnd≡
               with PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs' v₂abs' c2'
            ...| vpd , rnd≤
               with stepPreservesVoteParentData theStep vpd
            ...| res , pars≡ rewrite sym pars≡ =  res , ≤-trans (≤-reflexive c2'rnd≡) rnd≤
   ...| inj₁ (m₁∈outs , v₁pk , newV₁) | inj₁ (m₂∈outs , v₂pk , newV₂) =
              Impl-PR2 r stP pkH (msg⊆ v₁) m₁∈outs (msgSigned v₁) ¬init₁ newV₁ v₁pk (msg⊆ v₂)
                                           m₂∈outs (msgSigned v₂) ¬init₂ newV₂ v₂pk refl r₁<r₂ refl refl c3

   ...| inj₁ (m₁∈outs , v₁pk , v₁New) | inj₂ (v₂sb4 , refl) = help
        where
          round≡ = trans (msgRound≡ v₂sb4) (msgRound≡ v₂)
          ¬bootstrapV₂ = ¬Bootstrap∧Round≡⇒¬Bootstrap step pkH v₂ ¬init₂ (msgSigned v₂sb4) round≡
          epoch≡ = sym (msgEpoch≡ v₂sb4)

          implir0 : _
          implir0 = Impl-IRO r stP pkH (msg⊆ v₁) m₁∈outs (msgSigned v₁) ¬init₁ v₁New v₁pk (msg⊆ v₂sb4)
                                       (msg∈pool v₂sb4)  (msgSigned v₂sb4) ¬bootstrapV₂ epoch≡

          help : _
          help = either (λ r₂<r₁ → ⊥-elim (<⇒≯ r₁<r₂ (<-transʳ (≡⇒≤ (sym round≡)) r₂<r₁)))
                        (λ v₁sb4 → let v₁abs = α-ValidVote-trans (msgVote v₁) refl v₁sb4
                                       v₂abs = α-ValidVote-trans (msgVote v₂) refl v₂sb4
                                       c2'p  = Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4
                                       prp   = PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs v₂abs (proj₁ c2'p)
                                       vpd'  = stepPreservesVoteParentData theStep (proj₁ prp)
                                   in (proj₁ vpd') , (≤-trans (≤-reflexive (proj₂ c2'p)) (proj₂ prp)))
                        implir0
   ...| inj₂ (v₁sb4 , refl)           | inj₁ (m₂∈outs , v₂pk , v₂New) = help
        where
          rv₁<r₂ = <-transʳ (≡⇒≤ (msgRound≡ v₁sb4)) r₁<r₂
          round≡ = trans (msgRound≡ v₁sb4) (msgRound≡ v₁)
          ¬bootstrapV₁ = ¬Bootstrap∧Round≡⇒¬Bootstrap step pkH v₁ ¬init₁ (msgSigned v₁sb4) round≡
          v₁abs' = α-ValidVote-trans (msgVote v₁) refl v₁sb4

          c2'p   = Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4

          implir1 : _
          implir1 = Impl-PR1 r stP pkH (msg⊆ v₂) m₂∈outs (msgSigned v₂) ¬init₂ v₂New v₂pk
                                   (msg⊆ v₁sb4) (msg∈pool v₁sb4) (msgSigned v₁sb4) ¬bootstrapV₁
                                   (msgEpoch≡ v₁sb4) rv₁<r₂ v₁abs' refl c3

          help : _
          help = either id
                        (λ v₂sb4 → let v₂abs' = α-ValidVote-trans (msgVote v₂) refl v₂sb4
                                       prp    = PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs' v₂abs' (proj₁ c2'p)
                                       vpd'   = stepPreservesVoteParentData theStep (proj₁ prp)
                                   in (proj₁ vpd') , (≤-trans (≤-reflexive (proj₂ c2'p)) (proj₂ prp)))
                        implir1

   prr : Type (intSystemState st)
   prr honα refl sv refl sv' c2 round<
     with vmsg≈v (vmFor sv) | vmsg≈v (vmFor sv')
   ...| refl | refl
       = let v₁ = mkVoteForRound∈ (nm (vmFor sv)) (cv ((vmFor sv))) (cv∈nm (vmFor sv))
                                  (vmSender sv) (nmSentByAuth sv) (vmsgSigned (vmFor sv))
                                  (vmsgEpoch (vmFor sv)) refl refl
             v₂ = mkVoteForRound∈ (nm (vmFor sv')) (cv (vmFor sv')) (cv∈nm (vmFor sv'))
                                  (vmSender sv') (nmSentByAuth sv') (vmsgSigned (vmFor sv'))
                                  (vmsgEpoch (vmFor sv')) refl refl
         in PreferredRoundProof r honα v₁ v₂ round< refl refl c2


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import Dijkstra.EitherD
open import LibraBFT.Impl.Consensus.EpochManagerTypes
open import LibraBFT.Impl.Handle
open        InitHandler
import      LibraBFT.Impl.IO.OBM.GenKeyFile           as GenKeyFile
import      LibraBFT.Impl.IO.OBM.Properties.Start     as Start
import      LibraBFT.Impl.Properties.Util             as Util
import      LibraBFT.Impl.Types.BlockInfo             as BlockInfo
import      LibraBFT.Impl.Types.ValidatorSigner       as ValidatorSigner
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochIndep
open import LibraBFT.ImplShared.Interface.Output
open import Optics.All
open import Util.Prelude
open import Yasm.Types as YT

module LibraBFT.Impl.Handle.InitProperties where

------------------------------------------------------------------------------

------------------------------------------------------------------------------

open Util.Invariants
open Util.InitProofDefs

module getEmRmSpec
  (em : EpochManager)
  where

  Contract : EitherD-Post ErrLog RoundManager
  Contract (Left x)   = ⊤
  Contract (Right rm) = rm IsNormalRoundManagerOf em

  contract' : EitherD-weakestPre (getEmRm-ed-abs em) Contract
  contract' rewrite getEmRm-ed-abs≡
     with em ^∙ emProcessor | inspect (_^∙ emProcessor) em
  ...| nothing | _ = tt
  ...| just (RoundProcessorRecovery x) | _     = tt
  ...| just (RoundProcessorNormal   x) | [ refl ] = refl

module initializeSpec
  (now : Instant)
  (nfl : GenKeyFile.NfLiwsVsVvPe)
  where

  contract' : EitherD-weakestPre (initialize-ed-abs now nfl) (InitContract nothing)
  contract' rewrite initialize-ed-abs≡ =
    Start.startViaConsensusProviderSpec.contract'
      now
      nfl
      (TxTypeDependentStuffForNetwork∙new proposalGenerator (StateComputer∙new BlockInfo.gENESIS_VERSION))

module initEMWithOutputSpec
  (bsi : BootstrapInfo)
  (vs  : ValidatorSigner)
  where

  contract' : EitherD-weakestPre (initEMWithOutput-ed-abs bsi vs) (InitContract nothing)
  contract' rewrite initEMWithOutput-ed-abs≡ = initializeSpec.contract' now (mkNfLiwsVsVvPe bsi vs)

module initRMWithOutputSpec
  (bsi : BootstrapInfo)
  (vs  : ValidatorSigner)
  where

  Contract : EitherD-Post ErrLog (RoundManager × List Output)
  Contract (Left x)            = ⊤
  Contract (Right (rm , outs)) = InitContractOk nothing rm outs

  open initRMWithOutput-ed bsi vs

  contract-step₁ : ∀ {em lo}
                   → EMInitCond nothing (em , lo)
                   → EitherD-weakestPre (step₁ (em , lo)) Contract
  contract-step₁ {em} {lo} (rm , inrm , cntrctOk) =
    EitherD-⇒-bind (getEmRm-ed-abs em)
                   (getEmRmSpec.contract' em)
                   P⇒Q
     where
       P⇒Q : EitherD-Post-⇒ (getEmRmSpec.Contract em)
                            (EitherD-weakestPre-bindPost (λ rm → RightD (rm , lo)) Contract)
       P⇒Q (Left x) _ = tt
       P⇒Q (Right rm') pf .rm' refl rewrite IsNormalRoundManagerOf-inj {em} inrm pf = cntrctOk

  contract' : EitherD-weakestPre (initRMWithOutput-ed-abs bsi vs) Contract
  contract' rewrite initRMWithOutput-ed-abs≡ =
    EitherD-⇒-bind (initEMWithOutput-ed-abs bsi vs)
                   (initEMWithOutputSpec.contract' bsi vs)
                   P⇒Q
      where
      P⇒Q : EitherD-Post-⇒ (InitContract nothing) _
      P⇒Q (Left x) _ = tt
      P⇒Q (Right (em , lo)) pf .(em , lo) refl = contract-step₁ pf

  contract : Contract (initRMWithOutput-e-abs bsi vs)
  contract rewrite initRMWithOutput≡ {bsi} {vs} =
    EitherD-contract (initRMWithOutput-ed-abs bsi vs) Contract contract'

------------------------------------------------------------------------------

module initHandlerSpec
  (pid : Author)
  (bsi : BootstrapInfo)
  where

  record ContractOk (rm : RoundManager) (acts : List (YT.Action NetworkMsg)) : Set where
    constructor mkContractOk
    field
      rmInv       : Util.Invariants.RoundManagerInv rm
      sdLVnothing : InitSdLV≡ rm nothing
      sigs∈bs     : InitSigs∈bs rm
      isInitPM    : InitIsInitPM acts
      -- TODO-3: We will eventually need to know that our ValidatorSigner is for the correct peer,
      -- because it will be needed to prove impl-sps-avp : StepPeerState-AllValidParts

  Contract : Maybe (RoundManager × List (YT.Action NetworkMsg)) → Set
  Contract nothing            = ⊤
  Contract (just (rm , acts)) = ContractOk rm acts

  -- TODO-2: this property is more succinctly/elegantly stated as Contract (initHandler pid bsi),
  -- and can be proved by starting the proof as follows:
  --
  -- contract : Contract (initHandler pid bsi)
  -- contract with initHandler pid bsi | inspect (initHandler pid) bsi
  -- ...| nothing | _ = tt
  -- ...| just (rm , acts) | [ hndl≡just ]
  --
  -- However, this breaks a bunch of proofs that use this, so not doing it for now.
  contract : ∀ {x} → initHandler pid bsi ≡ x → Contract x
  contract {nothing} hndl≡nothing rewrite sym hndl≡nothing = tt
  contract {just (rm , acts)} hndl≡just
    with ValidatorSigner.obmGetValidatorSigner pid  (bsi ^∙ bsiVSS)
  ...| Left _ = absurd nothing ≡ just _ case hndl≡just  of λ ()
  ...| Right vs
    with initRMWithOutputSpec.contract bsi vs
  ...| initRMWithOutputContractOk
    with initRMWithOutput-e-abs bsi vs
  ...| Left _ = absurd nothing ≡ just (rm , acts) case hndl≡just of λ ()
  ...| Right rm×outs rewrite sym (cong proj₂ (just-injective hndl≡just)) |
                                 (cong proj₁ (just-injective hndl≡just)) =
       mkContractOk
         (InitContractOk.rmInv       initRMWithOutputContractOk)
         (InitContractOk.sdLV≡       initRMWithOutputContractOk)
         (InitContractOk.sigs∈bs     initRMWithOutputContractOk)
         (InitContractOk.isInitPM    initRMWithOutputContractOk)


module Coirc.Parser where
open import Data.Unit
open import Data.Bool
open import Data.Nat
open import Data.Char
open import Data.String
open import Data.Maybe
open import Data.List hiding (_++_)
open import Data.Sum
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Coirc
open import Coirc.Format

readTo-! : List Char → Maybe (String × List Char)
readTo-! [] = nothing
readTo-! ('!' ∷ xs) = just ("" , '!' ∷ xs)
readTo-! (x ∷ xs) with readTo-! xs
... | nothing = nothing
... | just (a , ys) = just ( fromList [ x ] ++ a  , ys )

readTo-sp : List Char → Maybe (String × List Char)
readTo-sp [] = nothing
readTo-sp (' ' ∷ xs) = just ("" , ' ' ∷ xs)
readTo-sp (x ∷ xs) with readTo-sp xs
... | nothing = nothing
... | just (a , ys) = just ( fromList [ x ] ++ a  , ys )

readTo-crlf : List Char → Maybe (String × List Char)
readTo-crlf [] = nothing
readTo-crlf ('\r' ∷ '\n' ∷ xs) = just ("" , '\r' ∷ '\n' ∷ xs)
readTo-crlf (x ∷ xs) with readTo-crlf xs
... | nothing = nothing
... | just (a , ys) = just ( fromList (x ∷ []) ++ a  , ys )

read : (u : U) → List Char → Maybe (El u × List Char)

read CHAR (x ∷ xs) = just (x , xs)

read (DAR n) (x ∷ xs) with Data.Nat._≟_ n (toNat x)
... | no _  = nothing
... | yes p rewrite p = just (dar x , xs)

read (DAR-RANGE n m) (x ∷ xs) with Data.Bool._≟_ true (within? x n m)
... | no _ = nothing
... | yes p rewrite p = just (dar x , xs)

read `*! xs = readTo-! xs
read `*sp xs = readTo-sp xs
read `*crlf xs = readTo-crlf xs

read _ [] = nothing

parse : (f : Format) → List Char → Maybe (⟦ f ⟧ × List Char)
parse Fail _ = nothing
parse End xs = just (tt , xs)
parse (As val) xs = just (val , xs)
parse (Base u) xs = read u xs
parse (Skip f₁ f₂) xs with parse f₁ xs
... | nothing = nothing
... | just (_ , ys) = parse f₂ ys
parse (Or f₁ f₂) xs with parse f₁ xs
... | just (a , ys) = just (inj₁ a , ys)
... | nothing with parse f₂ xs
... | just (a , ys) = just (inj₂ a , ys)
... | nothing = nothing
parse (And f₁ f₂) xs with parse f₁ xs
... | nothing = nothing
... | just (a , ys) with parse f₂ ys
... | nothing = nothing
... | just (b , zs) = just ((a , b) , zs)
parse (Use f₁ f₂) xs with parse f₁ xs
... | nothing = nothing
... | just (a , ys) with parse (f₂ a) ys
... | nothing = nothing
... | just (b , zs) = just ((a , b) , zs)

parse-Event : List Char → Maybe Event
parse-Event xs with parse Notice xs
... | just (x , _) = just x
... | nothing with parse NumericReply xs
... | just (x , _) = just x
... | nothing with parse Mode xs
... | just (x , _) = just x
... | nothing with parse Ping xs
... | just (x , _) = just x
... | nothing with parse Privmsg xs
... | just ((_ , _ , x) , _) = just x
... | nothing = nothing

private
  test : Event → String → Set
  test e s = just e ≡ parse-Event (toList (s ++ "\r\n"))

  test-Notice : test notice
    ":verne.freenode.net NOTICE * :*** Looking up your hostname..."
  test-Notice = refl

  test-NumericReply : test numeric
    ":verne.freenode.net 001 foobot-name :Welcome to the freenode Internet Relay Chat Network coalgbot"
  test-NumericReply = refl

  test-Mode : test mode
    ":coalgbot MODE coalgbot :+i"
  test-Mode = refl

  test-Ping : test ping
   "PING :verne.freenode.net"
  test-Ping = refl

  test-Privmsg : test (privmsg "amiller" "PING 3073265598")
    ":amiller!debian-tor@gateway/tor-sasl/socrates1024 PRIVMSG coalgbot :PING 3073265598"
  test-Privmsg = refl