You are an expert Lean4 and formal verification agent proving a Lean4 theorem. Your output **must** strictly adhere to the specified format.

### Input Information
You will receive the following components, relevant to the target theorem:
* <all_available_defs>: Definitions available from imported modules (either from the current Lean repository or from Mathlib)
* <all_available_lemmas>: Lemmas/theorems available that may assist the proof.
* <local_ctx>...</local_ctx>: The local file context (imports, namespaces, definitions, comments, etc.) from the top of the file up to—but not including—the target theorem or any previously defined local lemmas/theorems.
* <target_theorem>...</target_theorem>: The target theorem statement, ending with `:=`.

**Notes**
1. Definitions include their full bodies, but for definitions whose bodies contain proofs, the proof parts are replaced by `admit` (i.e., admit /- proof elided -/), while the rest of the definition is kept unchanged; lemmas include only their statements.
2. You may freely reference any definition or lemma contained in these tags without redefining them.
3. The tags for available definitions and lemmas (all_available_defs, all_available_lemmas) may be omitted if empty.

### Output Format & Requirements
Your output MUST contain a complete, syntactically correct Lean 4 proof for the target theorem.

**Strict Output Structure:**
<reasoning> 
...
</reasoning> 

<lean4_invented_lemmas>
-- each lemma is a full Lean 4 declaration with a complete proof
...
</lean4_invented_lemmas>

<lean4_proof>
-- Lean 4 proof body of the target theorem
...
</lean4_proof>

**Requirements:**
1. <reasoning> and <lean4_invented_lemmas> are OPTIONAL. Include them only if they aid proof construction.
2. <lean4_proof> MUST contain only the proof body (tactics/terms), starting by "by", NOT the theorem declaration.
3. <lean4_invented_lemmas> (if present) MUST contain syntactically correct lemma declarations that type checks AND complete proof bodies. Defining a lemma using `axiom` is NOT allowed.
4. <reasoning> contains high-level proof planning.
5. If you create a lemma under <lean4_invented_lemmas> whose name is namespaced (e.g., X.Y.Z), you MUST always refer to it using its fully qualified name. Do NOT rely on shortened names. For example, write rw [X.Y.Z], not rw [Z] for invented lemmas.
6. All Lean 4 code MUST be syntactically correct. No `sorry`, `admit`, or non-Lean text. Comments allowed using `--` or `/- ... -/`.
7. Follow the tags and structure EXACTLY. No extra text before, between, or after the sections.
8. Do NOT wrap invented lemmas in a `mutual` block unless they have genuine mutual recursion. Declare each lemma independently.

### Examples are provided here (example input are under "User Prompt", and example assistant response are under "Agent Response"):
Example 1 ------------------- 
User Prompt:
<all_available_defs>
structure BitVec (w : Nat) where
  /-- Construct a `BitVec w` from a number less than `2^w`.
  O(1), because we use `Fin` as the internal representation of a bitvector. -/
  ofFin ::

  /-- Interpret a bitvector as a number less than `2^w`.
  O(1), because we use `Fin` as the internal representation of a bitvector. -/
  toFin : Fin (hPow 2 w)
</all_available_defs>

<all_available_lemmas>
theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) : (l₁ ++ l₂)[i] = l₁[i]
theorem getElem_eq_testBit_toNat (x : BitVec w) (i : Nat) (h : i < w) :
  x[i] = x.toNat.testBit i := rfl
@[simp, grind =] theorem toNat_cons (b : Bool) (x : BitVec w) :
    (cons b x).toNat = (b.toNat <<< w) ||| x.toNat
@[simp, grind =] theorem getLsbD_of_ge (x : BitVec w) (i : Nat) (ge : w ≤ i) : getLsbD x i = false
theorem testBit_toNat (x : BitVec w) : x.toNat.testBit i = x.getLsbD i
</all_available_lemmas>

<local_ctx>
import Mathlib.Computability.NFA
import Mathlib.Data.FinEnum
import Mathlib.Data.Rel
import Mathlib.Data.Vector.Basic
import Blase.AutoStructs.ForLean

open Set
open Mathlib
open SetRel

-- this is better because card is defeq to n
instance (α : Type) : Inter (Language α) := ⟨Set.inter⟩
instance (α : Type) : Union (Language α) := ⟨Set.union⟩

/--
The set of `n`-tuples of bit vectors of an arbitrary width.
-/
structure BitVecs (n : Nat) where
  w : Nat
  bvs : List.Vector (BitVec w) n

def BitVecs.cast (bvs : BitVecs n) (h : n = n') : BitVecs n' :=
  { w := bvs.w, bvs := h ▸ bvs.bvs }

abbrev BitVecs.empty : BitVecs n := ⟨0, List.Vector.replicate n .nil⟩
abbrev BitVecs.singleton {w : Nat} (bv : BitVec w) : BitVecs 1 := ⟨w, bv ::ᵥ .nil⟩
abbrev BitVecs.pair {w : Nat} (bv1 bv2 : BitVec w) : BitVecs 2 := ⟨w, bv1 ::ᵥ bv2 ::ᵥ .nil⟩

/--
The set of `n`-tuples of bit vectors of an arbitrary width, encoded as a list of
bit vectors of width `n`. The width of the encoded bit vectors is the length of
the list.
-/
abbrev BitVecs' (n : Nat) := List (BitVec n)

@[simps]
def dec (bvs' : BitVecs' n) : BitVecs n where
  w := bvs'.length
  bvs := List.Vector.ofFn fun k => BitVec.ofFn fun i => bvs'[i].getLsbD k

@[simp]
</local_ctx>

<target_theorem>
lemma dec_snoc n (bvs' : BitVecs' n) (a : BitVec n) :
  dec (bvs' ++ [a]) =
    { w := bvs'.length + 1
      bvs := List.Vector.ofFn fun k =>
        BitVec.cons (a.getLsbD k) ((dec bvs').bvs.get k) } :=
</target_theorem>

Agent Response:
<reasoning> 
The goal is to understand what `dec` does after appending one more bitvector `a` to `bvs'`. By definition, `dec` builds a width `= length` and a vector of bitvectors whose `i`-th bit at position `k` is `bvs'[i].getLsbD k`. So for `bvs' ++ [a]`, we expect the width to increase by 1 and each resulting bitvector to be `BitVec.cons` of the new bit coming from `a`.

First, I use `ext` twice: once on the record to focus on the `bvs` field, and once on the resulting bitvector. This reduces everything to a pointwise statement:
for fixed `k` and `i` with `i < bvs'.length + 1`,
the bit `(bvs' ++ [a])[i].getLsbD k` should match the bit at index `i` of `BitVec.cons (a.getLsbD k) ((dec bvs').bvs.get k)`.

At this point I need a clean description of indexing into `BitVec.cons`: if we have `x : BitVec n`, then `(cons b x)[i]` should give `b` at the new “last” index `n` and `x[i]` otherwise. That motivates an auxiliary lemma `getElem_cons` expressing exactly this behavior, proved via the `testBit`/`toNat` characterization and a case split on `i < n`, `i = n`, `i > n`.

Using `getElem_cons`, the RHS becomes an `if` on whether `i = bvs'.length`. So I split into cases:
- If `i = bvs'.length`, then `(bvs' ++ [a])[i]` is the appended `a`, so both sides reduce to `a.getLsbD k`.
- If `i ≠ bvs'.length`, the bound `i < bvs'.length + 1` forces `i < bvs'.length`. Then `(bvs' ++ [a])[i] = bvs'[i]` by `List.getElem_append_left`, and the RHS takes the “else” branch and likewise gives the bit from `bvs'[i]`. In both subcases, `simp` (plus the definition of `dec`) finishes.

So the whole proof is: `ext` to bit level, unfold `dec` with `simp_all`, rewrite with `getElem_cons`, split on the boundary index `i = length bvs'`, and in the “< length” branch use `List.getElem_append_left` and bounds to line up both sides.
</reasoning> 

<lean4_invented_lemmas>
@[grind =]
theorem getElem_cons {b : Bool} {n} {x : BitVec n} {i : Nat} (h : i < n + 1) :
    (cons b x)[i] = if h : i = n then b else x[i] := by
  simp only [BitVec.getElem_eq_testBit_toNat, BitVec.toNat_cons, Nat.testBit_or]
  rw [Nat.testBit_shiftLeft]
  rcases Nat.lt_trichotomy i n with i_lt_n | i_eq_n | n_lt_i
  · have p1 : ¬(n ≤ i) := by omega
    have p2 : i ≠ n := by omega
    simp [p1, p2]
  · simp only [i_eq_n, ge_iff_le, Nat.le_refl, decide_true, Nat.sub_self, Nat.testBit_zero,
    Bool.true_and, BitVec.testBit_toNat, BitVec.getLsbD_of_ge, Bool.or_false]
    cases b <;> trivial
  · have p1 : i ≠ n := by omega
    have p2 : i - n ≠ 0 := by omega
    simp [p1, p2, Nat.testBit_bool_toNat]
</lean4_invented_lemmas>

<lean4_proof>
by
  ext k i hi <;> simp_all
  rw [getElem_cons]
  split
  next heq => simp_all
  next h =>
    have hlt : i < List.length bvs' := by simp at hi; omega
    rw [List.getElem_append_left hlt]
    simp
</lean4_proof>

### Your task:
<all_available_defs>
action req = {
  require False
}

example : forall s s' (Q : Prop), req.tr s s' -> Q :=

def theoremSuggestionsForChecks' (actIndicators : List (Name × Name)): CommandElabM (Array (TheoremIdentifier × TSyntax `command)) := do
    Command.runTermElabM fun vs => do
      let (systemTp, stateTp, st, st') := (← getSystemTpStx vs, ← getStateTpStx, mkIdent `st, mkIdent `st')
      let sectionArgs ← getSectionArgumentsStx vs
      let mut theorems : Array (TheoremIdentifier × TSyntax `command) := #[]
      
      for (actName, invName) in actIndicators.reverse do
        let (tp, body) ← do
          let trName := toTrName actName
          let invStx ← `(@$(mkIdent invName) $sectionArgs*)
          let trStx ← `(@$(mkIdent trName) $sectionArgs*)
          let trTpSyntax ← `(∀ ($st $st' : $stateTp), ($systemTp).$(mkIdent `assumptions) $st → ($systemTp).$(mkIdent `inv) $st → $trStx $st $st' → $invStx $st')

          let moduleName <- getCurrNamespace
          let some args := (<- localSpecCtx.get).spec.actions.find? (moduleName ++ ·.name == actName)
            | throwError s!"action {actName} not found"
          let args ← match args.br with
          | some br => explicitBindersIdents br
          | none => pure #[]

          let body ← do
            let name1 := toActTrEqName actName
            let name2 := mkTheoremName actName invName
            let name3 := ``forall_exists_index
            let name4 := ``TwoState_sound'_ret_unit'
            `(tacticSeq|
              rw [← $(mkIdent name1)] ; dsimp
              (try simp only [$(mkIdent name3):ident])
              have h := @$(mkIdent name2) $sectionArgs*
              intro st st' hassu hinv $args*
              specialize h st ; specialize h $args* ; specialize h hassu hinv
              have hthis := $(mkIdent name4):ident _ h
              apply hthis)
          pure (trTpSyntax, body)
        let thmName := mkTrTheoremName actName invName
        let thm ← `(@[invProof] theorem $(mkIdent thmName) : $tp := by admit /- proof elided -/
        )
        trace[veil.debug] "{thmName} ({thmName.components}) | {thm}"
        theorems := theorems.push (⟨invName, .some actName, thmName⟩, thm)
      return theorems

def theoremSuggestionsForIndicators' (actIndicators invIndicators : List (Name × Expr)) : CommandElabM (Array (TheoremIdentifier × TSyntax `command)) := do
  let (_, acts) ← Command.runTermElabM fun _ => do
    
    let initIndicators ← invIndicators.mapM (fun (invName, _) => resolveGlobalConstNoOverloadCore invName)
    let actIndicators ← actIndicators.mapM (fun (actName, _) => resolveGlobalConstNoOverloadCore actName)
    let mut acts := #[]
    for actName in actIndicators do
      for invName in initIndicators do
        acts := acts.push (actName, invName)
    return (initIndicators, acts)
  theoremSuggestionsForChecks' acts.toList

def recoverInvariantsInTrStyle : CommandElabM Unit := do
  let (_, invChecks) ← getAllChecks
  let actIndicators := (invChecks.map (fun (_, (act_name, ind_name)) => (act_name, ind_name))).toList |> List.removeDuplicates
  let invIndicators := (invChecks.map (fun ((inv_name, ind_name), _) => (inv_name, ind_name))).toList |> List.removeDuplicates
  let allTheorems ← theoremSuggestionsForIndicators' actIndicators invIndicators
  for (thmId, cmd) in allTheorems do
    
    if (← resolveGlobalName thmId.theoremName).isEmpty then
      elabCommand (← `(#guard_msgs(drop warning) in $(cmd)))
    else
      trace[veil.info] s!"{thmId.theoremName} has already been proven in transition mode; not recovering it from wp"

def elabAlreadyProven (trName : Name) : TacticM Unit := withMainContext do
  let g ← getMainGoal
  let ty ← g.getType
  let ty ← instantiateMVars ty      
  let inv := ty.getAppFn'
  let .some (invName, _) := inv.const? | throwError "the goal {ty} is not about an invariant clause? got {inv}, expect it to be a const"
  let thmName := mkTheoremName trName invName
  let attempt ← `(tactic| (apply $(mkIdent thmName) <;> assumption) )
  evalTactic attempt

elab "#split_invariants" : command => do
  let allClauses := (← localSpecCtx.get).spec.invariants
  if allClauses.isEmpty then return

  let (tempvars, thmType, subThmTypes) ← Command.runTermElabM fun vs => do
    let allClauses := (← localSpecCtx.get).spec.invariants
    let allClauses := allClauses.toList
    let invExprs := allClauses.map (fun x => mkAppN x.expr vs)
    let invNames := allClauses.map StateAssertion.name
    
    let invExprs := invExprs.reverse
    let invNames := invNames.reverse
    let invExprs ← invExprs.mapM (fun x => mkAppM ``RelationalTransitionSystem.isInvariant #[x])
    let invConj := mkAndN invExprs
    let thmType ← mkForallFVars vs invConj
    let subThmTypes ← invExprs.mapM (fun x => mkForallFVars vs x)
    
    let thmType ← instantiateMVars thmType
    let subThmTypes ← subThmTypes.mapM instantiateMVars
    let tempvars ← vs.mapM (fun x => x.fvarId!.getUserName)
    pure (tempvars, thmType, invNames.zip subThmTypes)

  let moduleName ← getCurrNamespace

  
  let conjunctionThmName := moduleName ++ `inv_split_base
  Command.liftTermElabM do
    let thmName1 := ``RelationalTransitionSystem.invariant_merge
    let thmName2 := ``RelationalTransitionSystem.invInductive_to_isInvariant
    let thmName3 := `inv_inductive
    simpleAddThm conjunctionThmName thmType
      `(tacticSeq|
        intros ; repeat rw [@$(mkIdent thmName1):ident]
        apply $(mkIdent thmName2)
        next => intro _ _ ; simp [invSimp]
        next => apply $(mkIdent thmName3))

  
  for (invName, subThmType) in subThmTypes do
    let subThmName := moduleName ++ invName ++ `is_inv
    Command.liftTermElabM do
      
      let tempvars := tempvars.map Lean.mkIdent
      let thmName1 := `inv_split_base
      simpleAddThm subThmName subThmType
        `(tacticSeq|
          intro $tempvars* ; have hh := @$(mkIdent thmName1) $tempvars*
          revert hh ; simp only [and_imp] ; intros ; assumption
        )     

inductive SmtTranslator
  | leanSmt
  | leanAuto
deriving BEq, Hashable, Inhabited

instance : ToString SmtTranslator where
  toString : SmtTranslator → String
  | .leanSmt  => "lean-smt"
  | .leanAuto => "lean-auto"

instance : Lean.KVMap.Value SmtTranslator where
  toDataValue n := toString n
  ofDataValue?
  | "lean-smt"  => some .leanSmt
  | "lean-auto" => some .leanAuto
  | _           => none

inductive SmtSolver where
  | z3
  | cvc5
deriving BEq, Hashable, Inhabited

instance : ToString SmtSolver where
  toString
    | SmtSolver.z3  => "z3"
    | SmtSolver.cvc5 => "cvc5"

instance : Lean.KVMap.Value SmtSolver where
  toDataValue n := toString n
  ofDataValue?
  | "z3"  => some .z3
  | "cvc5" => some .cvc5
  | _     => none

def solverToTryOnUnknown (tried : SmtSolver) : SmtSolver :=
  match tried with
  | .z3 => SmtSolver.cvc5
  | .cvc5 => SmtSolver.z3

abbrev SolverProc := IO.Process.Child ⟨.piped, .piped, .piped⟩

inductive SmtResult
   
  | Sat (modelString : Option String)
  | Unsat
  | Unknown (reason : Option String)
  | Failure (reason : Option String)
deriving Inhabited

instance : ToString SmtResult where
  toString
    | SmtResult.Sat none => "sat"
    | SmtResult.Sat (some m) => s!"sat\n{m}"
    | SmtResult.Unsat => s!"unsat"
    | SmtResult.Unknown none => s!"unknown"
    | SmtResult.Unknown (some r) => s!"unknown ({r})"
    | SmtResult.Failure none => "failure"
    | SmtResult.Failure (some r) => s!"failure ({r})"

instance : ToJson SmtResult where
  toJson res := match res with
    | .Sat none => Json.arr #["sat"]
    | .Unsat => Json.arr #["unsat"]
    | .Unknown none => Json.arr #["unknown"]
    | .Failure none => Json.arr #["failure"]

    | .Sat (some m) => Json.arr #["sat", m]
    | .Unknown (some r) => Json.arr #["unknown", r]
    | .Failure (some r) => Json.arr #["failure", r]

instance : FromJson SmtResult where
  fromJson? s := match s with
    | Json.arr #["sat"] => .ok (.Sat none)
    | Json.arr #["unsat"] => .ok .Unsat
    | Json.arr #["unknown"] => .ok (.Unknown none)
    | Json.arr #["failure"] => .ok (.Failure none)
    | Json.arr #["sat", m] => fromJsonStr? m >>= fun m => .ok (.Sat (some m))
    | Json.arr #["unknown", r] => fromJsonStr? r >>= fun r => .ok (.Unknown (some r))
    | Json.arr #["failure", r] => fromJsonStr? r >>= fun r => .ok (.Failure (some r))
    | _ => .error s!"invalid SMT result: {s}"
    where
      fromJsonStr? : Json → Except String String
        | Json.str s => .ok s
        | s => .error s!"expected string, got {s}"

abbrev SExpression := Auto.Parser.SMTSexp.Sexp

abbrev TimeInMs := Nat

partial def Handle.readLineSkip (h : IO.FS.Handle) (skipLine : String := "\n") : IO String := do
  let rec loop := do
    let line ← h.getLine
    if line.isEmpty then
      return line
    if line == skipLine then
      loop
    else
      return line
  loop

def emitCommandStr (p : SolverProc) (c : String) : MetaM Unit := do
  trace[veil.smt.query] "{c}"
  p.stdin.putStr c
  p.stdin.flush

def commandStr (c : Auto.IR.SMT.Command) : String := s!"{c}\n"

def emitCommand (p : SolverProc) (c : Auto.IR.SMT.Command) : MetaM Unit := do
  emitCommandStr p (commandStr c)

private def createAux (path : String) (args : Array String) : MetaM SolverProc := do
    trace[veil.smt.debug] "invoking {path} {args}"
    IO.Process.spawn {stdin := .piped, stdout := .piped, stderr := .piped,
                      cmd := path, args := args}

private def buildDir := System.mkFilePath [currentDirectory!] / ".." / ".." / ".lake" / "build"

def z3Path := buildDir / "z3"

def cvc5Path := buildDir / "cvc5"

def uvPath := buildDir / "uv"

def z3ModelPath := System.mkFilePath [currentDirectory!, "z3model.py"]

def createSolver (name : SmtSolver) (withTimeout : Nat) : MetaM SolverProc := do
  let tlim_sec := withTimeout
  let seed := veil.smt.seed.get $ ← getOptions
  match name with
  | .z3   => createAux s!"{z3Path}" #["-in", "-smt2", s!"-t:{tlim_sec * 1000}", s!"sat.random_seed={seed}", s!"smt.random_seed={seed}"]
  | .cvc5 =>
      let mut args := #["
        "
        "
      if veil.smt.finiteModelFind.get $ ← getOptions then
        args := args.push "
      let proc ← createAux s!"{cvc5Path}" args
      emitCommand proc (.setLogic "ALL")
      
      
      
      pure proc

inductive ModelGenerator where
  | z3Model

def modelGenerationFailureDiagnostic : String := "try changing `veil.smt.seed` or increasing `veil.smt.timeout`; if the goal cannot be solved by z3, we cannot show a readable model and instead show the model from cvc5"

def createModelGenerator (name : ModelGenerator) (withTimeout : Nat) (minimize : Bool) : MetaM SolverProc := do
  let tlim_sec := withTimeout
  let seed := veil.smt.seed.get $ ← getOptions
  match name with
  | .z3Model   =>
    let wrapperDir := currentDirectory!
    let wrapperPath := (System.mkFilePath [wrapperDir, "z3model.py"]).toString
    let mut wrapperArgs := #[s!"
    if minimize then
      wrapperArgs := wrapperArgs.push "
    let uvArgs := #["run", wrapperPath] ++ wrapperArgs
    createAux s!"{uvPath}" uvArgs

def getReadableModel (goalQuery : String) (withTimeout : Nat) (minimize : Bool) : MetaM (Option FirstOrderStructure) := do
  try
    let mg ← createModelGenerator .z3Model withTimeout minimize
    let queryStr := goalQuery ++ ("\n".intercalate $ [.checkSat, .getModel].map commandStr)
    emitCommandStr mg queryStr
    let (_, mg) ← mg.takeStdin
    let stdout ← mg.stdout.readToEnd
    let stderr ← mg.stderr.readToEnd
    trace[veil.smt.debug] "stdout: {stdout}"
    trace[veil.smt.debug] "stderr: {stderr}"
    mg.kill
    let (model, _) ← Auto.Solver.SMT.getSexp stdout
    extractStructure model
  catch e =>
    let exMsg ← e.toMessageData.toString
    if exMsg == ModelGenerationTimeoutMsg then
      logWarning s!"{ModelGenerationTimeoutMsg}; {modelGenerationFailureDiagnostic}"
    else
      logWarning s!"Could not get readable model: {exMsg}"
    pure none

partial def querySolver (goalQuery : String) (withTimeout : Nat) (forceSolver : Option SmtSolver := none) (retryOnUnknown : Bool := false) : MetaM (SmtResult × SmtSolver):= do
  withTraceNode `veil.smt.perf.query (fun _ => return "querySolver") do
  let opts ← getOptions
  let solverName :=
    match forceSolver with
    | some s => s
    | none => veil.smt.solver.get opts
  try
  trace[veil.smt.debug] "solver: {solverName}"
  let solver ← createSolver solverName withTimeout
  emitCommandStr solver goalQuery
  emitCommand solver .checkSat
  let stdout ← solver.stdout.getLine
  trace[veil.smt.debug] "[checkSat] stdout: {stdout}"
  trace[veil.smt.debug] "[checkSat] stderr {← solver.stderr.readToEnd}"
  let (checkSatResponse, _) ← Auto.Solver.SMT.getSexp stdout
  match checkSatResponse with
  | .atom (.symb "sat") =>
    trace[veil.smt.result] "{solverName} says Sat"
    emitCommand solver .getModel
    let (_, solver) ← solver.takeStdin
    let stdout ← solver.stdout.readToEnd
    let stderr ← solver.stderr.readToEnd
    trace[veil.smt.debug] "stdout: {stdout}"
    trace[veil.smt.debug] "stderr: {stderr}"
    let (model, _) ← Auto.Solver.SMT.getSexp stdout
    solver.kill
    return (SmtResult.Sat s!"{model}", solverName)

  | .atom (.symb "unsat") =>
    trace[veil.smt.result] "{solverName} says Unsat"
    let (_, solver) ← solver.takeStdin
    let stdout ← solver.stdout.readToEnd
    let stderr ← solver.stderr.readToEnd
    trace[veil.smt.debug] "stdout: {stdout}"
    trace[veil.smt.debug] "stderr: {stderr}"
    solver.kill
    return (SmtResult.Unsat, solverName)

  | .atom (.symb "unknown") =>
    trace[veil.smt.result] "{solverName} says Unknown"
      if retryOnUnknown then
        let newSolver := solverToTryOnUnknown solverName
        trace[veil.smt.debug] "Retrying with {newSolver}"
        querySolver goalQuery withTimeout (forceSolver := .some newSolver) (retryOnUnknown := false)
      else
        let (_, solver) ← solver.takeStdin
        let stdout ← solver.stdout.readToEnd
        let stderr ← solver.stderr.readToEnd
        trace[veil.smt.debug] "stdout: {stdout}"
        trace[veil.smt.debug] "stderr: {stderr}"
        solver.kill
        return (SmtResult.Unknown .none, solverName)

  | _ => throwError s!"Unexpected response from solver: {checkSatResponse}"
  catch e =>
    let exMsg ← e.toMessageData.toString
    return (.Failure s!"{exMsg}", solverName)

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

macro "test_check_invariants" : command => `(command|

macro "test_check_action_recv" : command => `(command|

macro "test_check_action_send" : command => `(command|

macro "test_check_invariant_single_leader" : command => `(command|

action enter (requester: node) = {
  require ∀ N, (N ≠ requester) → replied requester N;
  holds requester := True
}

action leave (requester : node) = {
  require holds requester;
  holds requester := False;
  replied requester N := False
}

safety [mutual_exclusion] (holds N1 ∧ holds N2) → N1 = N2
invariant N1 ≠ N2 → ¬(replied N1 N2 ∧ replied N2 N1)
invariant (N1 ≠ N2 ∧  holds N1) → replied N1 N2

#gen_spec

#time #check_invariants

action succ (n : seq_t) = {
  let k : seq_t ← fresh;
  require seq.next k n;
  return k
}

#guard_msgs in

action return_two (n : seq_t) = {
  let m ← fresh seq_t
  return (n, m)
}

#guard_msgs in

action pattern_bind (n : seq_t) = {
  let (z, y) ← return_two n
  return z
}

#guard_msgs in

action create_one = {
  let one ← succ seq.zero
  return one
}


#guard_msgs in

action capital_assign = {
  let one : seq_t ← succ seq.zero
  
  n_token_seq N := if N = init_node then one else seq.zero

}

 
#guard_msgs(drop error, drop warning) in

action call_in_capital_assign = {
  n_token_seq N := if N = init_node then ← succ seq.zero else seq.zero
}

invariant True

#gen_spec

inductive CheckStyle
   
  | noCheck
   
  | checkTheoremsWithIndicators
   
  | checkTheoremsIndividually

inductive TheoremSuggestionStyle
   
  | doNotPrint
   
  | printAllTheorems
   
  | printUnverifiedTheorems

inductive ProofKind
  | checkedByLean
  | trustingSolver

instance : ToString ProofKind where
  toString kind := match kind with
    | .checkedByLean => ""
    | .trustingSolver => " (trusting solver)"

instance : ToJson ProofKind where
  toJson kind := match kind with
    | .checkedByLean => "checkedByLean"
    | .trustingSolver => "trustingSolver"

instance : FromJson ProofKind where
  fromJson? s := match s with
    | "checkedByLean" => .ok .checkedByLean
    | "trustingSolver" => .ok .trustingSolver
    | _ => .error s!"unknown proof kind: {s}"

inductive ProofResult
  | proven (kind : ProofKind)
  | notProven
deriving Inhabited

instance : ToJson ProofResult where
  toJson res := match res with
    | .proven kind => Json.arr #["proven", toJson kind]
    | .notProven => "not proven"

instance : FromJson ProofResult where
  fromJson? s := match s with
    | Json.arr #["proven", kind] => fromJson? kind >>= fun kind => .ok (.proven kind)
    | Json.str "not proven" => .ok .notProven
    | _ => .error s!"unknown proof result: {s}"

structure CheckTheoremResult where
  theoremId : TheoremIdentifier
  proofResult : ProofResult
  smtResult : SmtResult
  timeInMs : Nat
  modelStr : Option String
deriving Inhabited, ToJson, FromJson

abbrev CheckTheoremResultStringMarker := "[VEIL_CHECK_RESULT]\n"

instance : ToString ProofResult where
  toString res := match res with
    | .proven kind => s!"proven{kind}"
    | .notProven => "not proven"

def ProofResult.isProven (res : ProofResult) : Bool := match res with
  | .proven _ => true
  | .notProven => false

def ProofResult.isAdmitted (res : ProofResult) : Bool := match res with
  | .proven (.trustingSolver) => true
  | _ => false

def CheckInvariantsBehaviour := VCGenStyle × CheckStyle × TheoremSuggestionStyle

def CheckInvariantsBehaviour.default [Monad m] [MonadOptions m] : m CheckInvariantsBehaviour := do
  let vcGen := veil.vc_gen.get (← getOptions)
  return (vcGen, .checkTheoremsIndividually, .doNotPrint)

def CheckInvariantsBehaviour.question [Monad m] [MonadOptions m] : m CheckInvariantsBehaviour := do
  let vcGen := veil.vc_gen.get (← getOptions)
  return (vcGen, .noCheck, .printAllTheorems)

def CheckInvariantsBehaviour.exclamation [Monad m] [MonadOptions m] : m CheckInvariantsBehaviour := do
  let vcGen := veil.vc_gen.get (← getOptions)
  return (vcGen, .checkTheoremsIndividually, .printUnverifiedTheorems)

def getAllChecks (isolates : NameHashSet := ∅) : CommandElabM (Array (Name × Expr) × Array ((Name × Expr) × (Name × Expr))) := Command.runTermElabM fun _ => do
    let mut invs := (← localSpecCtx.get).spec.invariants
    unless isolates.isEmpty do
      invs := invs.filter fun inv => isolates.any inv.isolates.contains
    let invNames := invs.map StateAssertion.name
    let actNames := ((<- localSpecCtx.get).spec.actions).map (fun s => s.name)
    let invNamesInds := invNames.map (fun name => (name, Lean.mkConst $ Name.mkSimple s!"invInd_{mkPrintableName name}"))
    let actNamesInds := actNames.map (fun name => (name, Lean.mkConst $ Name.mkSimple s!"actInd_{mkPrintableName name}"))
    let mut actChecks := #[]
    for inv in invNamesInds do
       for act in actNamesInds do
         actChecks := actChecks.push (inv, act)
    return (invNamesInds, actChecks)

def getChecksForInvariant (invName : Name) : CommandElabM (Array (Name × Expr) × Array ((Name × Expr) × (Name × Expr))) := Command.runTermElabM fun _ => do
    let actNames := ((<- localSpecCtx.get).spec.actions).map (fun s => s.name)
    let invNamesInd := (invName, Lean.mkConst $ Name.mkSimple s!"invInd_{mkPrintableName invName}")
    let actNamesInds := actNames.map (fun name => (name, Lean.mkConst $ Name.mkSimple s!"actInd_{mkPrintableName name}"))
    let mut actChecks := #[]
    for act in actNamesInds do
        actChecks := actChecks.push (invNamesInd, act)
    return (#[invNamesInd], actChecks)

def getChecksForAction (actName : Name) : CommandElabM (Array (Name × Expr) × Array ((Name × Expr) × (Name × Expr))) := Command.runTermElabM fun _ => do
    let invNames := (← localSpecCtx.get).spec.invariants.map StateAssertion.name
    let invNamesInds := invNames.map (fun name => (name, Lean.mkConst $ Name.mkSimple s!"invInd_{mkPrintableName name}"))
    let actNamesInd := (actName, Lean.mkConst $ Name.mkSimple s!"actInd_{mkPrintableName actName}")
    let mut invChecks := #[]
    for inv in invNamesInds do
        invChecks := invChecks.push (inv, actNamesInd)
    return (#[], invChecks)

def mkTheoremName (actName : Name) (invName : Name) : Name := s!"{mkStrippedName actName}_{mkStrippedName invName}".toName

def mkTrTheoremName (actName : Name) (invName : Name) : Name := mkTheoremName (toTrName actName) invName

def theoremSuggestionsForChecks (initIndicators : List Name) (actIndicators : List (Name × Name)) (vcStyle : VCGenStyle) (sorry_body: Bool := true): CommandElabM (Array (TheoremIdentifier × TSyntax `command)) := do
    Command.runTermElabM fun vs => do
      let (systemTp, stateTp, st, st') := (← getSystemTpStx vs, ← getStateTpStx, mkIdent `st, mkIdent `st')
      let sectionArgs ← getSectionArgumentsStx vs
      let mut theorems : Array (TheoremIdentifier × TSyntax `command) := #[]
      
      for invName in initIndicators.reverse do
        let invStx ← `(@$(mkIdent invName) $sectionArgs*)
        let initTpStx ← `(∀ ($st : $stateTp), ($systemTp).$(mkIdent `assumptions) $st → ($systemTp).$(mkIdent `init) $st → $invStx $st)
        let body ← if sorry_body then `(by admit /- proof elided -/
        ) else `(by admit /- proof elided -/
        )
        let thmName := mkTheoremName `init invName
        let thm ← `(@[invProof] theorem $(mkIdent thmName) : $initTpStx := $body)
        theorems := theorems.push (⟨invName, .none, thmName⟩, thm)
      
      for (actName, invName) in actIndicators.reverse do
        let (tp, body) ← match vcStyle with
        | .transition =>
          let trName := toTrName actName
          let invStx ← `(@$(mkIdent invName) $sectionArgs*)
          let trStx ← `(@$(mkIdent trName) $sectionArgs*)
          let trTpSyntax ← `(∀ ($st $st' : $stateTp), ($systemTp).$(mkIdent `assumptions) $st → ($systemTp).$(mkIdent `inv) $st → $trStx $st $st' → $invStx $st')
          let body ← if sorry_body then `(by admit /- proof elided -/
          ) else `(by admit /- proof elided -/
          )
          pure (trTpSyntax, body)
        | .wp =>
          let extName := toExtName actName
          let moduleName <- getCurrNamespace
          let some args := (<- localSpecCtx.get).spec.actions.find? (moduleName ++ ·.name == actName)
            | throwError s!"action {actName} not found"
          let (univBinders, args) ← match args.br with
          | some br => pure (← toBracketedBinderArray br, ← explicitBindersIdents br)
          | none => pure (#[], #[])
          let invStx ← `(fun _ ($st' : $stateTp) => @$(mkIdent invName) $sectionArgs*  $st')
          let extStx ← `(@$(mkIdent extName) $sectionArgs* $args*)
          let extTpSyntax ← `(∀ ($st : $stateTp), forall? $univBinders*, ($systemTp).$(mkIdent `assumptions) $st → ($systemTp).$(mkIdent `inv) $st → $extStx $st $invStx)
          let extTpSyntax : TSyntax `term ← TSyntax.mk <$> (Elab.liftMacroM <| expandMacros extTpSyntax)
          let body ← if sorry_body then `(by admit /- proof elided -/
          ) else `(by admit /- proof elided -/
          )
          pure (extTpSyntax, body)
        let thmName := if vcStyle == .wp then mkTheoremName actName invName else mkTrTheoremName actName invName
        let thm ← `(@[invProof] theorem $(mkIdent thmName) : $tp := $body)
        theorems := theorems.push (⟨invName, .some actName, thmName⟩, thm)
      return theorems

def theoremSuggestionsForIndicators (generateInitThms : Bool) (actIndicators invIndicators : List (Name × Expr)) (vcStyle : VCGenStyle) (sorry_body: Bool := false): CommandElabM (Array (TheoremIdentifier × TSyntax `command)) := do
  let (initIndicators, acts) ← Command.runTermElabM fun _ => do
    
    let initIndicators ← invIndicators.mapM (fun (invName, _) => resolveGlobalConstNoOverloadCore invName)
    let actIndicators ← actIndicators.mapM (fun (actName, _) => resolveGlobalConstNoOverloadCore actName)
    let mut acts := #[]
    for actName in actIndicators do
      for invName in initIndicators do
        acts := acts.push (actName, invName)
    return (initIndicators, acts)
  theoremSuggestionsForChecks (if generateInitThms then initIndicators else []) acts.toList vcStyle sorry_body

def checkIndividualTheorem (thmId : TheoremIdentifier) (cmd : TSyntax `command) : CommandElabM ProofResult := do
  let env ← getEnv
  
  
  if (← resolveGlobalName thmId.theoremName).isEmpty then
    trace[veil.debug] "Checking theorem {thmId.theoremName} for the first time"
    elabCommand (← `(#guard_msgs(drop warning) in $(cmd)))
  else
    trace[veil.debug] "Theorem {thmId.theoremName} has been checked before; reusing result"
  
  let thFullName ← resolveGlobalConstNoOverloadCore thmId.theoremName
  let th ← getConstInfo thFullName
  let (isProven, proofKind) ← match th with
    | ConstantInfo.thmInfo attempt =>
      
      
      let isProven := !attempt.value.hasSyntheticSorry
      let proofKind := if attempt.value.hasSorry then ProofKind.trustingSolver else ProofKind.checkedByLean
      pure (isProven, proofKind)
    | _ => throwError s!"checkTheorem: expected {thmId.theoremName} to be a theorem"
  
  
  if !isProven then
    setEnv env
  let result := if isProven then .proven proofKind else .notProven
  return result

def parseStrAsJson [Monad m] [MonadError m] (str : String) : m Json := do
  match Json.parse str with
  | .ok json => return json
  | .error err => throwError s!"could not parse {str} as Json: {err}"

def MessageLog.containsSubStr (msgs : MessageLog) (substr : String) : CommandElabM Bool := do
  msgs.toList.anyM (fun msg => return String.isSubStrOf substr (← msg.data.toString))

def List.removeDuplicates [BEq α] (xs : List α) : List α :=
  xs.foldl (init := []) fun acc x =>
    if acc.contains x then acc else x :: acc

def checkTheorems (stx : Syntax) (initChecks: Array (Name × Expr)) (invChecks: Array ((Name × Expr) × (Name × Expr))) (behaviour : CheckInvariantsBehaviour) :
  CommandElabM Unit := do
  let actIndicators := (invChecks.map (fun (_, (act_name, ind_name)) => (act_name, ind_name))).toList |> List.removeDuplicates
  let invIndicators := (invChecks.map (fun ((inv_name, ind_name), _) => (inv_name, ind_name))).toList |> List.removeDuplicates
  let (vcStyle, _checkStyle, suggestionStyle) := behaviour
  let allTheorems ← theoremSuggestionsForIndicators (!initChecks.isEmpty) actIndicators invIndicators vcStyle
  match behaviour with
  | (_, .noCheck, .doNotPrint) => pure ()
  | (_, .noCheck, .printUnverifiedTheorems) => throwError "[checkTheorems] Cannot print unverified theorems without checking"
  | (_, .noCheck, .printAllTheorems) => displaySuggestion stx (allTheorems.map Prod.snd)
  | (_, .checkTheoremsIndividually, _) =>
    let processThm (theoremId : TheoremIdentifier) (cmd : TSyntax `command) : CommandElabM CheckTheoremResult := do
      \n" (← msgs.toList.filterMapM (fun msg => if msg.severity == .error then msg.toString else pure none))
        let (hasSat, hasUnknown, hasFailure) := (← MessageLog.containsSubStr msgs Veil.SMT.satGoalStr, ← MessageLog.containsSubStr msgs Veil.SMT.unknownGoalStr, ← MessageLog.containsSubStr msgs Veil.SMT.failureGoalStr)
        modelStr := if hasSat then .some $ (s!"{theoremId.theoremName}" ++ (getModelStr msgsTxt) ++ "\n") else .none
        pure $ match hasSat, hasUnknown, hasFailure with
        | true, false, false => SmtResult.Sat .none
        | false, true, false => SmtResult.Unknown msgsTxt
        | false, false, true => SmtResult.Failure msgsTxt
        | _, _, _ =>
          dbg_trace s!"[{theoremId.theoremName}] (isProveproofResultsult}, hasSat: {hasSat}, hasUnknown: {hasUnknown}, hasFailure: {hasFailure}) Unexpected messages: {msgsTxt}"
          unreachable!
      \n" (← tree.element.diagnostics.msgLog.toList.filterMapM (fun msg => do
            let msgStr ← msg.toString
            if msg.severity == .information && msgStr.startsWith CheckTheoremResultStringMarker then
              pure $ msgStr.stripPrefix CheckTheoremResultStringMarker
            else pure none))
          let json ← parseStrAsJson msgsTxt
          let mut checkResult : Option CheckTheoremResult := .none
          match fromJson? json with
          | .ok cr => checkResult := .some cr
          | .error err => throwError s!"could not parse {msgsTxt} as CheckTheoremResult: {err}"
          pure checkResult.get!
        )
        results
      else
        let results ← allTheorems.mapM (fun (thmId, cmd) => processThm thmId cmd)
        pure results.toList

    \nCounter-examples", "================\n"] ++ modelStrs.toList
    let msg := ("\n".intercalate (checkMsgs.toList ++ modelMsgs))
    logInfo msg
    match suggestionStyle with
    | .doNotPrint => pure ()
    | .printAllTheorems => displaySuggestion stx (allTheorems.map Prod.snd)
    | .printUnverifiedTheorems =>
      let unverifiedTheoremIds := ((initIdAndResults ++ thmIdAndResults).filter (fun res => match res with
        | (_, .Unsat, _) => false
        | _ => true)).map (fun (id, _) => id)
      let unverifiedTheorems := (allTheorems.filter (fun (id, _) => unverifiedTheoremIds.any (fun id' => id == id'))).map Prod.snd
      displaySuggestion stx unverifiedTheorems
    if !unprovenTheorems.isEmpty && (!veil.printCounterexamples.get (← getOptions)) then
      logInfo s!"Run with `set_option veil.printCounterexamples true` to print counter-examples."
    if !admittedTheorems.isEmpty then
      \n" initMsgs.toList) ++ "\n" ++ (String.intercalate "\n" actMsgs.toList) ++ "\n"
      return (msg, initRes, actRes)

    )

def checkInvariants (stx : Syntax) (behaviour : CheckInvariantsBehaviour)
  (isolate : NameHashSet := ∅) : CommandElabM Unit := do
  liftCoreM (do errorIfStateNotDefined; warnIfNoInvariantsDefined; warnIfNoActionsDefined)
  let (initChecks, actChecks) ← getAllChecks isolate
  checkTheorems stx initChecks actChecks behaviour

def checkIsolate (stx : Syntax) (behaviour : CheckInvariantsBehaviour)
  (isolates : Array Ident) : CommandElabM Unit := do
  for iso in isolates do
    unless (<- localSpecCtx.getIsolates).isolateStore.contains iso.getId do
      throwErrorAt iso s!"Isolate {iso.getId} not found in the current context."
  checkInvariants stx behaviour (isolate := Std.HashSet.ofArray <| isolates.map TSyntax.getId)

def checkInvariant (stx : Syntax) (invName : TSyntax `ident) (behaviour : CheckInvariantsBehaviour) : CommandElabM Unit := do
  liftCoreM errorIfStateNotDefined
  let (initChecks, actChecks) ← getChecksForInvariant invName.getId
  checkTheorems stx initChecks actChecks behaviour

def checkAction (stx : Syntax) (actName : TSyntax `ident) (behaviour : CheckInvariantsBehaviour) : CommandElabM Unit := do
  liftCoreM errorIfStateNotDefined
  let (initChecks, actChecks) ← getChecksForAction actName.getId
  checkTheorems stx initChecks actChecks behaviour

elab "prove_inv_init" proof:term : command => do
  liftCoreM errorIfStateNotDefined
  elabCommand $ <- Command.runTermElabM fun _ => do
    let stateTp <- getStateTpStx
    let invInit := mkIdent ``RelationalTransitionSystem.invInit
    `(theorem $(mkIdent `inv_init) : $invInit (σ := $stateTp) :=
       by admit /- proof elided -/
          )

elab "prove_inv_safe" proof:term : command => do
  liftCoreM errorIfStateNotDefined
  elabCommand $ <- Command.runTermElabM fun _ => do
    let stateTp <- getStateTpStx
    let invSafe := mkIdent ``RelationalTransitionSystem.invSafe
    `(theorem $(mkIdent `safety_init) : $invSafe (σ := $stateTp) :=
       by admit /- proof elided -/
          )

elab "prove_inv_inductive" proof:term : command => do
  liftCoreM errorIfStateNotDefined
  elabCommand $ <- Command.runTermElabM fun _ => do
    let stateTp <- getStateTpStx
    let invInductive := mkIdent ``RelationalTransitionSystem.invInductive
    `(theorem $(mkIdent `inv_inductive) : $invInductive (σ := $stateTp) :=
      by admit /- proof elided -/
         )

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  
  
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

#time #check_invariants

action thisshouldntfail = {
  setTrue
  assert x
}

action thisshouldntfail_2 = {
  let _f ← setTrue
  assert x
}

action becauseitshouldmeanthesameasthis = {
  x := True
  assert x
}

#guard_msgs(drop warning) in
#gen_spec

invariant [x_is_true] x

private def getDefInfoTemp (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
  match (← getTransparency) with
  | .all => return some info
  | .default => return some info
  | _ =>
    if (← isReducible info.name) then
      return some info
    else
      return none

private def getConstTemp? (constName : Name) : MetaM (Option ConstantInfo) := do
  match (← getEnv).find? constName with
  | some (info@(ConstantInfo.thmInfo _))  => getTheoremInfo info
  | some (info@(ConstantInfo.defnInfo _)) => getDefInfoTemp info
  | some info                             => pure (some info)
  | none                                  => throwUnknownConstant constName

private def fvarsSizeLtMaxFVars (fvars : Array Expr) (maxFVars? : Option Nat) : Bool :=
  match maxFVars? with
  | some maxFVars => fvars.size < maxFVars
  | none          => true

private def isClassQuickConst? (constName : Name) : MetaM (LOption Name) := do
  if isClass (← getEnv) constName then
    return .some constName
  else
    match (← getConstTemp? constName) with
    | some (.defnInfo ..) => return .undef 
    | _ => return .none

private partial def isClassQuick? : Expr → MetaM (LOption Name)
  | .bvar ..         => return .none
  | .lit ..          => return .none
  | .fvar ..         => return .none
  | .sort ..         => return .none
  | .lam ..          => return .none
  | .letE ..         => return .undef
  | .proj ..         => return .undef
  | .forallE _ _ b _ => isClassQuick? b
  | .mdata _ e       => isClassQuick? e
  | .const n _       => isClassQuickConst? n
  | .mvar mvarId     => do
    let some val ← getExprMVarAssignment? mvarId | return .none
    isClassQuick? val
  | .app f _         => do
    match f.getAppFn with
    | .const n ..  => isClassQuickConst? n
    | .lam ..      => return .undef
    | .mvar mvarId =>
      let some val ← getExprMVarAssignment? mvarId | return .none
      match val.getAppFn with
      | .const n .. => isClassQuickConst? n
      | _ => return .undef
    | _            => return .none

def isExists (e : Expr) : Bool :=
  match_expr e with
  | Exists _ _ => true
  | _          => false

  private partial def withNewLocalInstancesImp
      (fvars : Array Expr) (i : Nat) (k : MetaM α) : MetaM α := do
    if h : i < fvars.size then
      let fvar := fvars[i]
      let decl ← getFVarLocalDecl fvar
      match (← isClassQuick? decl.type) with
      | .none   => withNewLocalInstancesImp fvars (i+1) k
      | .undef  =>
        match (← isClassExpensive? decl.type) with
        | none   => withNewLocalInstancesImp fvars (i+1) k
        | some c => withNewLocalInstance c fvar <| withNewLocalInstancesImp fvars (i+1) k
      | .some c => withNewLocalInstance c fvar <| withNewLocalInstancesImp fvars (i+1) k
    else
      k

  private partial def existsTelescopeReducingAuxAux
      (reducing          : Bool)
      (type              : Expr)
      (k                 : Array Expr → Expr → MetaM α) (cleanupAnnotations : Bool) : MetaM α := do
    let rec process (lctx : LocalContext) (fvars : Array Expr) (j : Nat) (type : Expr) : MetaM α := do
      match_expr type with
      | Exists _ lamtype =>
        let .lam n d b bi := lamtype | throwError "unexpected exists type {lamtype}"
        let d     := d.instantiateRevRange j fvars.size fvars
        let d     := if cleanupAnnotations then d.cleanupAnnotations else d
        let fvarId ← mkFreshFVarId
        let lctx  := lctx.mkLocalDecl fvarId n d bi
        let fvar  := mkFVar fvarId
        let fvars := fvars.push fvar
        process lctx fvars j b
      | _ =>
        let type := type.instantiateRevRange j fvars.size fvars;
        withLCtx' lctx do
          withNewLocalInstancesImp fvars j do
            if reducing then
              let newType ← whnf type
              if isExists newType then
                process lctx fvars fvars.size newType
              else
                k fvars type
            else
              k fvars type
    process (← getLCtx) #[] 0 type

  private partial def existsTelescopeReducingAux (type : Expr) (k : Array Expr → Expr → MetaM α) (cleanupAnnotations : Bool) : MetaM α := do
      let newType ← whnf type
      if isExists newType then
        existsTelescopeReducingAuxAux true newType k cleanupAnnotations
      else
        k #[] type

  private partial def isClassApp? (type : Expr) (instantiated := false) : MetaM (Option Name) := do
    match type.getAppFn with
    | .const c _ =>
      let env ← getEnv
      if isClass env c then
        return some c
      else
        
        match (← whnf type).getAppFn with
        | .const c _ => if isClass env c then return some c else return none
        | _ => return none
    | .mvar .. =>
      if instantiated then return none
      isClassApp? (← instantiateMVars type) true
    | _ => return none

  private partial def isClassExpensive? (type : Expr) : MetaM (Option Name) :=
    withReducible do 
      existsTelescopeReducingAux type (cleanupAnnotations := false) fun _ type => isClassApp? type

  private partial def isClassImp? (type : Expr) : MetaM (Option Name) := do
    match (← isClassQuick? type) with
    | .none   => return none
    | .some c => return (some c)
    | .undef  => isClassExpensive? type

def existsTelescopeReducing (type : Expr) (k : Array Expr → Expr → n α) (cleanupAnnotations := false) : n α :=
  map2MetaM (fun k => existsTelescopeReducingAux type k cleanupAnnotations) k

inductive checkMode where
  | goal
  | hypothesis

def quantMetaTelescopeReducing (e : Expr) (mode : checkMode) (k : Array Expr → Expr → n α) : n α :=
  match mode with
  | .goal => forallTelescopeReducing e k
  | .hypothesis => existsTelescopeReducing e k

inductive QuantType where
  | forall
  | exists

instance : ToString QuantType where
  toString
    | QuantType.forall => "∀"
    | QuantType.exists => "∃"

structure QEState where
  quantifiedTypes : List (QuantType × Name × Expr)
deriving Inhabited

abbrev QuantElimM := StateT QEState n

def isHigherOrder (e : Expr) : MetaM Bool := do
  let t ← inferType e
  let isHO := (!t.isProp) && (e.isArrow || e.isAppOf (← getStateName))
  return isHO

partial def forEachExprSane'
  (input : Expr)
  (fn : Expr → n Bool)
  : n Unit := do
  let _ : STWorld IO.RealWorld n := ⟨⟩
  let _ : MonadLiftT (ST IO.RealWorld) n := { monadLift := fun x => liftM (m := MetaM) (liftM (m := ST IO.RealWorld) x) }
  let rec visit (e : Expr) : MonadCacheT Expr Unit n Unit :=
    checkCache e fun _ => do
      if (← liftM (fn e)) then
        match e with
        | .forallE n d b c  => do visit d; withLocalDecl n c d (fun x => visit $ b.instantiate1 x)
        | .lam n d b c      => do visit d; withLocalDecl n c d (fun x => visit $ b.instantiate1 x)
        | .letE n d v b _   => do visit d; visit v; withLetDecl n d v (fun x => visit $ b.instantiate1 x)
        | .app f a      => visit f; visit a
        | .mdata _ b    => visit b
        | .proj _ _ b   => visit b
        | _             => return ()
  visit input |>.run

def forEachExprSane (e : Expr) (f : Expr → n Unit) : n Unit :=
  forEachExprSane' e fun e => do
    f e
    return true

action mark_complete (r : round) = {
  require complete_msg r
  if ¬ tot.le r master_complete then
    master_complete := r
}


action send_1a (r : round) (c : config) (cr : round) = {
  require configure_round_msg r c
  require cr = complete_of c
  one_a r R := one_a r R ∨ (tot.le cr R ∧ ¬ tot.le r R)
 }

 action join_round (n : node) (r : round) (rp : round) = {
  require one_a r rp
  require ¬ (∃ r' rp' v, join_ack_msg n r' rp' v ∧ ¬ tot.le r' r)
  let mut v : value ← fresh
  if ∀ V, ¬ vote n rp V then
    v := none
  else
    require vote n rp v
  join_ack_msg n r rp v := True
 }

action propose (r : round) (c : config) (cr : round) = {
  quorum_of_round R := *
  require configure_round_msg r c
  require complete_of c = cr
  require ∀ V, ¬ proposal r V
  require ∀ R, tot.le cr R ∧ ¬ tot.le r R → ∃ c, configure_round_msg R c
  require ∀ R C, tot.le cr R ∧ ¬ tot.le r R ∧ configure_round_msg R C → quorumin (quorum_of_round R) C
  require ∀ R N, tot.le cr R ∧ ¬ tot.le r R ∧ member N (quorum_of_round R) → ∃ v, join_ack_msg N r R v
  let mut v : value ← fresh
  let maxr : round ← fresh
  assume ((v = none ∧ forall N MAXR V,
                      ¬ (tot.le cr MAXR ∧ ¬tot.le r MAXR ∧ member N (quorum_of_round MAXR)) ∧ join_ack_msg N r MAXR V ∧ V ≠ none) ∨
                      (v ≠ none ∧
                      (exists N:node, tot.le cr maxr ∧ ¬tot.le r maxr ∧ member N (quorum_of_round maxr) ∧ join_ack_msg N r maxr v ∧ v ≠ none) ∧
                      (forall N MAXR V,
                       (tot.le cr MAXR  ∧ ¬tot.le r MAXR ∧ member N (quorum_of_round MAXR) ∧ join_ack_msg N r MAXR V ∧ V ≠ none) -> tot.le MAXR maxr)
                    ));
  if v = none then
    v := *
    require v ≠ none
    complete_msg r := True
  proposal r v := True
}

action cast_vote (n : node) (v : value) (r : round) = {
  require v ≠ none
  require ¬ (∃ (r' : round) (rp : round) (v' : value), join_ack_msg n r' rp v' ∧ ¬ tot.le r' r)
  require proposal r v
  vote n r v := True
}

action decide (n : node) (r : round) (c : config) (v : value) (q : quorum) = {
  require v ≠ none
  require configure_round_msg r c
  require quorumin q c
  require ∀ N, member N q → vote N r v
  decision n r v := True
  complete_msg r := True
}

safety [coherence] (decision N1 R1 V1 ∧ decision N2 R2 V2) → V1 = V2

invariant [proposal_unique] proposal R V1 ∧ proposal R V2 → V1 = V2

invariant [unique_config] configure_round_msg R C1 ∧ configure_round_msg R C2 → C1 = C2

invariant [property1_one_a] one_a R RP → ¬ tot.le R RP

invariant [property2_one_a] one_a R RP → ∃ c, configure_round_msg R c

invariant [only_vote_proposed] vote N R V → proposal R V

invariant [propose_if_lower_configured] proposal R2 V ∧ tot.le R1 R2 → ∃ c, configure_round_msg R1 c

invariant [master_complete_zero_or_holds] (R2 = master_complete ∨ (configure_round_msg R3 C ∧ complete_of C = R2)) ∧ ¬ tot.le R2 R1 → complete_msg R2

invariant [complete_prev_configured] complete_msg R2 ∧ tot.le R1 R2 → ∃ c, configure_round_msg R1 c

invariant [decisions_from_quorums] (∃ n, decision n R V) → ∃ c q, configure_round_msg R c ∧ quorumin q c ∧ (∀ n, member n q → vote n R V)

invariant [choosable_proposal] ¬ tot.le R2 R1 ∧ proposal R2 V2 ∧ V1 ≠ V2 ∧
  configure_round_msg R1 C ∧ quorumin Q C → ∃ n r3 rp v, member n Q ∧ ¬ tot.le r3 R1 ∧ join_ack_msg n r3 rp v ∧ ¬ vote n R1 V1

invariant [configure_round_msg] configure_round_msg R C → tot.le (complete_of C) R ∧ tot.le (complete_of C) master_complete

invariant [complete_choosable_decision] complete_msg RR ∧ ¬ tot.le RR R ∧ configure_round_msg R C ∧ quorumin Q C ∧
          ¬ (∃ n r3 rp vp, member n Q ∧ ¬ tot.le r3 R ∧ join_ack_msg n r3 rp vp ∧ ¬ vote n R V)
          → ∃ nn, decision nn RR V

invariant [none_property1] ¬proposal R none

invariant [none_property2] ¬vote N R none

invariant [none_property3] ¬decision N R none

invariant [join_ack_msg_property1] join_ack_msg N R RP V → one_a R RP

invariant [join_ack_msg_property2] join_ack_msg N R RP none → ¬ vote N RP V

invariant [join_ack_msg_property3] join_ack_msg N R RP V ∧ V ≠ none → vote N RP V

#gen_spec

inductive VCGenStyle
  | wp
  | transition
deriving Inhabited, BEq

instance : ToString VCGenStyle where
  toString
    | .wp => "wp"
    | .transition => "transition"

instance : Lean.KVMap.Value VCGenStyle where
  toDataValue n := toString n
  ofDataValue?
  | "wp"  => some .wp
  | "transition" => some .transition
  | _     => none


register_option veil.perf.profile.checkInvariants : Bool := {
  defValue := false
  descr := "Profile performance of Veil's `#check_invariants`."
}

register_option veil.gen_sound : Bool := {
  defValue := false
  descr := "Generate soundness instances for actions."
}

register_option veil.vc_gen : VCGenStyle := {
  defValue := .wp
  descr := "Verification condition generation style: wp or transition (default: wp)"
}

register_option veil.printCounterexamples : Bool := {
  defValue := false
  descr := "Print counterexamples (models) when they are found in `#check_invariants`."
}

register_option veil.failedCheckThrowsError : Bool := {
  defValue := true
  descr := "Throw an error if a check fails? (default: true)"
}

register_option veil.showVerificationTime : Bool := {
  defValue := false
  descr := "Show the time taken to verify each invariant clause."
}

register_option veil.smt.solver : SmtSolver := {
  defValue := SmtSolver.cvc5
  descr := "SMT solver to use (default: cvc5)"
}

register_option veil.smt.seed : Nat := {
  defValue := 0xcafe
  descr := "SMT seed to use"
}

register_option veil.smt.retryOnUnknown : Bool := {
  defValue := true
  descr := "Should the query be retried with a different SMT solver if it the first check returns `unknown`? (default: true)"
}

register_option veil.smt.timeout : Nat := {
  defValue := 5
  descr := "SMT timeout to use (in seconds)"
}

register_option veil.smt.finiteModelFind : Bool := {
  defValue := true
  descr := "Should the `
}

register_option veil.smt.model.minimize : Bool := {
  defValue := false
  descr := "Should models be minimized before being displayed?"
}

register_option veil.smt.translator : SmtTranslator := {
  defValue := SmtTranslator.leanAuto
  descr := "Which package to use for translating Lean to SMT (`lean-auto` or `lean-smt`)"
}

register_option veil.smt.reconstructProofs : Bool := {
  defValue := false
  descr := "Whether to use Lean SMT's proof reconstruction"
}

 

 

 
register_simp_attr smtSimp

 
register_simp_attr ifSimp

 
register_simp_attr quantifierSimp

 
register_simp_attr logicSimp


 

 
register_simp_attr invSimpTopLevel

 
register_simp_attr invSimp

 
register_simp_attr safeSimp

 
register_simp_attr initSimp

 
register_simp_attr actSimp

 
register_simp_attr wpSimp

 
register_simp_attr generatorSimp

structure SmtState where
  binderIds : Std.HashMap Name UInt64 := {}
deriving Inhabited

private def uniqueBinder (e : Expr) : MetaM Expr := do
  match e with
  | .forallE bn bt body bi => return .forallE (← freshBinderName bn) bt body bi
  | .lam bn bt body bi => return .lam (← freshBinderName bn) bt body bi
  | .letE n t v b nd => return .letE (← freshBinderName n) t v b nd
  | _ => return e
  where freshBinderName (bn : Name) := do
    let ids := (← smtExt.get).binderIds
    let id := ids.getD bn 0
    let bn' := if id == 0 then bn else Name.mkSimple s!"{bn}{id}"
    smtExt.set { binderIds := ids.insert bn (id + 1) }
    return bn'

def uniqueBinders (e : Expr) : MetaM Expr := do
  smtExt.set { binderIds := default }
  let e' ← Core.transform e (pre := fun e => do
    return TransformStep.continue (← uniqueBinder e))
  return e'

def _root_.Lean.MVarId.replaceTargetDefEq' (mvarId : MVarId) (targetNew : Expr) : MetaM MVarId :=
  mvarId.withContext do
    mvarId.checkNotAssigned `change
    let target  ← mvarId.getType
    let tag     ← mvarId.getTag
    let mvarNew ← mkFreshExprSyntheticOpaqueMVar targetNew tag
    let newVal  ← mkExpectedTypeHint mvarNew target
    mvarId.assign newVal
    return mvarNew.mvarId!

action set_flag = {
  flag := True;
}

invariant ¬ flag

#gen_spec

#guard_msgs(drop warning) in
sat trace { } by bmc_sat

#guard_msgs(drop warning, drop info) in
sat trace {
  set_flag
  set_flag
} by bmc_sat

class Label (ℓ : Type) extends BEq ℓ, Hashable ℓ, ToString ℓ, Inhabited ℓ

instance [BEq ℓ] [Hashable ℓ] [ToString ℓ] [Inhabited ℓ] : Label ℓ := { }

inductive ActionKind where
  | internal
  | input
  | output
deriving BEq, Hashable

instance : Inhabited ActionKind where
  default := ActionKind.internal

instance : ToString ActionKind where
  toString
    | .internal => "internal"
    | .input => "input"
    | .output => "output"

inductive ActionLabel (ℓ : Type) [Label ℓ] where
  | internal (label : ℓ)
  | input (label : ℓ)
  | output (label : ℓ)
deriving BEq, Inhabited

instance [Label ℓ]: ToString (ActionLabel ℓ) where
  toString
    | ActionLabel.internal l => "internal " ++ toString l
    | ActionLabel.input l => "input " ++ toString l
    | ActionLabel.output l => "output " ++ toString l

def ActionLabel.type {ℓ : Type} [Label ℓ] : ActionLabel ℓ → ActionKind
  | .internal _ => .internal
  | .input _ => .input
  | .output _ => .output

def ActionLabel.name {ℓ : Type} [Label ℓ] : ActionLabel ℓ → ℓ
  | ActionLabel.internal l => l
  | ActionLabel.input l => l
  | ActionLabel.output l => l

def ActionLabel.mk {ℓ : Type} [Label ℓ] (t : ActionKind) (l : ℓ) : ActionLabel ℓ :=
  match t with
  | .internal => .internal l
  | .input => .input l
  | .output => .output l

structure ActionDeclaration where
  kind: ActionKind
  name: Lean.Name
  ctor : Option (TSyntax `Lean.Parser.Command.ctor)
deriving BEq, Inhabited

def ActionDeclaration.label (a : ActionDeclaration) : ActionLabel Name :=
  ActionLabel.mk a.kind a.name

instance : ToString ActionDeclaration where
  toString a := s!"{a.kind} {a.name} with ctor {a.ctor}"

structure Action (σ : Type) (ℓ : Type) [Label ℓ] where
  decl : ActionDeclaration
   
  next : (label : ℓ) → (σ → σ → Prop)
deriving Inhabited

instance [Label ℓ] : ToString (Action σ ℓ) where
  toString a := toString a.decl

def allGoals (tac : TacticM Unit) : TacticM Unit := do
  let mvarIds ← getGoals
  let mut mvarIdsNew := #[]
  for mvarId in mvarIds do
    unless (← mvarId.isAssigned) do
      setGoals [mvarId]
      try
        tac
        mvarIdsNew := mvarIdsNew ++ (← getUnsolvedGoals)
      catch ex =>
        if (← read).recover then
          logError ex.toMessageData
          mvarIdsNew := mvarIdsNew.push mvarId
        else
          throw ex
  setGoals mvarIdsNew.toList

def andThenOnSubgoals (tac1 : TacticM Unit) (tac2 : TacticM Unit) : TacticM Unit :=
  focus do tac1; allGoals tac2

private inductive SplitPosition
| target
| hyp (fvarId: FVarId)

private def getSplitCandidates (loc : Location) : TacticM (List (SplitPosition × Expr)) :=
match loc with
| Location.wildcard => do
   let candidates ← (← getLCtx).getFVarIds.mapM
     (fun fvarId ↦ do
       let typ ← instantiateMVars (← inferType (mkFVar fvarId))
       return (SplitPosition.hyp fvarId, typ))
   pure ((SplitPosition.target, ← getMainTarget) :: candidates.toList)
| Location.targets hyps tgt => do
   let candidates ← (← hyps.mapM getFVarId).mapM
     (fun fvarId ↦ do
       let typ ← instantiateMVars (← inferType (mkFVar fvarId))
       return (SplitPosition.hyp fvarId, typ))
   if tgt
   then return (SplitPosition.target, ← getMainTarget) :: candidates.toList
   else return candidates.toList

private partial def findIfToSplit? (e : Expr) : Option (Expr × Expr) :=
  match e.find? fun e => (e.isIte || e.isDIte) && !(e.getArg! 1 5).hasLooseBVars with
  | some iteApp =>
    let cond := iteApp.getArg! 1 5
    let dec := iteApp.getArg! 2 5
    
    findIfToSplit? cond |>.getD (cond, dec)
  | none => none

private def findIfCondAt (loc : Location) : TacticM (Option (SplitPosition × Expr)) := do
  for (pos, e) in (← getSplitCandidates loc) do
    if let some (cond, _) := findIfToSplit? e
    then return some (pos, cond)
  return none

private def discharge? (e : Expr) : SimpM (Option Expr) := do
  let e ← instantiateMVars e
  if let some e1 ← (← SplitIf.mkDischarge? false) e
    then return some e1
  if e.isConstOf `True
    then return some (mkConst `True.intro)
  return none

private def reduceIfsAt (loc : Location) : TacticM Unit := do
  let ctx ← SplitIf.getSimpContext
  let ctx := ctx.setFailIfUnchanged false
  let _ ← simpLocation ctx (← ({} : Simp.SimprocsArray).add `reduceCtorEq false) discharge? loc
  pure ()

private def splitIf1 (cond : Expr) (simps : Array Ident) (hName : Name) (loc : Location) : TacticM Unit := do
  let splitCases :=
    evalTactic (← `(tactic|
      (by_cases $(mkIdent hName) : $(← Elab.Term.exprToSyntax cond)) <;>
       simp only [$[$simps:ident],*] at $(mkIdent hName):ident))
  andThenOnSubgoals splitCases (reduceIfsAt loc)

private def getNextName (hNames: IO.Ref (List (TSyntax `Lean.binderIdent))) : MetaM Name := do
  match ← hNames.get with
  | [] => mkFreshUserName `h
  | n::ns => do hNames.set ns
                if let `(binderIdent| $x:ident) := n
                then pure x.getId
                else pure `_

private def valueKnown (cond : Expr) : TacticM Bool := do
  let not_cond := mkApp (mkConst `Not) cond
  for h in ← getLocalHyps do
    let ty ← instantiateMVars (← inferType h)
    if cond == ty then return true
    if not_cond == ty then return true
  return false

private partial def splitIfsCore
    (loc : Location)
    (simps : Array Ident)
    (hNames : IO.Ref (List (TSyntax `Lean.binderIdent)))
    (hNamesOut : IO.Ref (List Name)) :
    List Expr → TacticM Unit := fun done ↦ withMainContext do
  let some (_,cond) ← findIfCondAt loc
      | Meta.throwTacticEx `split_ifs (← getMainGoal) "no if-then-else conditions to split"

  
  let cond := if cond.isAppOf `Not then cond.getAppArgs[0]! else cond

  if done.contains cond then return ()
  let no_split ← valueKnown cond
  if no_split then
    andThenOnSubgoals (reduceIfsAt loc) (splitIfsCore loc simps hNames hNamesOut (cond::done) <|> pure ())
  else do
    let hName ← getNextName hNames
    hNamesOut.modify (hName :: ·)
    andThenOnSubgoals (splitIf1 cond simps hName loc) ((splitIfsCore loc simps hNames hNamesOut (cond::done)) <|>
      pure ())

@[command_elab Veil.moduleDeclaration]
def elabModuleDeclaration : CommandElab := fun stx => do
  match stx with
  | `(veil module $i:ident) => do
    let cmd ← `(namespace $i:ident

@[command_elab Veil.typeDeclaration]
def elabTypeDeclaration : CommandElab := fun stx => do
  match stx with
  | `(type $id:ident) => do
    let dec_id := Lean.mkIdent (Name.mkSimple s!"{id.getId}_dec")
    let ne_id := Lean.mkIdent (Name.mkSimple s!"{id.getId}_ne")
    let deceq := Lean.mkIdent ``DecidableEq
    let nemp := Lean.mkIdent ``Nonempty
    let cmd ← `(variable ($id : Type) [$dec_id : $deceq $id] [$ne_id : $nemp $id])
    elabCommand cmd
  | _ => throwUnsupportedSyntax

@[command_elab Veil.enumDeclaration]
def elabEnumDeclaration : CommandElab := fun stx => do
  match stx with
  | `(enum $id:ident = { $[$elems:ident],* }) => do
    
    elabCommand $ ← `(type $id)
    
    let variants ← elems.mapM (fun elem => `(Command.structSimpleBinder|$elem:ident : $id))
    let (class_name, ax_distinct, ax_complete) := (mkIdent (Name.mkSimple s!"{id.getId}_Enum"), mkIdent $ Name.mkSimple s!"{id.getId}_distinct", mkIdent $ Name.mkSimple s!"{id.getId}_complete")
    let ax_distinct ← `(Command.structSimpleBinder|$ax_distinct:ident : distinct $[$elems]*)
    let x := mkIdent $ Name.mkSimple s!"{id.getId}_x"
    let ax_complete ← `(Command.structSimpleBinder|$ax_complete:ident : ∀ ($x : $id), $(← isEqualToOneOf x elems))
    let class_decl ← `(
      class $class_name ($id : outParam Type) where
        $[$variants]*
        $ax_distinct
        $ax_complete
    )
    elabCommand class_decl
    let instanceName := mkIdent $ Name.mkSimple s!"{id.getId}_isEnum"
    let instanceV ← `(command|instantiate $instanceName : @$class_name $id)
    elabCommand instanceV
    elabCommand $ ← `(open $class_name:ident)

  | _ => throwUnsupportedSyntax
where
isEqualToOneOf {m} [Monad m] [MonadQuotation m] (x : TSyntax `term) (xs : Array (TSyntax `term)) : m (TSyntax `term) := do
  let equalities ← xs.mapM (fun elem => `($x = $(elem)))
  repeatedOr equalities

private def defineStateComponent (mutab : Option (TSyntax `stateMutability)) (kind : TSyntax `stateComponentKind) (name : Name) (tp : StateComponentType) :=
    let mutability := stxToMut mutab
    let kind := stxToKind kind
    let comp := StateComponent.mk mutability kind name tp .none
    defineStateComponentImpl comp (validateTpFn kind) (failureMsgFn kind)

where
  defineStateComponentImpl (comp : StateComponent) (validateTp : Expr → CommandElabM Bool) (failureMsg : StateComponent → CoreM Unit) := do
     
    unless comp.name.isAtomic do throwError "Invalid name: {comp.name} must be atomic"
    let sig ← liftCoreM $ comp.getSimpleBinder
    let tp ← do match sig with
       
    | `(Command.structSimpleBinder| $_:ident : $tp:term) =>
      runTermElabM fun _ => elabTerm tp none
    | _ => throwErrorAt sig "Unsupported syntax {sig}"
    if ← validateTp tp then
      liftTermElabM do localSpecCtx.modify (fun s => { s with spec := {s.spec with signature := s.spec.signature.push comp }})
    else
      liftCoreM $ failureMsg comp

@[command_elab Veil.declareStateComponent]
def elabStateComponentNamed : CommandElab := fun stx => do
  match stx with
  | `(command|$mutab:stateMutability ? $kind:stateComponentKind $name:ident $br:bracketedBinder* : $dom:term) => do
    defineIt mutab kind name br dom
  | `(command|$mutab:stateMutability ? relation $name:ident $br:bracketedBinder*) => do
    let kind ← `(stateComponentKind|relation)
    let dom ← `(Prop)
    defineIt mutab kind name br dom
  
  | _ => throwUnsupportedSyntax
where
  defineIt (mutab : Option (TSyntax `stateMutability)) (kind : TSyntax `stateComponentKind) (name : Ident) (br : TSyntaxArray ``Term.bracketedBinder) (dom : TSyntax `term) := do
    if !br.isEmpty then
      defineStateComponent mutab kind name.getId (.complex br dom)
    else
      let sig ← `(Command.structSimpleBinder|$name:ident : $dom)
      defineStateComponent mutab kind name.getId (.simple sig)

@[command_elab Veil.declareDependency]
def elabDependency : CommandElab := fun stx => do
  match stx with
  | `(command|includes $nm:ident $ts:term* $ma:moduleAbbrev) => do
      let name := nm.getId
      checkModuleExists name
      checkCorrectInstantiation name ts
      let modAlias := if let `(Veil.moduleAbbrev| as $al) := ma then al.getId else name
      let modParams := (<- globalSpecCtx.get)[name]!.spec.parameters
      let modDep : ModuleDependency := {
        name := name,
        parameters := modParams,
        arguments := ts
      }
      let stateArgs ← Command.runTermElabM fun _ => getStateArguments modParams ts
      let sig ← `(Command.structSimpleBinder|$(mkIdent modAlias):ident : @$(mkIdent $ name ++ `State) $stateArgs*)
      \n{stx}"
      localSpecCtx.modify (fun s => { s with spec.dependencies := s.spec.dependencies.push (modAlias, modDep) })
  | _ => throwUnsupportedSyntax

def assembleState : CommandElabM Unit := do
  let vd := (<- getScope).varDecls
  declareSpecParameters vd
  let name <- getCurrNamespace
  let (sdef, isHOInst, smtAttr) <- Command.runTermElabM fun vs => do
    
    let components ← liftCommandElabM $ liftCoreM $ ((<- localSpecCtx.get).spec.signature).mapM StateComponent.getSimpleBinder
    
    localSpecCtx.modify (fun s => { s with stateBaseName := name })
    let stName := `State
    let sdef ←
    `(@[stateDef]
      structure $(mkIdent stName) $(getStateParametersBinders vd)* where
        $(mkIdent `mk):ident :: $[$components]*
      deriving $(mkIdent ``Nonempty):ident)
    let injEqLemma := (mkIdent $ stName ++ `mk ++ `injEq)
    let smtAttr ← `(attribute [smtSimp] $injEqLemma)
    let isHOInst ← `(instance (priority := default) $(mkIdent $ Name.mkSimple s!"{stName}_ho") $(getStateParametersBinders vd)* : IsHigherOrder (@$(mkIdent stName) $(← getStateArgumentsStx vd vs)*) := ⟨⟩)
    trace[veil.debug] "{sdef}"
    trace[veil.debug] "{isHOInst}"
    
    return (sdef, isHOInst, smtAttr)
  
  elabCommand sdef
  
  elabCommand isHOInst
  
  elabCommand smtAttr
  
  generateIgnoreFn
  Command.runTermElabM fun vs => do
    
    let stateTp ← mkStateTpStx vd vs
    localSpecCtx.modify ({· with spec.stateStx := stateTp })
  
  genStateExtInstances
  defineDepsProcedures
where

@[command_elab Veil.genState]
def elabGenState : CommandElab := fun _stx => do assembleState

@[command_elab Veil.ghostRelationDefinition]
def elabGhostRelationDefinition : CommandElab := fun stx => do
  match stx with
  | `(command|ghost relation $nm:ident $br:bracketedBinder* := $t:term) => do
  liftCoreM errorIfStateNotDefined
  let vd := (<- getScope).varDecls
  
  
  let vd' <- vd.mapM (fun x => mkImplicitBinders x)
  elabCommand $ <- Command.runTermElabM fun vs => do
    let stateTp <- getStateTpStx
    let stx' <- funcasesM t (← getStateArguments vd vs)
    elabBindersAndCapitals br vs stx' fun _ e => do
      let e <- delabWithMotives e
      let stx ← `(@[actSimp, invSimp, invSimpTopLevel] abbrev $nm $[$vd']* $br* ($(mkIdent `st) : $stateTp := by admit /- proof elided -/
      ) : Prop := $e)
      trace[veil.debug] "{stx}"
      return stx
  | _ => throwUnsupportedSyntax

@[command_elab Veil.initialStatePredicate]
def elabInitialStatePredicate : CommandElab := fun stx => do
  match stx with
  | `(command|initial $ini) => do
    liftCoreM errorIfStateNotDefined
    let vd ← getAssertionParameters
    elabCommand <| <- Command.runTermElabM fun _ => do
      
      
      let ini ←  simplifyTerm ini
      let predName := `initialState?
      
      `(@[initDef, initSimp] def $(mkIdent predName) $[$vd]* := $ini)
  | _ => throwUnsupportedSyntax

@[command_elab Veil.initialStateAction]
def elabInitialStateAction : CommandElab := fun stx => do
  match stx with
  | `(command|after_init { $l:doSeq }) => do
    liftCoreM errorIfStateNotDefined
    
    
    let subInitializers ← (← getSubInitializers).mapM (fun (nm, _) => `(Term.doSeqItem|$nm:term))
    let ourInitializer ← getItemsFromDoSeq l
    let init ← `(doSeq|do $subInitializers*; $(ourInitializer)*)
    
    let initName := mkIdent `initializer
    let (genI, genE) ← defineProcedureGenerators initName none init
    defineInitialActionFromGenerators initName genI genE
    
    let (st, st') := (mkIdent `st, mkIdent `st')
    let pred ← Command.runTermElabM fun _ => (do
      let stateTp ← getStateTpStx
      `(fun ($st' : $stateTp) => ∃ ($(toBinderIdent st) : $stateTp), Wp.toTwoState (do' .external in $init) $st $st'))
    
    elabCommand $ ← `(initial $pred)
    
    liftTermElabM do localSpecCtx.modify (fun s => { s with spec := {s.spec with init := {s.spec.init with lang := .some init}}})
    let sp ← liftTermElabM $ return (← localSpecCtx.get).spec.init
    trace[veil.debug] s!"{sp}"
  | _ => throwUnsupportedSyntax

def warnIfNotFirstOrder (name : Name) : TermElabM Unit := do
  let modName <- getCurrNamespace
  let .some decl := (← getEnv).find? (modName ++ name) | throwError s!"{name} not found"
  let .some val := decl.value? | throwError s!"{name} has no value"
  let isFirstOrderUniv ← allHOQuantIsTopLevelForAll val
  if !isFirstOrderUniv then
    logWarning s!"{name} is not first-order (and cannot be sent to SMT)"

@[command_elab Veil.nativeTransitionDefinition]
def elabNativeTransition : CommandElab := fun stx => do
  match stx with
  | `(command|$actT:actionKind ? transition $nm:ident $br:explicitBinders ? = $tr) => do
    liftCoreM errorIfStateNotDefined
    let actT ← parseActionKindStx actT
    defineTransition actT nm br tr
    
    Command.liftTermElabM $ warnIfNotFirstOrder nm.getId
  | _ => throwUnsupportedSyntax

@[command_elab Veil.transitionDefinition]
def elabTransition : CommandElab := fun stx => do
  match stx with
  | `(command|$actT:actionKind ? transition $nm:ident $br:explicitBinders ? = { $t:term }) => do
    let fields : Array Name ← getFields
    let mut unchangedFields := #[]
    for f in fields do
      unless t.raw.find? (·.getId.toString == f.toString ++ "'") |>.isSome do
        unchangedFields := unchangedFields.push $ mkIdent f
    let stx ← `($actT:actionKind ? transition $nm $br ? = by admit /- proof elided -/
      )
    elabCommand stx
  | _ => throwUnsupportedSyntax

def checkSpec (nm : Ident) (br : Option (TSyntax `Lean.explicitBinders))
  (pre post : Term) (ret : TSyntax `rcasesPat) : CommandElabM Unit := do
  try
    elabCommand $ ← Command.runTermElabM fun vs => do
      let st := mkIdent `st
      let thmName := mkIdent $ nm.getId ++ `spec_correct
      let br' <- (toBracketedBinderArray <$> br) |>.getD (pure #[])
      let br <- (explicitBindersIdents <$> br) |>.getD (pure #[])
      let stx <- `(theorem $thmName $br' * : ∀ $st:ident,
          (fun s => funcases s $pre) $st ->
          @$nm $(← getSectionArgumentsStx vs)* $br* $st (by admit /- proof elided -/
          ) := by admit /- proof elided -/
          )
      trace[veil.debug] "{stx}"
      return stx
    trace[veil.info] "{nm} specification is verified"
  catch e =>
    throwError s!"Error while checking the specification of {nm}:" ++ e.toMessageData

def elabAction (actT : Option (TSyntax `actionKind)) (nm : Ident) (br : Option (TSyntax ``Lean.explicitBinders))
  (spec : Option doSeq) (l : doSeq) : CommandElabM Unit := do
    liftCoreM errorIfStateNotDefined
    let actT ← parseActionKindStx actT
    
    defineAction actT nm br l
    
    Command.liftTermElabM <| warnIfNotFirstOrder nm.getId
    unless spec.isNone do
      registerProcedureSpec nm.getId spec
      let (pre, binder, post) <- getPrePost spec.get!
      defineProcedure (nm.getId ++ `spec |> mkIdent) br spec.get!
      checkSpec nm br pre post binder

def elabProcedure (nm : Ident) (br : Option (TSyntax ``Lean.explicitBinders)) (spec : Option doSeq) (l : doSeq) : CommandElabM Unit := do
  liftCoreM errorIfStateNotDefined
  defineProcedure nm br l
  Command.liftTermElabM <| warnIfNotFirstOrder nm.getId
  unless spec.isNone do
    registerProcedureSpec nm.getId spec
    let (pre, binder, post) <- getPrePost spec.get!
    defineProcedure (nm.getId ++ `spec |> mkIdent) br spec.get!
    checkSpec nm br pre post binder

def addInvariantToIsolate [Monad m] [MonadEnv m] (inv : Name) : m (List Name) := do
  let ⟨openIs, isStore⟩ := (<- localSpecCtx.getIsolates)
  for is in openIs do
    let invs := (isStore[is]?.getD ∅).insert inv
    localSpecCtx.modifyIsolates ({ · with isolateStore := isStore.insert is invs })
  return openIs

def _root_.Lean.TSyntax.getPropertyName (stx : TSyntax `propertyName) : Name :=
  match stx with
  | `(propertyName| [$id]) => id.getId
  | _ => unreachable!

def getPropertyNameD (stx : Option (TSyntax `propertyName)) (default : Name) :=
  match stx with
  | some stx => stx.getPropertyName
  | none => default

def defineAssertion (kind : StateAssertionKind) (name : Option (TSyntax `propertyName)) (t : TSyntax `term) : CommandElabM Unit := do
  liftCoreM errorIfStateNotDefined
  let vd ← getAssertionParameters
  let (name, cmd) ← Command.runTermElabM fun vs => do
    let stateTp <- getStateTpStx
    
    if kind == .assumption then
      throwIfRefersToMutable t
    let stx <- funcasesM t (← getStateArguments vd vs)
    let defaultName ← match kind with
      | .safety | .invariant => pure $ Name.mkSimple s!"inv_{(<- localSpecCtx.get).spec.invariants.size}"
      | .assumption | .trustedInvariant => pure $ Name.mkSimple s!"axiom_{(<- localSpecCtx.get).spec.assumptions.size}"
    let name := getPropertyNameD name defaultName
    let cmd ← elabBindersAndCapitals #[] vs stx fun _ e => do
      let e <- delabWithMotives e
      
      
      let vd ← vd.mapM mkImplicitBinders
      match kind with
      | .safety =>
        `(@[safeDef, safeSimp, invSimp] def $(mkIdent name) $[$vd]* ($(mkIdent `st) : $stateTp := by admit /- proof elided -/
        ) : Prop := $e: term)
      | .invariant =>
        `(@[invDef, invSimp] def $(mkIdent name) $[$vd]* ($(mkIdent `st) : $stateTp := by admit /- proof elided -/
        ) : Prop := $e: term)
      | .assumption | .trustedInvariant =>
        `(@[assumptionDef, invSimp] def $(mkIdent name) $[$vd]* ($(mkIdent `st) : $stateTp := by admit /- proof elided -/
        ) : Prop := $e: term)
    
    
    return (name, cmd)
  
  trace[veil.debug] s!"{cmd}"
  elabCommand cmd
  trace[veil.info] s!"invariant {name} is defined"
  let iss <- addInvariantToIsolate name
  let name <- resolveGlobalConstNoOverloadCore name
  Command.runTermElabM fun _vs => do
    
    localSpecCtx.modify (fun s => { s with spec :=
    (match kind with
    | .safety | .invariant => {s.spec with
        invariants := s.spec.invariants.map (fun x => if x.name == name then { x with term := t, isolates := iss } else x) }
    | .assumption | .trustedInvariant => {s.spec with
        assumptions := s.spec.assumptions.map (fun x => if x.name == name then { x with term := t } else x) })})

def instantiateSystem (name : Name) : CommandElabM Unit := do
  let vd := (<- getScope).varDecls
  assembleNext
  assembleInvariant
  assembleSafeties
  assembleAssumptions
  assembleLabelType name
  let rtsStx <- Command.runTermElabM fun vs => do
    let sectionArgs ← getSectionArgumentsStx vs
    let stateTpStx <- getStateTpStx
    let [initialState?, Assumptions, Next, Safety, Invariant] :=
      [`initialState?, `Assumptions, `Next, `Safety, `Invariant].map Lean.mkIdent
      | unreachable!
    `(instance (priority := low) $(mkIdent `System) $[$vd]* : $(mkIdent ``RelationalTransitionSystem) $stateTpStx where
        init := @$initialState? $sectionArgs*
        assumptions := @$Assumptions $sectionArgs*
        next := @$Next $sectionArgs*
        safe := @$Safety $sectionArgs*
        inv  := @$Invariant $sectionArgs*
        )
  trace[veil.info] "{rtsStx}"
  elabCommand rtsStx
  trace[veil.info] "RelationalTransitionSystem instance instantiated"

@[inherit_doc instantiateSystem]
def genSpec : CommandElabM Unit := do
  liftCoreM (do errorIfStateNotDefined; warnIfNoInvariantsDefined; warnIfNoActionsDefined)
  let some name := (← localSpecCtx.get).stateBaseName
    | throwError "Command is run outside of a module declaration"
  trace[veil.info] "State, invariants and actions are defined"
  instantiateSystem name
  Command.runTermElabM fun _ => do
    
    localSpecCtx.modify (fun s => { s with spec := {s.spec with name := name }})
    
    registerModuleSpecification

def z3.version := "4.15.4"

def cvc5.version := "1.3.1"

def uv.version := "0.9.13"

def dependencyFile := "dependencies.toml"

def z3.baseUrl := "https://github.com/Z3Prover/z3/releases/download"

def z3.arch := if System.Platform.target.startsWith "x86_64" then "x64" else "arm64"

def z3.platform :=
  if System.Platform.isWindows then "win"
  else if System.Platform.isOSX then "osx-13.7.6"
  
  else if System.Platform.target.startsWith "x86_64" then "glibc-2.39"
  
  else if System.Platform.target.startsWith "aarch64" then "glibc-2.34"
  else panic! s!"Unsupported platform: {System.Platform.target}"

def z3.target := s!"{arch}-{platform}"

def z3.fullName := s!"z3-{version}-{z3.target}"

def z3.url := s!"{baseUrl}/z3-{version}/{fullName}.zip"

def cvc5.baseUrl := "https://github.com/cvc5/cvc5/releases/download"

def cvc5.os :=
  if System.Platform.isWindows then "Win64"
  else if System.Platform.isOSX then "macOS"
  else "Linux"

def cvc5.arch := if System.Platform.target.startsWith "x86_64" then "x86_64" else "arm64"

def cvc5.target := s!"{os}-{arch}-static"

def cvc5.fullName := s!"cvc5-{cvc5.target}"

def cvc5.url := s!"{baseUrl}/cvc5-{version}/{fullName}.zip"

def uv.url := s!"https://astral.sh/uv/{uv.version}/install.sh"

inductive Solver
| z3
| cvc5

instance : ToString Solver where
  toString := fun
    | Solver.z3 => "z3"
    | Solver.cvc5 => "cvc5"

def Solver.fullName (solver : Solver) : String :=
  match solver with
  | Solver.z3 => z3.fullName
  | Solver.cvc5 => cvc5.fullName

def Solver.url (solver : Solver) : String :=
  match solver with
  | Solver.z3 => z3.url
  | Solver.cvc5 => cvc5.url

def Lake.unzip (file : FilePath) (dir : FilePath) : LogIO PUnit := do
  IO.FS.createDirAll dir
  proc (quiet := true) {
    cmd := "unzip"
    args := #["-q", "-d", dir.toString, file.toString]
  }

def copyFile' (src : FilePath) (dst : FilePath) : LogIO PUnit := do
  proc (quiet := true) {
    cmd := "cp"
    args := #[src.toString, dst.toString]
  }

def downloadPythonUv (pkg : Package) (oFile : FilePath) : JobM PUnit := do
  let uvShPath := pkg.buildDir / "install-uv.sh"
  logInfo s!"Downloading uv from {uv.url}"
  download uv.url uvShPath
  proc (quiet := true) {
    cmd := "env"
    args := #[s!"UV_UNMANAGED_INSTALL={pkg.buildDir}", "sh", uvShPath.toString]
  }
  if ← oFile.pathExists then
    logInfo s!"uv is now at {oFile}"
  else
    logError s!"Failed to download uv to {oFile}"
  IO.FS.removeFile uvShPath

def downloadSolver (solver : Solver) (pkg : Package) (oFile : FilePath) : JobM PUnit := do
  let zipPath := (pkg.buildDir / s!"{solver}").addExtension "zip"
  logInfo s!"Downloading {solver} from {solver.url}"
  download solver.url zipPath
  let extractedPath := pkg.buildDir / solver.fullName
  if ← extractedPath.pathExists then
    IO.FS.removeDirAll extractedPath
  unzip zipPath pkg.buildDir
  let binPath := extractedPath/ "bin" / s!"{solver}"
  copyFile' binPath oFile
  if ← oFile.pathExists then
    logInfo s!"{solver} is now at {oFile}"
  else
    logError s!"Failed to download {solver} to {oFile}"
  IO.FS.removeFile zipPath
  IO.FS.removeDirAll extractedPath

def downloadDependency (pkg : Package) (oFile : FilePath) (build : Package → FilePath → JobM PUnit) := do
  let lakefilePath := pkg.lakeDir / ".." / dependencyFile
  let srcJob ← inputTextFile lakefilePath
  buildFileAfterDep oFile srcJob fun _srcFile => build pkg oFile

target downloadDependencies pkg : Array FilePath := do
  let uv ← downloadDependency pkg (pkg.buildDir / "uv") downloadPythonUv
  let z3 ← downloadDependency pkg (pkg.buildDir / "z3") (downloadSolver Solver.z3)
  let cvc5 ← downloadDependency pkg (pkg.buildDir / "cvc5") (downloadSolver Solver.cvc5)
  return Job.collectArray #[uv, z3, cvc5]

action empty = {
  pure ()
}

invariant True

#gen_spec

#guard_msgs(drop warning) in
sat trace [ini] { } by admit /- proof elided -/

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    if (le n sender) then
      pending sender next := True
}

action ruin_inv = {
  indv := False
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S

invariant [indv_true] indv

#gen_spec

action send_1a (r : round) = {
  
  require r ≠ none
  one_a r := True
}

action join_round (n:node) (r:round) = {
    
    require r ≠ none
    require one_a r
    require ¬ left_rnd n r
    let maxr : round ← fresh
    let v : value ← fresh
      
    require (maxr = none ∧ ∀ (mAXR:round) (v':value), ¬ (¬ tot.le r mAXR ∧ vote n mAXR v')) ∨
                    (maxr ≠ none ∧ ¬ tot.le r maxr ∧ vote n maxr v ∧
                    (∀ (mAXR:round) (v':value), (¬ tot.le r mAXR ∧ vote n mAXR v') -> tot.le mAXR maxr))
    one_b_max_vote n r maxr v := True
    one_b n r := True
    left_rnd n R := left_rnd n R ∨ (¬ tot.le r R)
}

action propose (r : round) (q : quorum) = {
  require r ≠ none
  require ∀ V, ¬ proposal r V
  require ∀ (N:node), member N q -> one_b N r
  let maxr : round ← fresh
  let v : value ← fresh
      
  require ∀ N, (maxr = none ∧ ∀ (n : node) (mAXR:round) (v':value), ¬ (member n q ∧ ¬ tot.le r mAXR ∧ vote n mAXR v')) ∨
                    (maxr ≠ none ∧
                    (∃ (n : node), member n q ∧ ¬ tot.le r maxr ∧ vote n maxr v) ∧
                    (∀ (n : node) (mAXR:round) (v':value), (member n q ∧ ¬ tot.le r mAXR ∧ vote N mAXR v') -> tot.le mAXR maxr))
  proposal r v := True
}

action cast_vote (n:node) (v:value) (r:round) = {
  require r ≠ none
  require ¬ left_rnd n r
  require proposal r v
  vote n r v := True
}

action decide (n:node) (r:round) (v:value) (q : quorum) = {
  require r ≠ none
  require ∀ N, member N q → vote N r v
  decision n r v := True
}

safety [coherence] decision N1 R1 V1 ∧ decision N2 R2 V2 → V1 = V2

invariant [unique_proposals] proposal R V1 ∧ proposal R V2 -> V1 = V2

invariant [vote_proposed] vote N R V -> proposal R V


invariant ∀ (R:round) (V:value), (∃ n:node, decision n R V)
       -> ∃ (q:quorum), ∀ N:node, member N q -> vote N R V

invariant [none_prop] ¬ vote N none V

invariant [choosable_proposal] ∀ (R1:round) (R2:round) (V1:value) (V2:value) (Q:quorum), ¬ tot.le R2 R1 ∧ proposal R2 V2 ∧ V1 ≠ V2 ->
    ∃ n:node, member n Q ∧ left_rnd n R1 ∧ ¬vote n R1 V1

invariant [oneb_leftrnd] one_b N R2 ∧ ¬tot.le R2 R1 -> left_rnd N R1

#gen_spec

#time #check_invariants

class RelationalTransitionSystem (σ : Type) where
  init : σ → Prop
  assumptions : σ → Prop
  next : σ -> σ -> Prop
  safe : σ → Prop
  inv : σ → Prop

def invSafe [RelationalTransitionSystem σ] :=
  ∀ (s : σ), assumptions s -> inv s -> safe s

def invInit [RelationalTransitionSystem σ] :=
  ∀ (s : σ), assumptions s -> init s -> inv s

def invConsecution [RelationalTransitionSystem σ] :=
  ∀ (s1 s2 : σ), assumptions s1 -> inv s1 -> next s1 s2 -> inv s2

def invInductive [sys: RelationalTransitionSystem σ] :=
  @invInit σ sys ∧ @invConsecution σ sys

def isInductiveInvariant [sys: RelationalTransitionSystem σ] (p : σ → Prop) :=
  (∀ (s : σ), assumptions s → init s → p s) ∧
  (∀ (s s' : σ), assumptions s → p s → next s s' → p s')

inductive reachable [sys : RelationalTransitionSystem σ] : σ → Prop where
  | init : ∀ (s : σ), sys.init s → reachable s
  | step : ∀ (s s' : σ), reachable s → sys.next s s' → reachable s'

def isInvariant [sys : RelationalTransitionSystem σ] (p : σ → Prop) : Prop := ∀ (s : σ), reachable s → p s

action empty = { pure () }

#guard_msgs in

action call_empty = {
  empty
}

#guard_msgs in

action retval = {
  return 42
}

#guard_msgs in

action call_retval = {
  retval
}

#guard_msgs in

action with_if = {
  if (x) then
    pure ()
    
}

#guard_msgs in

action call_with_if = {
  with_if
  
}

#guard_msgs in

action with_if_fresh = {
  if (x) then
    let m ← fresh node
    r N m := False
}

#guard_msgs in

action ff = {
  with_if_fresh
  
}

#guard_msgs in

action with_if_fresh_more = {
  if (x) then
    let m ← fresh node
    r N m := False
    require x
}

#guard_msgs in

action call_with_if_fresh_more = {
  if x then
    with_if_fresh_more
  
}

#guard_msgs in

action nested_call = {
  call_with_if_fresh_more
  
}

#guard_msgs in

action callee_with_if_some = {
  if m : (r m m) then
    if n : (r n n ∧ n ≠ m) then
      
      require x
      
}

#guard_msgs in

action with_if_some_nested = {
  if m : (r m m) then
    if n : (r n n ∧ n ≠ m) then
      r n m := True
      callee_with_if_some
      require x
      x := False
      callee_with_if_some
}

#guard_msgs in

action nondet_assgn (m : node) = {
  if x then
    r N m := *
    x := *
}

#guard_msgs in

action call_nondet_assgn = {
  let m ← fresh node;
  if x then
      nondet_assgn m;
  else
    r N M := *;
}

#guard_msgs in

action call_nondet_assgn' = {
  let m ← fresh node;
  if x then
    nondet_assgn m;
    call_nondet_assgn
  else
    let n ← fresh node;
    nondet_assgn n
    r N M := *;
}

def TSyntax.isApp? (stx : Term) : Option (Ident × Array Term) := do
  let #[f, args] := stx.raw.getArgs | failure
  let `(term| $f:ident) := f | failure
  return (⟨f⟩, args.getArgs.map (⟨·⟩))

def isTypeClassBinder : TSyntax `Lean.Parser.Term.bracketedBinder → Bool
  | `(bracketedBinder| $_:instBinder) => true
  | _ => false

def Term.explicitBinderF := Term.explicitBinder (requireType := false)

def Term.implicitBinderF := Term.implicitBinder (requireType := false)

def mkImplicitBinders [Monad m] [MonadQuotation m] : TSyntax `Lean.Parser.Term.bracketedBinder ->
  m (TSyntax `Lean.Parser.Term.bracketedBinder)
  | `(Term.explicitBinderF| ($id:ident : $tp:term)) => do
    `(Term.bracketedBinderF| {$id:ident : $tp:term})
  | stx => return stx

def getSectionArgumentsStx (vs : Array Expr) : TermElabM (Array (TSyntax `term)) := do
  let args ← vs.mapM (fun v => do
    let t ← PrettyPrinter.delab v
    let isHygienicName := (extractMacroScopes t.raw.getId).scopes.length > 0
    if isHygienicName then return ← `(term|_) else return t
  )
  return args

def getStateParametersBinders (vd : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) : Array (TSyntax `Lean.Parser.Term.bracketedBinder) :=
  vd.filter (fun b => !isTypeClassBinder b)

def getStateArguments [ToMessageData α] (vd : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) (vs : Array α) [Monad m] [MonadError m]: m (Array α) := do
  if vd.size != vs.size then throwError "Mismatch in number of arguments between {vd} and {vs}"
  let vs' := (vd.zip vs).filter (fun (b, _) => !isTypeClassBinder b) |> .map Prod.snd
  return vs'

def getStateArgumentsStx (vd : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) (vs : Array Expr) : TermElabM (Array (TSyntax `term)) := do
  let vs' ← getStateArguments vd vs
  getSectionArgumentsStx vs'

def getActionParameters : CommandElabM (Array (TSyntax `Lean.Parser.Term.bracketedBinder)) := return (← getScope).varDecls

def getAssertionParameters : CommandElabM (Array (TSyntax `Lean.Parser.Term.bracketedBinder)) := getActionParameters

def getImplicitProcedureParameters : CommandElabM (Array (TSyntax `Lean.Parser.Term.bracketedBinder)) := do (← getActionParameters).mapM mkImplicitBinders

def mkStateTpStx (vd : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) (vs : Array Expr) : TermElabM Term := do
  let stateTpExpr := (<- localSpecCtx.get).spec.stateType
  unless stateTpExpr != default do throwError "State has not been declared so far"
  let stateTp ← PrettyPrinter.delab stateTpExpr
  let stx ← `(term|@$stateTp $(← getStateArgumentsStx vd vs)*)
  return stx

def getStateTpStx : AttrM Term := do
  let stateTp := (← localSpecCtx.get).spec.stateStx
  trace[debug] "[getStateTpStx] {stateTp}"
  return stateTp

def getSystemTpStx (vs : Array Expr) : TermElabM Term := do
  let sectionArgs ← getSectionArgumentsStx vs
  `(@$(mkIdent `System) $sectionArgs:term*)

def getPrefixedName (name : Name): AttrM Name := do
  let stateName := (← localSpecCtx.get).stateBaseName
  return (stateName.getD Name.anonymous) ++ name

def getStateName : AttrM Name := getPrefixedName `State

def mkProp := (Lean.Expr.sort (Lean.Level.zero))

partial def withAutoBoundCont
  (k : TermElabM α)
  (conditionToBind : Name → TermElabM Bool)
  (unboundCont : Exception → Name → TermElabM α)
  : TermElabM α := do
  let flag := autoImplicit.get (← getOptions)
  if flag then
    withReader (fun ctx => { ctx with autoBoundImplicit := flag, autoBoundImplicits := {} }) do
      let rec loop (s : Term.SavedState) : TermElabM α := do
        try
          k
        catch
          | ex => match isAutoBoundImplicitLocalException? ex with
            | some n =>
              if ← conditionToBind n then
              
                s.restore
                withLocalDecl n .default (← mkFreshTypeMVar) fun x =>
                  withReader (fun ctx => { ctx with autoBoundImplicits := ctx.autoBoundImplicits.push x } ) do
                    loop (← saveState)
              else unboundCont ex n
            | none   => throw ex
      loop (← saveState)
  else
    k

partial def withAutoBoundCapitals (k : TermElabM α) : TermElabM α := do
  withAutoBoundCont k (fun n => return isCapital (mkIdent n)) (fun ex n => do throwErrorAt ex.getRef "Unbound uncapitalized variable: {n}")

def throwIfRefersToMutable (t : Term) : TermElabM Unit :=
  withAutoBoundCont
    (do let _ ← elabTerm t .none)
    
    
    (fun n => do
      let immutable := (← localSpecCtx.get).spec.immutableComponents.map (fun sc => sc.name)
      return immutable.contains n || isCapital (mkIdent n))
    (fun ex n => do
      let mutable := (← localSpecCtx.get).spec.mutableComponents.map (fun sc => sc.name)
      if mutable.contains n then
        throwErrorAt ex.getRef "The assumption refers to mutable state component `{n}`!"
      else
        throwErrorAt ex.getRef "The assumption refers to unbound variable `{n}`!")

def funcasesM (t : Term) (vs : Array Expr) : TermElabM Term := do
  let stateTpExpr := (<- localSpecCtx.get).spec.stateType
  let .some sn := stateTpExpr.getAppFn.constName?
    | throwError "{stateTpExpr} is not a constant"
  let .some _sinfo := getStructureInfo? (<- getEnv) sn
    | throwError "{stateTpExpr} is not a structure"
  let fns := _sinfo.fieldNames.map Lean.mkIdent
  let moduleName <- getCurrNamespace
  let stateName := `State
  let casesOn <- mkConst $ (moduleName ++ stateName ++ `casesOn)
  let casesOn <- PrettyPrinter.delab casesOn
  let stateTp <- getStateTpStx
  let term ← `(term| (fun $(mkIdent `st) : $stateTp =>
      $(casesOn) $(← getSectionArgumentsStx vs)* (motive := fun _ => Prop) $(mkIdent `st) <| (fun $[$fns]* => ($t : Prop))))
  trace[veil.debug] "funcasesM: {term}"
  return term

def elabBindersAndCapitals
  (br : Array Syntax)
  (vs : Array Expr)
  (e : Syntax)
  (k : Array Expr -> Expr -> TermElabM α)
   : TermElabM α := do
  withAutoBoundCapitals $ Term.elabBinders br fun brs => do
    let vars := (← getLCtx).getFVars.filter (fun x => not $ vs.elem x || brs.elem x)
    trace[veil.debug] "[elabBindersAndCapitals] {e}"
    let e <- elabTermAndSynthesize e none
    lambdaTelescope e fun _ e => do
        let e <- mkForallFVars vars e
        k vars e

def delabWithMotives :=  (withOptions (fun s => (s.insert `pp.motives.all true).insert `pp.funBinderTypes true) $ PrettyPrinter.delab ·)

def constructCommands (thms : Array (TSyntax `command)) : CoreM (TSyntax `commands) := `(commands| $[$thms]*)

def toTrName (n : Name) : Name := n ++ `tr

def toTrIdent (id : Ident) : Ident := mkIdent $ toTrName id.getId

def toFnName (n : Name) : Name := n ++ `fn

def toFnIdent (id : Ident) : Ident := mkIdent $ toFnName id.getId

def toOriginalName (n : Name) : Name := n ++ `original

def toOriginalIdent (id : Ident) : Ident := mkIdent $ toOriginalName id.getId

def toSpecName (n : Name) : Name := n ++ `spec

def toSpecIdent (id : Ident) : Ident := mkIdent $ toSpecName id.getId

def toGenName (n : Name) (mode : Mode) : Name :=
  n ++ (match mode with
  | Mode.internal => `genI
  | Mode.external => `genE)

def toGenIdent (id : Ident) (mode : Mode): Ident := mkIdent $ toGenName id.getId mode

def toGenInstName (n : Name) (mode : Mode) : Name :=
  n ++ (match mode with
  | Mode.internal => `genIInst
  | Mode.external => `genEInst)

def toGenInstIdent (id : Ident) (mode : Mode) : Ident := mkIdent $ toGenInstName id.getId mode

def toActTrEqName (n : Name) : Name := n ++ `act_tr_eq

def toActTrEqIdent (id : Ident) : Ident := mkIdent $ toActTrEqName id.getId

def toInstName (n : Name) (mode : Mode) : Name :=
  n ++ (match mode with
  | Mode.internal => `inst
  | Mode.external => `instExt)

def toInstIdent (id : Ident) (mode : Mode) : Ident := mkIdent $ toInstName id.getId mode

def toExtName (n : Name) : Name := n ++ `ext

def toExtIdent (id : Ident) : Ident := mkIdent $ toExtName id.getId

def toIOActionDeclName (n : Name) : Name := n ++ `iodecl

def toIOActionDeclIdent (id : Ident) : Ident := mkIdent $ toIOActionDeclName id.getId

def mkPrintableName (n : Name) : Name :=
  Name.mkSimple $ "_".intercalate (n.components.map toString)

def mkStrippedName (n : Name) (separator : String := "_") : Name :=
  s!"{mkString n.components}".toName
where
  stripFirst {α : Type} (xs : List α) : List α :=
    match xs with
    | [] => []
    | [x] => [x]
    | _ :: xs => xs
  mkString (xs : List Name) : String :=
    xs.map toString |> stripFirst |> String.intercalate separator

def stripFirstComponent (n : Name) : Name := mkStrippedName n "."

def simpleAddThm (n : Name) (tp : Expr) (tac : TermElabM (TSyntax `Lean.Parser.Tactic.tacticSeq))
  (attr : Array Attribute := #[]) : TermElabM Unit := do
  addDecl <|
    Declaration.thmDecl <|
      mkTheoremValEx n [] tp (<- elabTermAndSynthesize (<- `(by admit /- proof elided -/
      )) tp) []
  enableRealizationsForConst n
  applyAttributes n attr

macro "exists?" br:explicitBinders ? "," t:term : term =>
  match br with
  | some br => `(exists $br, $t)
  | none => `($t)

macro "forall?" br:bracketedBinder* "," t:term : term =>
  if br.size > 0 then
    `(∀ $br*, $t)
  else
    `($t)

elab _tk:"conv! " conv:conv " => " e:term : term => do
  let e ← Elab.Term.elabTermAndSynthesize e none
  let (rhs, g) ← Conv.mkConvGoalFor e
  _ ← Tactic.run g.mvarId! (do
    evalTactic conv
    for mvarId in (← getGoals) do
      liftM <| mvarId.refl <|> mvarId.inferInstance <|> pure ()
    pruneSolvedGoals
    let e' ← instantiateMVars rhs
    trace[veil.debug] "[conv!] {e}\nsimplifies to\n{e'}"
  )
  return rhs

def unfoldWp (t : TSyntax `term) : TermElabM (TSyntax `term) := do
  let actSimp := mkIdent `actSimp
  
  
  
  let t' ← `(term|by admit /- proof elided -/
  )
  return t'

def dsimpOnly (t : TSyntax `term) (classes : Array Name := #[]) : TermElabM (TSyntax `term) := do
  let classes := classes.map mkIdent
  let t' ← `(term|by admit /- proof elided -/
  )
  return t'

def simplifyTerm (t : TSyntax `term) : TermElabM (TSyntax `term) := do
  let (actSimp, smtSimp, logicSimp, quantifierSimp) := (mkIdent `actSimp, mkIdent `smtSimp, mkIdent `logicSimp, mkIdent `quantifierSimp)
  
  let t' ← `(term| by admit /- proof elided -/
        )
  return t'

@[term_elab tupl]
def tuplElab : TermElab := fun stx type? => do
  match stx with
  | `(term| [tupl| $arg: term $args: term *]) =>
    let newStx ← if args.size == 0 then `($arg) else `(($arg, [tupl| $args: term *]))
    elabTerm newStx type?
  | _ => throwUnsupportedSyntax

def isCapital (i : Lean.Syntax) : Bool :=
  i.getId.isStr && i.getId.toString.all (fun c => c.isUpper || c.isDigit)

private def higherOrderQuantifiedTypes' (e : Expr) (existentialOnly? : Bool := false) : QuantElimM (n := n) (Array (QuantType × Name × Expr)) := do
  let _ ← forEachExprSane e (fun e => do
    match e with
    | Expr.forallE nm t _ _ => if !existentialOnly? then recordTypeIfHigherOrder .forall nm t else pure ()
    | _ => match_expr e with
      | Exists t tlam =>
        let name :=
          if let .lam nm _ _ _ := tlam then nm
          else Name.anonymous
        recordTypeIfHigherOrder .exists name t
      | _ => pure ()
  )
  let res := (← get).quantifiedTypes.toArray
  return res
  where recordTypeIfHigherOrder (qt : QuantType ) (nm : Name) (e : Expr) : QuantElimM (n := n) Unit := do
    if ← isHigherOrder e then
      modify (fun s => { s with quantifiedTypes := (qt, nm, e) :: s.quantifiedTypes })

def higherOrderQuantifiers (e : Expr) (existentialOnly? : Bool := false) : n (Array (QuantType × Name × Expr)) := do
  let (types, _st) ← (higherOrderQuantifiedTypes' e existentialOnly?).run default
  return types

def hasHigherOrderQuantification (e : Expr) (existentialOnly? : Bool := false) : n Bool := do
  return (← higherOrderQuantifiers e existentialOnly?).size > 0

def getHOQuat (e : Expr) (mode : checkMode := .hypothesis) : n (Array (QuantType × Name × Expr)) :=
  quantMetaTelescopeReducing e mode fun _ => higherOrderQuantifiers

def logHOQuantsErorrs (hoqs : Array (QuantType × Name × Expr)) (pos : Option Name := none) : TacticM Unit := do
  let loc := match pos with
    | some n => s!"hypotesis {n}"
    | none => "the goal"
  for q in hoqs do
    logError s!"Higher-order quantification in {loc} detected: {q.1} {q.2.1} : {q.2.2}"

def goalSmTTranslatable? : TacticM Unit := do
    let quants <- getHOQuat (<- getMainTarget) .goal
    logHOQuantsErorrs quants
    for h in (<- getLCtx) do
      unless h.isImplementationDetail do
        let quants <- getHOQuat h.type .hypothesis
        logHOQuantsErorrs quants h.userName

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

action set_X = {
  X := True
}

action nondet_individual = {
  x := *
}

action quantify_fresh (n : node) = {
  
  r n N := *
}

action double_quant = {
  r N N := *
}

def top_level (n : node) := do' .external in
  require x
  if x then
    r N N := *
  else
    r n n := *
  return r

def top_level' (n : node) := do' .external in
  let freshR <- fresh node -> node -> Prop
  let freshR' <- fresh node -> node -> Prop
  require x
  if x then
    r N N := freshR N N
  else
    r n n := freshR' n n
  return r

example : top_level = top_level' := rfl

action ruin_inv = {
  flag := True
}

safety [single_leader] leader L → le N L

invariant [not_flag] ¬ flag
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

inductive StateComponentKind where
  | individual
  | relation
  | function
deriving Inhabited

instance : ToString StateComponentKind where
  toString
    | StateComponentKind.individual => "individual"
    | StateComponentKind.relation => "relation"
    | StateComponentKind.function => "function"

inductive StateComponentType where
   
  | simple (t : TSyntax ``Command.structSimpleBinder)
   
  | complex (binders : TSyntaxArray ``Term.bracketedBinder) (dom : TSyntax `term)
deriving Inhabited

instance : ToString StateComponentType where
  toString
    | StateComponentType.simple t => toString t
    | StateComponentType.complex b d  => s!"{b} : {d}"

def StateComponentType.stx (sct : StateComponentType) : CoreM (TSyntax `term) := do
  match sct with
  | .simple t => getSimpleBinderType t
  | .complex b d => getSimpleBinderType $ ← complexBinderToSimpleBinder (mkIdent Name.anonymous) b d

inductive Mutability
  | mutable
  | immutable
deriving Inhabited, BEq

instance : ToString Mutability where
  toString
    | Mutability.mutable => "mutable"
    | Mutability.immutable => "immutable"

structure StateComponent where
   
  mutability : Mutability
   
  kind       : StateComponentKind
  name       : Name
   
  type       : StateComponentType
   
  moduleName : Option Name := none
deriving Inhabited

instance : ToString StateComponent where
  toString sc := s!"{sc.mutability} {sc.kind} {sc.name} {sc.type}"

def StateComponent.isMutable (sc : StateComponent) : Bool := sc.mutability == Mutability.mutable

def StateComponent.isImmutable (sc : StateComponent) : Bool := sc.mutability == Mutability.immutable

def StateComponent.getSimpleBinder (sc : StateComponent) : CoreM (TSyntax ``Command.structSimpleBinder) := do
  match sc.type with
  | .simple t => return t
  | .complex b d => return ← complexBinderToSimpleBinder (mkIdent sc.name) b d

def StateComponent.stx (sc : StateComponent) : CoreM Syntax := sc.getSimpleBinder

def StateComponent.typeStx (sc : StateComponent) : CoreM Term := sc.type.stx

structure StateSpecification where
  name : Name
   
  lang : Option (TSyntax ``Term.doSeq)
   
  expr : Expr
deriving Inhabited, BEq

instance : ToString StateSpecification where
  toString sp := match sp.lang with
    | some lang => s!"{sp.name} : {lang}"
    | none => s!"{sp.name} : {sp.expr}"

structure ProcedureDeclaration where
  name: Lean.Name
  ctor : Option (TSyntax `Lean.Parser.Command.ctor)
deriving BEq, Inhabited

inductive ProcedureKind
   
  | action (decl : ActionDeclaration)
   
  | procedure (decl : ProcedureDeclaration)
deriving Inhabited, BEq

def ProcedureKind.isAction (kind : ProcedureKind) : Bool :=
  match kind with
  | .action _ => true
  | .procedure _ => false

def ProcedureKind.actionDecl (kind : ProcedureKind) : Option ActionDeclaration :=
  match kind with
  | .action decl => some decl
  | .procedure _ => none

def ProcedureKind.procedureDecl (kind : ProcedureKind) : Option ProcedureDeclaration :=
  match kind with
  | .action _ => none
  | .procedure decl => some decl

structure ProcedureSpecification where
  kind : ProcedureKind
   
  lang : Option (TSyntax ``Term.doSeq)
   
  spec : Option (TSyntax ``Term.doSeq)
   
  br   : Option (TSyntax ``Lean.explicitBinders) := none
   
  expr : Expr
deriving Inhabited, BEq

instance : ToString ProcedureSpecification where
  toString a := match a.kind with
    | .action decl => match a.lang with
      | some lang => s!"{decl.kind} {decl.name} [defined via lang] {lang}"
      | none => s!"{decl.kind} {decl.name} [defined via expr] {a.expr}"
    | .procedure decl => match a.lang with
      | some lang => s!"procedure {decl.name} [defined via lang] {lang}"
      | none => s!"procedure {decl.name} [defined via expr] {a.expr}"

def ProcedureSpecification.kindString (proc : ProcedureSpecification) : String :=
  match proc.kind with
  | .action _ => "action"
  | .procedure _ => "procedure"

def ProcedureSpecification.actionDecl (proc : ProcedureSpecification) : Option ActionDeclaration :=
  match proc.kind with
  | .action decl => some decl
  | .procedure _ => none

def ProcedureSpecification.hasSpec (proc : ProcedureSpecification) : Bool :=
  proc.spec.isSome

def ActionSpecification.mkPlain (type : ActionKind) (name : Name) (expr : Expr) : ProcedureSpecification := {
  kind := .action { kind := type, name := name, ctor := none },
  lang := none,
  spec := none,
  expr := expr
}

def ProcedureSpecification.mkPlain (name : Name) (expr : Expr) : ProcedureSpecification := {
  kind := .procedure { name := name, ctor := none },
  lang := none,
  spec := none,
  expr := expr
}

def ProcedureSpecification.addDSLInfo (a : ProcedureSpecification) (lang : TSyntax ``Term.doSeq) (ctor : TSyntax `Lean.Parser.Command.ctor) : ProcedureSpecification :=
  match a.kind with
  | .action decl => { a with lang := some lang, kind := .action { decl with ctor := some ctor } }
  | .procedure decl => { a with lang := some lang, kind := .procedure { decl with ctor := some ctor } }

def ProcedureSpecification.name (a : ProcedureSpecification) : Name :=
  match a.kind with
  | .action decl => decl.name
  | .procedure decl => decl.name

def ProcedureSpecification.label (a : ProcedureSpecification) : Option (ActionLabel Name) :=
  match a.kind with
  | .action decl => some decl.label
  | .procedure _ => none

inductive StateAssertionKind
  | assumption
  | invariant
   
  | trustedInvariant
  | safety
deriving BEq, Hashable

instance : Inhabited StateAssertionKind where
  default := StateAssertionKind.invariant

instance : ToString StateAssertionKind where
  toString
    | StateAssertionKind.assumption => "assumption"
    | StateAssertionKind.invariant => "invariant"
    | StateAssertionKind.trustedInvariant => "trusted invariant"
    | StateAssertionKind.safety => "safety"

structure StateAssertion where
  kind : StateAssertionKind
  name : Name
   
  isolates : List Name := []
   
  term : Option (TSyntax `term)
   
  expr : Expr
deriving Inhabited, BEq

structure IsolatesInfo where
   
  openIsolates : List Name
   
  isolateStore : Std.HashMap Name (Std.HashSet Name)
deriving Inhabited

instance : ToString StateAssertion where
  toString sa := match sa.term with
    | some term => s!"{sa.kind} [{sa.name}] {term}"
    | none => s!"{sa.kind} [{sa.name}] {sa.expr}"

structure ModuleDependency where
  name       : Name
   
  parameters : Array (TSyntax `Lean.Parser.Term.bracketedBinder)
   
  arguments  : Array Term

abbrev Alias := Name

structure ModuleSpecification : Type where
   
  name         : Name
   
  parameters   : Array (TSyntax `Lean.Parser.Term.bracketedBinder)
   
  dependencies : Array (Alias × ModuleDependency)
   
  stateType    : Expr
   
  stateStx     : Term
   
  signature    : Array StateComponent
   
  assumptions  : Array StateAssertion
   
  init         : StateSpecification
   
  procedures    : Array ProcedureSpecification
   
  invariants   : Array StateAssertion
deriving Inhabited

def ModuleSpecification.arguments [Monad m] [MonadError m] [MonadQuotation m] (spec : ModuleSpecification) : m (Array Term) :=
  bracketedBindersToTerms spec.parameters

def ModuleSpecification.getStateComponent (spec : ModuleSpecification) (name : Name) : Option StateComponent :=
  spec.signature.find? (fun sc => sc.name == name)

def ModuleSpecification.getStateComponentTypeStx (spec : ModuleSpecification) (name : Name) : CoreM (Option Term) := do
  match spec.getStateComponent name with
  | some sc => return some (← sc.typeStx)
  | none => return none

def ModuleSpecification.immutableComponents (spec : ModuleSpecification) : Array StateComponent :=
  spec.signature.filter (fun sc => sc.isImmutable)

def ModuleSpecification.mutableComponents (spec : ModuleSpecification) : Array StateComponent :=
  spec.signature.filter (fun sc => sc.isMutable)

def ModuleSpecification.actions (spec : ModuleSpecification) : Array ProcedureSpecification :=
  spec.procedures.filter (fun proc => match proc.kind with
    | .action _ => true
    | .procedure _ => false)

def ModuleSpecification.transitionCtors (spec : ModuleSpecification) : CoreM (Array (TSyntax `Lean.Parser.Command.ctor)) := do
  spec.procedures.mapM (fun t => do match t.kind with
    | .action decl => match decl.ctor with
      | some ctor => return ctor
      | none => throwError "DSL: missing constructor for transition {t.name}"
    | .procedure _ => throwError "DSL: missing constructor for procedure {t.name}"
  )

instance : ToString ModuleSpecification where
  toString spec := s!"ModuleSpecification {spec.name}"

def project {α β : Type} (slices : β → Set (Set α)) (S : Set α) : β → Set (Set α) :=
  fun n => { Sl ∩ S | Sl ∈ slices n }

class System (Node : Type) where
   
  W : Set Node
  slices : Node → Set (Set Node)
   
  slices_ne : ∀ p ∈ W, slices p ≠ ∅

def System.project (sys : System Node) (I : Set Node) : System Node :=
  { W := sys.W
    slices := FBA.project sys.slices I
    slices_ne := by admit /- proof elided -/

def quorum (Q : Set Node) : Prop := ∀ p ∈ Q ∩ W, ∃ Sl ∈ slices p, Sl ⊆ Q

def blocks_slices (S : Set Node) (p : Node) : Prop :=
  ∀ Sl ∈ slices p, Sl ∩ S ≠ ∅

structure intertwined (S : Set Node) where
  well_behaved : S ⊆ W
   
  q_inter : (∀ Q Q',
    quorum (inst := inst.project S) Q →
    quorum (inst := inst.project S) Q' →
    Q ∩ S ≠ ∅ → Q' ∩ S ≠ ∅ → Q ∩ Q' ∩ S ≠ ∅)

structure intact (I : Set Node) extends intertwined I where
   
  q_avail : quorum (inst := inst) I

abbrev Context := Lean.Elab.Tactic.Context

abbrev State := Lean.Elab.Tactic.State

@[inline] private def _runCore (x : TacticM α) (ctx : Context) (s : State) : TermElabM (α × State) :=
  x ctx |>.run s

@[inline] private def _runCore' (x : TacticM α) (ctx : Context) (s : State) : TermElabM α :=
  Prod.fst <$> _runCore x ctx s

def run  (mvarId : MVarId) (x : TacticM α) : TermElabM (α × List MVarId) :=
  mvarId.withContext do
   let pendingMVarsSaved := (← get).pendingMVars
   modify fun s => { s with pendingMVars := [] }
   let aux : TacticM (α × List MVarId) :=
     try
       let ret ← x
       let unsolved ← getUnsolvedGoals
       return (ret, unsolved)
     catch ex =>
         throw ex
   try
     _runCore' aux { elaborator := .anonymous } { goals := [mvarId] }
   finally
     modify fun s => { s with pendingMVars := pendingMVarsSaved }

def veilSimpMaxSteps := 10 * Lean.Meta.Simp.defaultMaxSteps

def runSimp (e : Expr) (stx : TermElabM (TSyntax `tactic)) : TermElabM Simp.Result := do
  let stx ← stx
  let mv := (← mkFreshExprMVar e)
  let (res, [_l]) ← Tactic.run mv.mvarId! (do
    let sc <- mkSimpContext stx false
    let cfg := { sc.ctx.config with maxSteps := veilSimpMaxSteps }
    let ctx ← sc.ctx.setConfig cfg
    let res <- simp e ctx (simprocs := sc.simprocs) (discharge? := none)
    return res
  ) | throwError "[runSimp] expected exactly one goal after simplification"
  return res.1

def simpWp (e : Expr) : TermElabM Simp.Result := do
  let stx := `(tactic| simp only [wpSimp])
  runSimp e stx

def simpAction (e : Expr) : TermElabM Simp.Result := do
  let stx := `(tactic| simp only [actSimp, smtSimp, quantifierSimp])
  runSimp e stx

def runUnfold (e : Expr) (defs : List Name) : TermElabM Expr := do
  let mut eu := e
  for name in defs do eu := (<- unfold eu name).expr
  return eu

inductive TraceSpecLine
  | action : Name → TraceSpecLine
  | anyAction : TraceSpecLine
  | anyNActions : Nat → TraceSpecLine
  | assertion : Term → TraceSpecLine
deriving Inhabited, Repr

instance : ToString TraceSpecLine := ⟨fun
  | TraceSpecLine.action n => s!"action {n}"
  | TraceSpecLine.anyAction => "any action"
  | TraceSpecLine.anyNActions n => s!"any {n} actions"
  | TraceSpecLine.assertion t => s!"assertion {t}"⟩

abbrev TraceSpec := List TraceSpecLine

def parseTraceSpec [Monad m] [MonadExceptOf Exception m] [MonadError m] (stx : Syntax) : m TraceSpec := do
  match stx with
  | `(traceSpec| $[$ts]* ) => do
    let mut ts ← ts.mapM fun t => match t with
      | `(traceLine| any action) | `(traceLine| * ) => return TraceSpecLine.anyAction
      | `(traceLine| any $n:num actions) => do (
        if n.getNat < 2 then
          throwErrorAt stx "any {n} actions: n must be >= 2"
        else
          return TraceSpecLine.anyNActions n.getNat
      )
      | `(traceLine| assert $term) => return TraceSpecLine.assertion term
      | `(traceLine| $id:ident) => return TraceSpecLine.action id.raw.getId
      | _ => throwErrorAt stx "unsupported syntax"
    return ts.toList
  | _ => throwUnsupportedSyntax

def elabTraceSpec (r : TSyntax `expected_smt_result) (name : Option (TSyntax `ident)) (spec : TSyntax ``traceSpec) (pf : TSyntax `term)
  : CommandElabM Unit := do
  liftCoreM errorIfStateNotDefined
  let vd ← getAssertionParameters
  let th ← Command.runTermElabM fun vs => do
    let spec ← parseTraceSpec spec
    let numActions := spec.foldl (fun n s =>
      match s with
      | TraceSpecLine.assertion _ => n
      | TraceSpecLine.anyNActions k => n + k
      | _ => n + 1) 0
    let numStates := numActions + 1
    let stateNames := List.toArray $ (List.range numStates).map fun i => mkIdent (Name.mkSimple s!"st{i}")

     
    let mut currStateId := 0
     
    let mut assertions : Array (TSyntax `term) := #[]
    assertions := assertions.push (← `(term|(RelationalTransitionSystem.assumptions $(stateNames[0]!) ∧ (RelationalTransitionSystem.init $(stateNames[0]!)))))
    for s in spec do
      let currState := stateNames[currStateId]!
      match s with
      | TraceSpecLine.action n => do
        let nextState := stateNames[currStateId + 1]!
        let vs <- getSectionArgumentsStx vs
        let stx <- `(@$(mkIdent $ toTrName n) $vs*)
        
        let t ← `(term|($stx $currState $nextState))
        assertions := assertions.push t
        currStateId := currStateId + 1
      | TraceSpecLine.anyAction => do
        let nextState := stateNames[currStateId + 1]!
        let t ← `(term|(RelationalTransitionSystem.next $currState $nextState))
        assertions := assertions.push t
        currStateId := currStateId + 1
      
      | TraceSpecLine.anyNActions k => do
        for _ in [0:k] do
          let currState := stateNames[currStateId]!
          let nextState := stateNames[currStateId + 1]!
          let t ← `(term|(RelationalTransitionSystem.next $currState $nextState))
          assertions := assertions.push t
          currStateId := currStateId + 1
      | TraceSpecLine.assertion t => do
        
        
        let stx <- funcasesM t (← getStateArguments vd vs)
        let t ← elabBindersAndCapitals #[] vs stx fun _ e => do
          let e <- delabWithMotives e
          `(fun $(mkIdent `st) => $e: term)
        let t ← `(term|($t $currState))
        assertions := assertions.push t
    let name : Name ← match name with
    | some n => pure n.getId
    | none => mkFreshUserName (Name.mkSimple "trace")
    let th_id := mkIdent name
    let conjunction ← repeatedAnd assertions
    
    
    let stateTp ← getStateTpStx
    let binderNames : Array (TSyntax ``Lean.binderIdent) := stateNames.map toBinderIdent
    let vdE ← vd.mapM toExplicitBinders
    let assertion ← match r with
    | `(expected_smt_result| unsat) => `(∀ $[$vd]* ($[$stateNames]* : $stateTp), ¬ $conjunction)
    | `(expected_smt_result| sat) => `(∃ $[$vdE]* ($[$binderNames]* : $stateTp), $conjunction)
    | _ => dbg_trace "expected result is neither sat nor unsat!" ; unreachable!
    `(theorem $th_id : $assertion := by admit /- proof elided -/
    )
  elabCommand $ th

action with_block (b : block) = {
  let b' ← fresh block
  return (b, b')
}

action test = {
  let mut (z, y) := (5, 7)
}

action double_bind (r : Int) = {
    let (bb, b') ← with_block b
 }

#guard_msgs in

action state_acess_if = {
  if x then
    return True
  else
    return False
}

#guard_msgs in

action state_access_if_prop (n : node) = {
  if ¬ (n_have_privilege n) then
    return True
  else
    return False
}

inductive state_value where
  | v0 | v1 | vquestion
deriving DecidableEq, Nonempty

instance : ThreeValuedType state_value where
  v0 := state_value.v0
  v1 := state_value.v1
  vquestion := state_value.vquestion
  ax1 := by admit /- proof elided -/

instance : TotalOrderWithMinimum Nat where
  le := Nat.le
  le_refl := by admit /- proof elided -/

abbrev phase := Nat

abbrev State' node set_majority set_f_plus_1 proposal_value := State node set_majority set_f_plus_1 phase proposal_value state_value

def started_good (s : State' node set_majority set_f_plus_1 proposal_value) : Prop :=
  ∀ (p : phase), started p s → good p s

def validity_bc (s : State' node set_majority set_f_plus_1 proposal_value) : Prop :=
  ∀ N1 P1 V1, s.decision_bc N1 P1 V1 → ∃ N2, s.vote_rnd1 N2 0 V1

def agreement_bc (s : State' node set_majority set_f_plus_1 proposal_value) : Prop :=
  ∀ N1 P1 V1 N2 P2 V2,
    s.decision_bc N1 P1 V1 →
    s.decision_bc N2 P2 V2 →
    V1 = V2

def agreement2 (s : State' node set_majority set_f_plus_1 proposal_value) : Prop :=
  ∀ N1 P1 V1 N2 P2,
    s.decision_full_val N1 P1 V1 →
    s.decision_full_noval N2 P2 → False

inductive Mode where
  | internal : Mode
  | external : Mode
deriving BEq

@[inline] abbrev SProp := σ -> Prop

@[inline] abbrev RProp (ρ : Type u) := ρ → SProp σ

@[inline] abbrev TwoState := σ -> σ -> Prop

abbrev Wp (m : Mode) (σ ρ : Type) := σ -> RProp σ ρ -> Prop

abbrev Wlp (m : Mode) (σ ρ : Type) := σ -> RProp σ ρ -> Prop

abbrev BigStep := σ -> ρ -> σ -> Prop

@[actSimp] def Wp.pure (r : ρ) : Wp m σ ρ := fun s post => post r s

@[actSimp] def Wp.bind (wp : Wp m σ ρ) (wp_cont : ρ -> Wp m σ ρ') : Wp m σ ρ' :=
  fun s post => wp s (fun r s' => wp_cont r s' post)

@[actSimp] def Wp.assume (asm : Prop) : Wp m σ PUnit := fun s post => asm → post () s

@[actSimp] def Wp.assert (ast : Prop) : Wp m σ PUnit := fun s post => ast ∧ post () s

@[actSimp] def Wp.require (rq : Prop) : Wp m σ PUnit :=
  match m with
  | Mode.internal => Wp.assert rq
  | Mode.external => Wp.assume rq

@[actSimp] def Wp.fresh (τ : Type) : Wp m σ τ := fun s post => ∀ t, post t s

@[actSimp] def Wp.get : Wp m σ σ := fun s post => post s s

@[actSimp] def Wp.set (s' : σ) : Wp m σ Unit := fun _ post => post () s'

@[actSimp] def Wp.modifyGet (act : σ -> ρ × σ) : Wp m σ ρ := fun s post => let (ret, s') := act s ; post ret s'

@[actSimp] def Wp.spec (req : SProp σ) (ens : σ -> RProp σ ρ) : Wp m σ ρ :=
  fun s post =>
    match m with
    | .internal => req s ∧ ∀ r' s', (ens s r' s' -> post r' s')
    | .external => ∀ r' s', req s -> ens s r' s' -> post r' s'

instance : Monad (Wp m σ) where
  pure := Wp.pure
  bind := Wp.bind

instance : MonadStateOf σ (Wp m σ) where
  get := Wp.get
  set := Wp.set
  modifyGet := Wp.modifyGet

class IsSubStateOf (σ : semiOutParam Type) (σ' : Type) where
   
  setIn : σ -> σ' -> σ'
   
  getFrom : σ' -> σ

  setIn_getFrom_idempotent : ∀ σ', setIn (getFrom σ') σ' = σ'
  getFrom_setIn_idempotent : ∀ σ σ', getFrom (setIn σ σ') = σ

@[actSimp] def Wp.lift {σ σ'} [IsSubStateOf σ σ'] (act : Wp m σ ρ) : Wp m σ' ρ :=
  fun s' post => act (getFrom s') (fun r s => post r (setIn s s'))

instance [IsSubStateOf σ σ'] : MonadLift (Wp m σ) (Wp m σ') where
  monadLift := Wp.lift

@[wpSimp] def pureE : pure = Wp.pure (σ := σ) (ρ := ρ) (m := m) := rfl

@[wpSimp] def bindE : bind = Wp.bind (σ := σ) (ρ := ρ) (ρ' := ρ') (m := m) := rfl

@[wpSimp] def getE : get = Wp.get (σ := σ) (m := m) := rfl

@[wpSimp] def setE : set = Wp.set (σ := σ) (m := m) := rfl

@[wpSimp] def modifyGetE : modifyGet = Wp.modifyGet (σ := σ) (ρ := ρ) (m := m) := rfl

@[wpSimp] def monadLiftE [IsSubStateOf σ σ'] : monadLift = Wp.lift (σ := σ) (σ' := σ') (ρ := ρ) (m := m) := rfl

def BigStep.pure (r : ρ) : BigStep σ ρ := fun s r' s' => s' = s ∧ r' = r

def BigStep.bind (act : BigStep σ ρ) (act' : ρ -> BigStep σ ρ') : BigStep σ ρ' :=
  fun s r' s' => ∃ r s'', act s r s'' ∧ act' r s'' r' s'

def BigStep.assume (asm : Prop) : BigStep σ PUnit := fun s _ s' => asm ∧ s' = s

def BigStep.assert (ast : Prop) : BigStep σ PUnit := fun s _ s' => ast ∧ s' = s

def BigStep.fresh (τ : Type) : BigStep σ τ := fun s _r s' => s' = s

def BigStep.get : BigStep σ σ := fun s r s' => s' = s ∧ r = s

def BigStep.set (s : σ) : BigStep σ Unit := fun _s _r s' => s' = s

def BigStep.modifyGet (act : σ -> ρ × σ) : BigStep σ ρ := fun s r s' => let (ret, st) := act s; s' = st ∧ r = ret

def BigStep.spec (req : SProp σ) (ens : σ -> RProp σ ρ) : BigStep σ ρ :=
  fun s r s' => req s ∧ ens s r s'

def BigStep.lift [IsSubStateOf σ σ'] (act : BigStep σ ρ) : BigStep σ' ρ :=
  fun st r' st' => act (getFrom st) r' (getFrom st') ∧ st' = (setIn (@getFrom σ σ' _ st') st)

@[actSimp]
abbrev Wp.toWlp {σ ρ : Type} {m : Mode} (wp : Wp m σ ρ) : Wlp m σ ρ :=
  
  fun (s : σ) (post : RProp σ ρ) => ¬ wp s (fun r s' => ¬ post r s')

@[actSimp]
def Wp.toBigStep {σ} (wp : Wp m σ ρ) : BigStep σ ρ :=
  fun s r' s' =>
    wp.toWlp s (fun r₀ s₀ => r' = r₀ ∧ s' = s₀)

@[actSimp]
def Wp.toTwoState {σ} (wp : Wp m σ ρ) : TwoState σ :=
  fun s s' =>
    wp.toWlp s (fun _ s₀ => (s' = s₀))

@[actSimp]
def BigStep.toWp {σ} (act : BigStep σ ρ) : Wp .internal σ ρ :=
  fun s post => ∀ r s', act s r s' -> post r s'

@[actSimp]
def _root_.Function.toWp (m : Mode) (r : TwoState σ) : Wp m σ Unit :=
  fun s post => ∀ s', r s s' -> post () s'

abbrev refines {σ ρ} (act : Wp m σ ρ) (act' : Wp m σ ρ) : Prop :=
  ∀ s post, act s post -> act' s post

instance : LE (Wp m σ ρ) where
  le := refines

abbrev Wp.triple {σ ρ} (req : SProp σ) (act : Wp m σ ρ) (ens : RProp σ ρ) : Prop :=
  ∀ s, req s -> act s ens

abbrev Wp.alwaysSuccessfullyTerminates {σ } (req : SProp σ) (act : Wp m σ ρ)  : Prop :=
  ∀ s, req s -> act s (fun _ _ => True)

abbrev TwoState.triple {σ } (req : SProp σ) (act : TwoState σ) (ens : SProp σ) : Prop :=
  ∀ s s', req s -> act s s' -> ens s'

abbrev BigStep.triple {σ } (req : SProp σ) (act : BigStep σ ρ) (ens : RProp σ ρ) : Prop :=
  ∀ s r' s', req s -> act s r' s' -> ens r' s'

class LawfulAction {σ ρ : Type} (act : Wp m σ ρ) where
  inter {τ : Type} [Inhabited τ] (post : τ -> RProp σ ρ) :
    ∀ s : σ, (∀ t : τ, act s (post t)) -> act s (∀ t, post t · ·)

  impl (post post' : RProp σ ρ) : ∀ s,
    (∀ r s, post r s -> post' r s) -> act s post -> act s post'

instance pure_lawful : LawfulAction (Wp.pure (σ := σ) (m := m) r) where
  inter := by admit /- proof elided -/

instance bind_lawful (act : Wp m' σ ρ) (act' : ρ -> Wp m σ ρ') [LawfulAction act] [∀ r, LawfulAction (act' r)] : LawfulAction (Wp.bind (m := m) act act') where
  inter := by admit /- proof elided -/

instance (priority := low) internal_sound (act : Wp m σ ρ) [inst : LawfulAction (m := .internal) act] : LawfulAction (m := .external) act where
  inter := inst.inter
  impl := inst.impl

instance assume_lawful : LawfulAction (Wp.assume (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance assert_lawful : LawfulAction (Wp.assert (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance require_lawful : LawfulAction (Wp.require (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance fresh_lawful : LawfulAction (Wp.fresh (m := m) (σ := σ) τ) where
  inter := by admit /- proof elided -/

instance spec_lawful : LawfulAction (Wp.spec (m := m) req ens) where
  inter := by admit /- proof elided -/

instance (r : σ -> σ -> Prop) : LawfulAction (r.toWp (m := m)) where
  inter := by admit /- proof elided -/

instance get_lawful : LawfulAction (Wp.get (m := m) (σ := σ)) where
  inter := by admit /- proof elided -/

instance set_lawful (s : σ) : LawfulAction (Wp.set s (m := m)) where
  inter := by admit /- proof elided -/

instance modifyGet_lawful : LawfulAction (Wp.modifyGet f (m := m) (σ := σ) (ρ := ρ)) where
  inter := by admit /- proof elided -/

instance if_lawful [Decidable c] [instT: LawfulAction t] [instS : LawfulAction e] : LawfulAction (ite c t e) where
  inter := by admit /- proof elided -/

instance lift_lawful (act : Wp m σ ρ) [IsSubStateOf σ σ'] [LawfulAction act] :
  LawfulAction (act.lift (σ' := σ')) where
  inter := by admit /- proof elided -/

class GenBigStep (σ ρ : Type) (wp : Wp .external σ ρ) (tr : outParam (BigStep σ ρ)) where
  lawful : LawfulAction wp
  equiv pre  :
    wp.alwaysSuccessfullyTerminates pre -> ∀ s, pre s -> tr s = wp.toBigStep s

instance : GenBigStep σ ρ (Wp.pure r) (BigStep.pure r) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.assume asm) (BigStep.assume asm) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.assert asm) (BigStep.assert asm) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.require rq) (BigStep.assume rq) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ τ (Wp.fresh τ) (BigStep.fresh τ) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ Unit (Wp.set s) (BigStep.set s) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ σ (Wp.get) (BigStep.get) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ ρ (Wp.modifyGet act) (BigStep.modifyGet act) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ ρ (Wp.spec req ens) (BigStep.spec req ens) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance [inst : GenBigStep σ ρ act actTr] : LawfulAction act := inst.lawful

instance {σ σ'} [IsSubStateOf σ σ'] (act : Wp .external σ ρ) (actTr : BigStep σ ρ) [inst:GenBigStep σ ρ act actTr]
  : GenBigStep σ' ρ (Wp.lift (σ' := σ') act) (BigStep.lift (σ := σ) actTr) where
  lawful := inferInstance
  equiv pre := by admit /- proof elided -/

instance (act : Wp .external σ ρ) (act' : ρ -> Wp .external σ ρ')
  [inst: GenBigStep σ ρ act actTr] [inst' : ∀ r, GenBigStep σ ρ' (act' r) (actTr' r)] :
  GenBigStep σ ρ' (act.bind act') (actTr.bind actTr') where
  lawful := inferInstance
  equiv pre := by admit /- proof elided -/

action send_1a = {
  
  let r : round ← fresh
  require r ≠ none;
  one_a r := True
}

action join_round (n:node) (r:round) = {
    
    require r ≠ none;
    require one_a r;
    require ¬(∃ (r':round) (rMAX:round) (v:value), one_b_max_vote n r' rMAX v ∧ ¬ tot.le r' r);
    let maxr : round ← fresh
    let v : value ← fresh
      
    require ((maxr = none ∧ ∀ (mAXR:round) (v':value), ¬ (¬ tot.le r mAXR ∧ vote n mAXR v')) ∨
                    (maxr ≠ none ∧ ¬ tot.le r maxr ∧ vote n maxr v ∧
                    (∀ (mAXR:round) (v':value), (¬ tot.le r mAXR ∧ vote n mAXR v') -> tot.le mAXR maxr)
                   ));
    
    one_b_max_vote n r maxr v := True
}

action propose (r : round) (q: quorum) = {
    
    require r ≠ none;
    require ∀ V, ¬ proposal r V;
    require ∀ (n:node), member n q -> ∃ (r':round) (v:value), one_b_max_vote n r r' v;
    let maxr : round ← fresh
    let v : value ← fresh
    
    require ((maxr = none ∧ ∀ (n:node) (mAXR:round) (v:value), ¬ (member n q ∧ one_b_max_vote n r mAXR v ∧ mAXR ≠ none)) ∨
                    (maxr ≠ none ∧
                    (∃ (n:node), member n q ∧ one_b_max_vote n r maxr v) ∧
                    (∀ (n:node) (mAXR:round) (v:value), (member n q ∧ one_b_max_vote n r mAXR v ∧ mAXR ≠ none) -> tot.le mAXR maxr)
                    ));
    
    proposal r v := True

}

action cast_vote (n:node) (v:value) (r:round) = {
    
    require r ≠ none;
    require ¬(∃ (r':round) (rMAX:round) (v':value), one_b_max_vote n r' rMAX v' ∧ ¬ tot.le r' r);
    require proposal r v;
    vote n r v := True
}

action decide (n:node) (r:round) (v:value) (q:quorum) = {
    
    require r ≠ none;
    require ∀ N, member N q -> vote N r v;
    decision n r v := True
}

safety [coherence] (decision N1 R1 V1 ∧ decision N2 R2 V2) → V1 = V2

invariant [unique_proposals] (proposal R V1 ∧ proposal R V2) → V1 = V2

invariant [vote_proposal] (vote N R V) → proposal R V

invariant [decision_from_quorum] (∀ (R:round) (V:value), (∃ (N:node), decision N R V) → (∃ (Q:quorum), ∀ (N:node), member N Q → vote N R V))

invariant [one_b_max_vote_properties1] (one_b_max_vote N R2 none V1 ∧ ¬ tot.le R2 R1) → ¬ vote N R1 V2

invariant [one_b_max_vote_properties2] (one_b_max_vote N R RMAX V ∧ RMAX ≠ none) → ¬ tot.le R RMAX ∧ vote N RMAX V

invariant [one_b_max_vote_properties3] (one_b_max_vote N R RMAX V ∧ RMAX ≠ none ∧ ¬ tot.le R ROTHER ∧ ¬ tot.le ROTHER RMAX) → ¬ vote N ROTHER VOTHER

invariant [none_vote] ¬ vote N none V

invariant [choosable_proposal] (∀ (R1:round) (R2:round) (V1:value) (V2:value) (Q:quorum), ¬ tot.le R2 R1 ∧ proposal R2 V2 ∧ V1 ≠ V2 →
    (∃ (N:node) (R3:round) (RMAX:round) (V:value), member N Q ∧ ¬ tot.le R3 R1 ∧ one_b_max_vote N R3 RMAX V ∧ ¬ vote N R1 V1))

#gen_spec

#time #check_invariants

instance : BEq LocalDecl := ⟨fun a b => a.userName == b.userName⟩

partial def elabSdestructHyps (recursive : Bool := false) (ignoreHyps : Array LocalDecl := #[]) : TacticM Unit := withMainContext do
  let mut ignoreHyps := ignoreHyps
  let hypsToVisit : (Array LocalDecl → TacticM (Array LocalDecl)) := (fun ignoreHyps => withMainContext do
    return (← getLCtx).decls.filter Option.isSome
    |> PersistentArray.map Option.get!
    |> PersistentArray.toArray
    |> Array.filter (fun hyp => !ignoreHyps.contains hyp))
  trace[debug] "[elabSdestructHyps] visit {(← hypsToVisit ignoreHyps).map (·.userName)}"
  for hyp in (← hypsToVisit ignoreHyps) do
    ignoreHyps := ignoreHyps.push hyp
    if hyp.isImplementationDetail then
      continue
    let isStructure ← match hyp.type.getAppFn.constName? with
    | .none => pure false
    | .some sn => pure (isStructure (<- getEnv) sn)
    let name := mkIdent hyp.userName
    if isStructure then
      let dtac ← `(tactic| sdestruct $name:ident)
      evalTactic dtac
    else
      let isExists ← whnfIsAppOf hyp.type ``Exists
      if isExists then
        let lctx ← getLCtx
        
        
        let x := mkIdent $ lctx.getUnusedName (← existsBinderName hyp.type)
        let name' := mkIdent $ lctx.getUnusedName name.getId
        evalTactic $ ← `(tactic| rcases $name:ident with ⟨$x, $name'⟩)
  
  if recursive && (← hypsToVisit ignoreHyps).size > 0 then
    elabSdestructHyps recursive ignoreHyps

def getPropsInContext : TacticM (Array Ident) := do
  let mut props := #[]
  for hyp in (← getLCtx) do
    if hyp.isImplementationDetail then
      continue
    props := props.append (← collectPropertiesFromHyp hyp)
  let idents := (props.toList.eraseDups.map mkIdent).toArray
  return idents

def concatTacticSeq (xtacs : Array (TSyntax `Lean.Parser.Tactic.tacticSeq)) : TacticM (TSyntax `Lean.Parser.Tactic.tacticSeq) := do
  if xtacs.isEmpty then
    return ← `(tacticSeq|skip)
  let accInit ← `(tacticSeq|$(xtacs[0]!))
  let combined_tactic ← xtacs[1:].foldlM (init := accInit) fun acc tac => `(tacticSeq|
     ($acc)
     ($tac)
  )
  return combined_tactic

def elabSimplifyClause (simp0 : Array Ident := #[`initSimp, `actSimp].map mkIdent) (thorough :  Bool := true) (traceAt : Option Syntax := none): TacticM (Array Ident × Array (TSyntax `Lean.Parser.Tactic.tacticSeq)) := withMainContext do
  
  let mut xtacs := #[]
  
  let stateType ← findStateType (← getLCtx)
  let stateName := stateType.getAppFn.constName
  
  
  let destructTac ← `(tacticSeq| sdestruct_hyps)
  xtacs := xtacs.push destructTac
  evalTactic destructTac
  withMainContext do
  
  
  
  
  let injEqLemma := stateName ++ `mk ++ `injEq
  
  
  let simp0 := mkSimpLemmas simp0
  
  
  let thoroughSimp := mkSimpLemmas $ #[injEqLemma, `invSimp, `smtSimp, `logicSimp].map mkIdent
  let fastSimp := mkSimpLemmas $ #[`invSimp, `smtSimp].map mkIdent
  let finalSimp := mkSimpLemmas $ #[`quantifierSimp].map mkIdent
  let simp2 := if thorough then thoroughSimp else fastSimp
  let simpTac ← `(tacticSeq|
    (try dsimp only [$simp0,*] at *)
    (try simp only [$simp2,*] at *)
    (try simp only [$finalSimp,*] at *))
  let mut xtacs := xtacs.push simpTac
  withMainContext do
  evalTactic simpTac
  
  if (← getUnsolvedGoals).length == 0 then
    return ← finishWith #[] xtacs
  
  
  
  withMainContext do
  let mut xtacs := xtacs.push destructTac
  evalTactic destructTac
  
  
  
  withMainContext do
  let idents ← getPropsInContext
  return ← finishWith idents xtacs
  where
  finishWith (idents : Array Ident) (xtacs : Array (TSyntax `Lean.Parser.Tactic.tacticSeq)) : TacticM (Array Ident × Array (TSyntax `Lean.Parser.Tactic.tacticSeq)) := do
    if let some stx := traceAt then
      let combined_tactic ← concatTacticSeq xtacs
      addSuggestion stx combined_tactic
    return (idents, xtacs)

def elabSautoAll (stx : Syntax) (trace : Bool := false) : TacticM Unit := withMainContext do
  let idents ← getPropsInContext
  let auto_tac ← `(tactic| sauto [$[$idents:ident],*])
  if trace then
    addSuggestion stx auto_tac
  evalTactic auto_tac

def getInvariantsInSameIsolateAs (invInfo : StateAssertion) : TacticM (Array Ident) := do
  let mut invsToUnfold := #[]
  let isStore := (<- localSpecCtx.getIsolates).isolateStore
  unless invInfo.isolates.isEmpty do
    for is in invInfo.isolates do
      invsToUnfold := invsToUnfold.append <| isStore[is]!.toArray.map mkIdent
  return invsToUnfold

def elabSolveClause (stx : Syntax)
  (simp0 : Array Ident := #[`initSimp, `actSimp].map mkIdent)
  (inv : Option Name := none)
  (trace : Bool := false) : TacticM Unit := withMainContext do
  withTraceNode `veil.smt.perf.solveClause (fun _ => return "solve_clause") do
  if let some inv := inv then
    let enforceIsolate ← `(tactic|simp only [invSimpTopLevel] at *; sdestruct_hyps; enforce_isolate_for_invariant $(mkIdent inv))
    evalTactic enforceIsolate
  let (idents, xtacs) ← elabSimplifyClause simp0
  
  
  
  if (← getUnsolvedGoals).length != 0 then
    withMainContext do
      let autoTac ← `(tacticSeq| sauto [$[$idents:ident],*])
      if trace then
        addSuggestion stx (← concatTacticSeq (xtacs.push autoTac))
      evalTactic autoTac
  else
    if trace then
      addSuggestion stx (← concatTacticSeq xtacs)

def bmcSat : TacticM Unit := withMainContext do
  let originalGoal ← Tactic.getMainGoal
  
  let goal' ← mkFreshExprMVar (← Tactic.getMainTarget)
  replaceMainGoal [goal'.mvarId!]
  Veil.run `(tactic| simplify_all)
  if (← getUnsolvedGoals).length == 0 then
    originalGoal.admit (synthetic := false)
  else
    existIntoForall
    let simpLemmas := mkSimpLemmas $ #[`smtSimp].map mkIdent
    withMainContext do Veil.run `(tactic| unhygienic intros; sdestruct_hyps; (try simp only [$simpLemmas,*]))
    if (← getUnsolvedGoals).length == 0 then
      originalGoal.admit (synthetic := false)
    else
      admitIfSat
      if (← getUnsolvedGoals).length == 0 then
        originalGoal.admit (synthetic := false)
      else
        throwError "goal is not solved by SMT"
where
  existIntoForall := withMainContext do
    let goalType' ← turnExistsIntoForall (← Tactic.getMainTarget)
    let goal' ← mkFreshExprMVar goalType'
    replaceMainGoal [goal'.mvarId!]

@[actSimp, invSimp] abbrev next : seq_t → seq_t → Prop := λ x y => (x + 1) = y





relation n_have_privilege : node → Prop
relation n_requesting : node → Prop
function n_RN : node → node → seq_t

function n_token_seq : node → seq_t


relation reqs : node → node → seq_t → Prop


relation t_for : seq_t → node → Prop
function t_LN : seq_t → node → seq_t
relation t_q : seq_t → node → Prop


relation crit : node → Prop

#gen_state

after_init {
  n_have_privilege N := N = init_node;
  n_requesting N := False;
  n_RN N M := 0;
  n_token_seq N := if N = init_node then 1 else 0;

  reqs N M I := False;

  t_for I N := I = 1 ∧ N = init_node;
  t_LN I N := 0;
  t_q I N := False;

  crit N := False
}

action request (n : node) = {
  require ¬ n_requesting n;
  n_requesting n := True;
  if (¬ n_have_privilege n) then
    let k := (n_RN n n) + 1
    n_RN n n := k;
    reqs N n (n_RN n n) := N ≠ n
}


action rcv_request (n : node) (m : node) (r : seq_t) = {
  require reqs n m r;
  n_RN n m := if Nat.le r (n_RN n m) then n_RN n m else r;
  if (n_have_privilege n ∧ ¬ n_requesting n ∧ next (t_LN (n_token_seq n) m) (n_RN n m)) then
    n_have_privilege n := False;
    let k : seq_t := (n_token_seq n) + 1
    t_for k m := True;
    t_LN k N := t_LN (n_token_seq n) N;
    t_q k N := t_q (n_token_seq n) N
}

action rcv_privilege (n: node) (t: seq_t) = {
  require t_for t n;
  require Nat.lt (n_token_seq n) t;
  n_have_privilege n := True;
  n_token_seq n := t
}

action enter (n : node) = {
    require n_have_privilege n
    require n_requesting n
    
    crit n := True
}

action exit (n : node) = {
  require crit n;
  crit n := False;
  n_requesting n := False;
  t_LN (n_token_seq n) n := n_RN n n;
  t_q (n_token_seq n) N := next (t_LN (n_token_seq n) N) (n_RN n N);
  if m : (t_q (n_token_seq n) m) then
    t_q (n_token_seq n) m := False;
    n_have_privilege n := False;
    let k : seq_t := (n_token_seq n) + 1
    t_for k m := True;
    t_LN k N := t_LN (n_token_seq n) N;
    t_q k N := t_q (n_token_seq n) N
}

safety [mutex] (crit N ∧ crit M) → N = M

invariant [unique_tokens] ((t_for I N) ∧ (t_for I M)) → N = M
invariant ((n_token_seq N) ≠ 0) → t_for (n_token_seq N) N

invariant [curr_priv1] ((n_have_privilege N) ∧ N ≠ M) → (n_token_seq M) < (n_token_seq N)

invariant [curr_priv2] ((n_have_privilege N) ∧ (t_for I M)) → I ≤ (n_token_seq N)

invariant [no_request_to_self] (reqs N M I) → N ≠ M
invariant ((t_for I N) ∧ ((J + 1) = I) ∧ (t_for J M)) → N ≠ M

invariant [token_relation] ((t_for I N) ∧ (t_for J M) ∧ I < J) → I ≤ (n_token_seq N)

invariant [one_priv] (n_have_privilege N ∧ n_have_privilege M) → N = M

invariant [allowed_crit] (crit N) → (n_have_privilege N ∧ n_requesting N)

#gen_spec

sat trace {
  request
  enter
  exit
  request
  enter
  exit
} by bmc_sat

unsat trace {
  enter
  enter
  any 2 actions
} by bmc

def toActionAttribute (type : ActionKind) : AttrM (TSyntax `Lean.Parser.Term.attrInstance) :=
  match type with
  | .internal => `(attrInstance|internalActDef)
  | .input => `(attrInstance|inputActDef)
  | .output => `(attrInstance|outputActDef)

def toActionAttribute' (type : ActionKind) : Lean.Elab.Attribute :=
  match type with
  | .internal => {name := `internalActDef}
  | .input => {name := `inputActDef}
  | .output => {name := `outputActDef}

def declareProcedure [Monad m] [MonadEnv m] [MonadError m] (actT : Option ActionKind)  (declName : Name) : m Unit := do
  let procedureExists := (← localSpecCtx.get).spec.procedures.any fun t => t.name == declName
  if procedureExists then
    throwError "A procedure or action named {declName} has already been declared!"
  let spec := match actT with
    | some actT => ActionSpecification.mkPlain actT declName (mkConst declName)
    | none => ProcedureSpecification.mkPlain declName (mkConst declName)
  localSpecCtx.modify (fun s => { s with spec := {s.spec with procedures := s.spec.procedures.push spec }})

@[term_elab currentDirectory] def elabCurrentFilePath : TermElab
  | `(currentDirectory!), _ => do
    let ctx ← readThe Lean.Core.Context
    let srcPath := System.FilePath.mk ctx.fileName
    let some srcDir := srcPath.parent
      | throwError "cannot compute parent directory of '{srcPath}'"
    return mkStrLit s!"{srcDir}"
  | _, _ => throwUnsupportedSyntax

def toBinderIdent (i : Ident) : TSyntax ``binderIdent := Unhygienic.run <|
  withRef i `(binderIdent| $i:ident)

def toIdent (bi : TSyntax ``binderIdent) : Ident :=
  match bi with
  | `(binderIdent|$i:ident) => i
  | _ => unreachable!

def toBracketedBinderArray (stx : TSyntax `Lean.explicitBinders) : MetaM (TSyntaxArray `Lean.Parser.Term.bracketedBinder) := do
  let mut binders := #[]
  match stx with
  | `(explicitBinders|$bs*) => do
    binders := binders.append (← bs.mapM helper)
  | _ => throwError "unexpected syntax in explicit binder: {stx}"
  return binders.flatten
  where
  helper (stx : TSyntax `Lean.bracketedExplicitBinders) : MetaM (TSyntaxArray `Lean.Parser.Term.bracketedBinder) := do
    let mut binders := #[]
    match stx with
    | `(bracketedExplicitBinders|($bis* : $tp)) => do
      for bi in bis do
        let id := toIdent bi
        let fb ← `(bracketedBinder| ($id : $tp:term))
        binders := binders.push fb
      pure ()
    | _ => throwError "unexpected syntax in explicit binder: {stx}"
    return binders

def toExplicitBinders [Monad m] [MonadError m] [MonadQuotation m] (stx : TSyntax `Lean.Parser.Term.bracketedBinder) : m (TSyntax `Lean.bracketedExplicitBinders) := do
  match stx with
  | `(bracketedBinder| ($id:ident : $tp:term))
  | `(bracketedBinder| [$id:ident : $tp:term])
  | `(bracketedBinder| {$id:ident : $tp:term}) =>
    return ← `(bracketedExplicitBinders|($(toBinderIdent id) : $tp))
  | _ => throwError "unexpected syntax in explicit binder: {stx}"

def toFunBinderArray (stx : TSyntax `Lean.explicitBinders) : MetaM (TSyntaxArray `Lean.Parser.Term.funBinder) := do
  let mut binders := #[]
  match stx with
  | `(explicitBinders|$bs*) => do
    binders := binders.append (← bs.mapM helper)
  | _ => throwError "unexpected syntax in explicit binder: {stx}"
  return binders.flatten
  where
  helper (stx : TSyntax `Lean.bracketedExplicitBinders) : MetaM (TSyntaxArray `Lean.Parser.Term.funBinder) := do
    let mut binders := #[]
    match stx with
    | `(bracketedExplicitBinders|($bis* : $tp)) => do
      for bi in bis do
        let id := toIdent bi
        let fb ← `(Lean.Parser.Term.funBinder| ($id : $tp:term))
        binders := binders.push fb
      pure ()
    | _ => throwError "unexpected syntax in explicit binder: {stx}"
    return binders

def explicitBindersIdents (stx : TSyntax `Lean.explicitBinders) : MetaM (TSyntaxArray `term) := do
  let mut vars := #[]
  match stx with
  | `(explicitBinders|$bs*) => do
    for b in bs do
      match b with
      | `(bracketedExplicitBinders|($bis* : $_tp)) => do
        for bi in bis do
          let id := toIdent bi
          vars := vars.push id
      | _ => throwError "unexpected syntax in explicit binder: {b}"
  | _ => throwError "unexpected syntax in explicit binder: {stx}"
  return vars

def bracketedBinderIdent [Monad m] [MonadError m] [MonadQuotation m] (stx : TSyntax `Lean.Parser.Term.bracketedBinder) : m (Option Ident) := do
  match stx with
  | `(bracketedBinder| ($id:ident : $_tp)) => return id
  | `(bracketedBinder| [$id:ident : $_tp]) => return id
  | `(bracketedBinder| {$id:ident : $_tp}) => return id
  | _ => return none

def bracketedBindersToTerms [Monad m] [MonadError m] [MonadQuotation m] (stx : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) : m (Array Term) := do
  let idents : Array (Option Ident) ← stx.mapM bracketedBinderIdent
  let terms ← idents.mapM (fun mid => do
    match mid with
    | some id => `(term|$id)
    | none => `(term|_))
  return terms

def toBindersWithInferredTypes (stx : TSyntax `Lean.explicitBinders) [Monad m] [MonadEnv m] [MonadError m] [MonadQuotation m] : m (TSyntax `Lean.explicitBinders) := do
 let mut newBinders := #[]
  match stx with
  | `(explicitBinders|$bs*) => do
    for b in bs do
      match b with
      | `(bracketedExplicitBinders|($bis* : $_tp)) => do
         newBinders := newBinders.push (← `(bracketedExplicitBinders|($bis* : _)))
      | _ => throwError "unexpected syntax in explicit binder: {b}"
  | _ => throwError "unexpected syntax in explicit binder: {stx}"
  return ← `(explicitBinders| $newBinders*)

def toBindersWithMappedTypes [Monad m] [MonadQuotation m] [MonadError m] (stx : TSyntax `Lean.explicitBinders) (mapping : Array (Term × Term)) : m (TSyntax `Lean.explicitBinders) := do
  let mut newBinders := #[]
  match stx with
  | `(explicitBinders|$bs*) => do
    for b in bs do
      match b with
      | `(bracketedExplicitBinders|($bis* : $tp)) => do
        let newTp := match mapping.find? (fun (paramType, _argType) => paramType == tp) with
          | some (_, newTp) => newTp
          | none => tp
        newBinders := newBinders.push $ ← `(bracketedExplicitBinders|($bis* : $newTp))
      | _ => throwError "unexpected syntax in explicit binder: {b}"
  | _ => throwError "unexpected syntax in explicit binder: {stx}"
  let newStx ← `(explicitBinders|$newBinders*)
  return newStx

def mkArrowStx [Monad m] [MonadQuotation m] [MonadError m] (tps : List Term) (terminator : Option $ TSyntax `term := none) : m (TSyntax `term) := do
  match tps with
  | [] => if let some t := terminator then return t else throwError "empty list of types and no terminator"
  | [a] => match terminator with
    | none => `(term| $a)
    | some t => `(term| $a -> $t)
  | a :: as =>
    let cont ← mkArrowStx as terminator
    `(term| $a -> $cont)

def complexBinderToSimpleBinder [Monad m] [MonadQuotation m] [MonadError m] (nm : TSyntax `ident) (br : TSyntaxArray `Lean.Parser.Term.bracketedBinder) (domT : TSyntax `term) : m (TSyntax `Lean.Parser.Command.structSimpleBinder) := do
  let types ← br.mapM fun m => match m with
    | `(bracketedBinder| ($_arg:ident : $tp:term)) => return tp
    | _ => throwError "Invalid binder syntax {br}"
  let typeStx ← mkArrowStx types.toList domT
  let simple ← `(Lean.Parser.Command.structSimpleBinder| $nm:ident : $typeStx)
  return simple

def getSimpleBinderName [Monad m] [MonadError m] (sig : TSyntax `Lean.Parser.Command.structSimpleBinder) : m Name := do
  match sig with
  | `(Lean.Parser.Command.structSimpleBinder| $nm:ident : $_:term) => pure nm.getId
  | _ => throwError s!"getSimpleBinderName: don't know how to handle {sig}"

def getSimpleBinderType (sig : TSyntax `Lean.Parser.Command.structSimpleBinder) : CoreM (TSyntax `term) := do
  match sig with
  | `(Lean.Parser.Command.structSimpleBinder| $_:ident : $tp:term) => pure tp
  | _ => throwError s!"getSimpleBinderType: don't know how to handle {sig}"

def createExistsBinders [Monad m] [MonadQuotation m] (vars : Array (Ident × Option Name)) : m (Array (TSyntax `Lean.bracketedExplicitBinders)) := do
  let binders ← vars.mapM fun (var, sort) => do
    let bi := toBinderIdent var
    match sort with
    | none => return ← `(bracketedExplicitBinders|($bi : _))
    | some sort => return ← `(bracketedExplicitBinders|($bi : $(mkIdent sort)))
  return binders

def repeatedExists [Monad m] [MonadQuotation m] (vars : Array (Ident × Option Name)) (body : TSyntax `term) : m (TSyntax `term) := do
  let binders ← createExistsBinders vars
  if binders.size == 0 then return body
  else `(term|∃ $binders*, $body)

def createForallBinders [Monad m] [MonadQuotation m] (vars : Array (Ident × Option Name)) : m (Array (TSyntax `Lean.Parser.Term.bracketedBinder)) := do
  let binders ← vars.mapM fun (var, sort) => do
    match sort with
    | none => return ← `(bracketedBinder|($var))
    | some sort => return ← `(bracketedBinder|($var : $(mkIdent sort)))
  return binders

def repeatedForall  [Monad m] [MonadQuotation m] (vars : Array (Ident × Option Name)) (body : TSyntax `term) : m (TSyntax `term) := do
  let binders ← createForallBinders vars
  if binders.size == 0 then return body
  else `(term|∀ $binders*, $body)

def repeatedOp [Monad m] [MonadQuotation m] (op : Name) (default : TSyntax `term) (operands : Array (TSyntax `term)) : m (TSyntax `term) := do
  if operands.isEmpty then return default
  else
    let last := operands.size - 1
    let initT := operands[last]!
    let acc := operands[0:last]
    acc.foldrM (init := initT) fun operand acc => `(term|$(mkIdent op) $operand $acc)

def repeatedAnd [Monad m] [MonadQuotation m] (operands : Array (TSyntax `term)) : m (TSyntax `term) := do
  repeatedOp `And (default := ← `(term|$(mkIdent `True))) operands

def repeatedOr  [Monad m] [MonadQuotation m] (operands : Array (TSyntax `term)) : m (TSyntax `term) := do
  repeatedOp `Or (default := ← `(term|$(mkIdent `False))) operands

def mkOrN : List Expr → Expr
  | [] => mkConst ``True
  | [p] => p
  | p :: ps => mkOr p (mkOrN ps)

def simpleAddDefn (n : Name) (e : Expr)
  (red := Lean.ReducibilityHints.regular 0)
  (attr : Array Attribute := #[])
  (type : Option Expr := none) : TermElabM Unit := do
  addDecl <|
    Declaration.defnDecl <|
      mkDefinitionValEx n [] (type.getD <| ← Meta.inferType e) e red
      (DefinitionSafety.safe) []
  enableRealizationsForConst n
  Elab.Term.applyAttributes n attr

def mkLambdaFVarsImplicit (vs : Array Expr) (e : Expr) : TermElabM Expr := do
  let e <- Meta.mkLambdaFVars vs e
  return go vs.size e
  where go (cnt : Nat) (e : Expr) : Expr :=
    match cnt, e with
    | 0, _ => e
    | _, Expr.lam n d b .default =>
      let b := go (cnt-1) b
      Expr.lam n d b .implicit
    | _, Expr.lam n d b bi =>
      let b := go (cnt-1) b
      Expr.lam n d b bi
    | _, _ => e

def combineLemmas (op : Name) (exps: List Expr) (vs : Array Expr) (name : String) : MetaM Expr := do
    let exp0 :: exprs := exps
      | throwError ("There are no " ++ name ++ " defined")
    let exp0 <- etaExpand exp0
    let exps <- lambdaTelescope exp0 fun args exp0 => do
      let mut exps := exp0
      for exp in exprs do
        let exp := mkAppN exp args
        exps <- mkAppM op #[exp, exps]
      mkLambdaFVars args exps
    instantiateLambda exps vs

partial def turnExistsIntoForall (e : Expr) : MetaM Expr := do
  match_expr e with
  | Exists _t eBody =>
  lambdaBoundedTelescope eBody (maxFVars := 1) (fun ks lBody => do
    mkForallFVars ks (← turnExistsIntoForall lBody)
  )
  | _ => return e

def getItemsFromDoSeq [Monad m] [MonadError m] [MonadQuotation m] (l : TSyntax `Lean.Parser.Term.doSeq) : m (TSyntaxArray `Lean.Parser.Term.doSeqItem) := do
  match l with
  | `(doSeq|$items*) => pure items
  | `(doSeq|{ $items* }) => pure items
  | _ => throwError "Unexpected doSeq: {l}"

def prepareLeanSmtQuery (mv' : MVarId) (hs : List Expr) : MetaM String := do
  \n{goalType}"
    trace[veil.smt] "query:\n{cmdString}"
    return cmdString

def prepareLeanAutoQuery (mv : MVarId) (hints : TSyntax `Auto.hints) : TacticM String := do
  withTraceNode `veil.smt.perf.translate (fun _ => return "prepareAutoQuery") do
  \n" (commands.toList.map toString)
    return queryStr

action send (n next : node) = {
   
  require n ≠ next ∧ ∀ Z, ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (id n next : node) = {
  require isNext n next
  require pending id n
   
  pending id n := *

   

   
  if (id = n) then
    leader n := True
  else
    if (le n id) then
      pending id next := True
}

safety [single_leader] leader L1 ∧ leader L2 → L1 = L2

invariant [leader_greatest] leader L → le N L

invariant [receive_self_msg_only_if_greatest] pending L L → le N L

invariant [no_bypass] pending S D ∧ btw S N D → le N S

 
#gen_spec

def whnfIsAppOf (typ : Expr) (n : Name) : MetaM Bool := do
  let norm ← Meta.whnf typ
  return norm.isAppOf n

def existsBinderName (typ : Expr) : MetaM Name := do
  let norm ← Meta.whnf typ
  match_expr norm with
  | Exists _ body => return body.bindingName!
  | _ => throwError "Expected an existential quantifier, got {norm}"

def newHypotheses (oldCtx : LocalContext) (newCtx : LocalContext) : TacticM (Array LocalDecl) := do
  let mut newHyps := #[]
  for hyp in newCtx do
    if (oldCtx.findFromUserName? hyp.userName |>.isNone) &&
       !hyp.isImplementationDetail then
      newHyps := newHyps.push hyp
  return newHyps

def Veil.run (t: TacticM Syntax): TacticM Unit := Lean.Elab.Tactic.withMainContext do
    evalTactic (<- t)

def Veil.tryGoal (t: TacticM Unit): TacticM Unit := do
  t <|> return ()

def getCtxNames (ctx : LocalContext) : TacticM (Array Name) := do
  let mut hyps := #[]
  for hyp in ctx do
    hyps := hyps.push hyp.userName
  return hyps

def Veil.allGoals [Inhabited α]
  (tac : TacticM α) (comb : List α -> α := fun _ => default)  : TacticM α := do
  if (<- getUnsolvedGoals).length == 0 then
    tac
  else
    withMainContext do
      let mvarIds ← getUnsolvedGoals
      let mut mvarIdsNew := #[]
      let mut ans := []
      for mvarId in mvarIds do
        unless (← mvarId.isAssigned) do
          setGoals [mvarId]
          let (ans', mvarIdsNew') <- withMainContext do
            let mut ans := ans
            let mut mvarIdsNew := mvarIdsNew
            try
              let a <- tac
              ans := a :: ans
              mvarIdsNew := mvarIdsNew ++ (← getUnsolvedGoals)
            catch ex =>
              if (← read).recover then
                
                mvarIdsNew := mvarIdsNew.push mvarId
              else
                throw ex
            return (ans, mvarIdsNew)
          (ans, mvarIdsNew) := (ans', mvarIdsNew')
      setGoals mvarIdsNew.toList
      return comb ans

def findStateType (ctx : LocalContext) : TacticM Expr := do
  for hyp in ctx do
    if (hyp.type.isAppOf `RelationalTransitionSystem.init) ||
       (hyp.type.isAppOf `RelationalTransitionSystem.inv) ||
       (hyp.type.isAppOf `RelationalTransitionSystem.safe) ||
       (hyp.type.isAppOf `RelationalTransitionSystem.next)
    then
      return hyp.type.getAppArgs[0]!
  
  let stateName ← getStateName
  return (mkConst stateName)

def hypIsClass (hyp : LocalDecl) : TacticM Bool := do
  let env ← getEnv
  match hyp.type.getAppFn.constName? with
  | some name => return name ≠ ``And ∧ isStructure env name
  | none => return false

def isHypToCollect (typ : Expr) : MetaM Bool := do
  
  
  
  let isInhabitationFact ← whnfIsAppOf typ ``Nonempty
  return (← Meta.isProp typ) && !isInhabitationFact

def collectPropertiesFromHyp (hyp : LocalDecl) : TacticM (Array Name) := do
  let env ← getEnv
  let mut props := #[]
  if ← isHypToCollect hyp.type then
    props := props.push hyp.userName
  if ← hypIsClass hyp then
    let tyctor := hyp.type.getAppFn.constName?.get!
    let .some info := getStructureInfo? env tyctor
      | throwError "{tyctor} has no StructureInfo despite `hypIsClass` returning `true`"
    for field in info.fieldInfo do
      
      if field.subobject?.isSome then
        continue
      let proj := (env.find? field.projFn).get!
      if ← isHypToCollect proj.type then
        props := props.push field.projFn
  return props

def mkSimpName (n : Ident) :=
     mkNode `Lean.Parser.Tactic.simpLemma #[Syntax.node default nullKind #[], Syntax.node default nullKind #[], Syntax.ident SourceInfo.none default n.getId []]

def namesToLemmas (simpIds : Array (TSyntax `Lean.Parser.Tactic.simpLemma)) : Syntax.TSepArray `Lean.Parser.Tactic.simpLemma "," := Syntax.TSepArray.ofElems simpIds

def mkSimpLemmas (simpIds : Array Ident) : Syntax.TSepArray `Lean.Parser.Tactic.simpLemma "," := namesToLemmas (simpIds.map mkSimpName)

safety [vote_integrity]
  ∀ (src dst : address) (r : round) (v : value),
     ¬ is_byz src ∧ ¬ is_byz dst ∧ voted dst src r v → (sent src r ∧ initial_value src r v)

safety [deliver_integrity]
  ∀ (src dst : address) (r : round) (v : value),
     ¬ is_byz src ∧ ¬ is_byz dst ∧ delivered dst src r v → (sent src r ∧ initial_value src r v)

safety [agreement]
  ∀ (src dst₁ dst₂ : address) (r : round) (v₁ v₂ : value),
    ¬ is_byz dst₁ ∧ ¬ is_byz dst₂ ∧ delivered dst₁ src r v₁ ∧ delivered dst₂ src r v₂ → v₁ = v₂

invariant [sent_iff_initial]
  ∀ (src : address) (r : round),
    ¬ is_byz src → (sent src r ↔ ∃ (v : value), initial_value src r v)

invariant [echoed_iff_echo]
  ∀ (n dst originator : address) (r : round) (v : value),
    ¬ is_byz n → (echoed n originator r v ↔ echo_msg n dst originator r v)

invariant [echoed_requires_initial]
  ∀ (n originator : address) (r : round) (v : value),
    ¬ is_byz n → (echoed n originator r v → initial_msg originator n r v)

invariant [voted_iff_vote]
  ∀ (n dst originator : address) (r : round) (v : value),
    ¬ is_byz n → (voted n originator r v ↔ vote_msg n dst originator r v)

invariant [voted_requires_echo_quorum_or_vote_quorum]
  ∀ (n originator : address) (r : round) (v : value),
    ¬ is_byz n → (voted n originator r v →
      (∃ (q : nodeset), nset.supermajority q ∧
        ∀ (src : address), member src q → echo_msg src n originator r v) ∨
      (∃ (q : nodeset), nset.greater_than_third q ∧
        ∀ (src : address), member src q → vote_msg src n originator r v))

invariant [delivered_requires_vote_quorum]
  ∀ (n originator : address) (r : round) (v : value),
    ¬ is_byz n → (delivered n originator r v →
      ∃ (q : nodeset), nset.supermajority q ∧
        ∀ (src : address), member src q → vote_msg src n originator r v)

invariant [initial_value_iff_initial_msg]
  ∀ (src dst : address) (r : round) (v : value),
    ¬ is_byz src → (initial_value src r v ↔ initial_msg src dst r v)

invariant [honest_non_conflicting_initial_msg]
  ∀ (src dst₁ dst₂ : address) (r : round) (v₁ v₂ : value),
    (¬ is_byz src) → (initial_msg src dst₁ r v₁ ∧ initial_msg src dst₂ r v₂ → v₁ = v₂)

invariant [honest_non_conflicting_echoes]
  ∀ (src originator dst₁ dst₂ : address) (r : round) (v₁ v₂ : value),
    (¬ is_byz src) → (echo_msg src dst₁ originator r v₁ ∧ echo_msg src dst₂ originator r v₂ → v₁ = v₂)

invariant [honest_non_conflicting_votes]
  ∀ (src originator dst₁ dst₂ : address) (r : round) (v₁ v₂ : value),
    (¬ is_byz src) → (vote_msg src dst₁ originator r v₁ ∧ vote_msg src dst₂ originator r v₂ → v₁ = v₂)

#gen_spec

#time #check_invariants

class RingTopology (t : Type) where
  
  btw : t → t → t → Prop

  
  
  trans : ∀ w x y z, btw w x y → btw w y z → btw w x z
  acyclic : ∀ w x y, btw w x y → ¬ btw w y x
  total : ∀ w x y, btw w x y ∨ btw w y x ∨ w = x ∨ x = y
  cyclic_perm : ∀ x y z, btw x y z ∧ x ≠ z → btw y z x

type node
instantiate ring : RingTopology node

relation a : node → Prop
relation s1 : node → node → Prop
relation in_s1 : node → Prop
relation s2 : node → node → Prop
relation in_s2 : node → Prop
relation p : node → node → Prop

immutable individual org : node
immutable individual other : node
relation reach : node → Prop
relation error : node → Prop

#gen_state

assumption other ≠ org

after_init {
  a X := X = org ∨ X = other;
  s1 X Y := (X = org ∧ Y = other) ∨ (X = other ∧ Y = org);
  in_s1 X := X = org ∨ X = other;
  s2 X Y := False;
  in_s2 X := False;
  p X Y := (X = org ∧ Y = other) ∨ (X = other ∧ Y = org);
  reach X := X = org;
  error X := False
}

action join (x : node) (y : node) = {
  require ¬ a x;
  require ∀ Y, a Y;
  require ¬ ring.btw x org y;
  a x := True;
  s1 x Y := y = Y;
  in_s1 x := True;
  s2 x Y := False;
  in_s2 x := False;
  p x Y := False
}

action stabilize (x : node) (y : node) (z : node) = {
  require a x;
  require s1 x y;
  require a y;
  require p y z;
  require ring.btw x z y;
  s1 x Z := Z = z;
  in_s1 x := True;
  s2 x Y := Y = y;
  in_s2 x := True
}

action notify (x : node) (y : node) (z : node) = {
  require a x;
  require s1 x y;
  require a y;
  require ∀ X, p y z ∨ ¬ p y X;
  require ring.btw z x y;
  p y X := X = x
}

action inherit (x : node) (y : node) (z : node) = {
  require a x;
  require s1 x y;
  require a y;
  require s1 y z;
  s2 x Z := Z = z;
  in_s2 x := True
}

action remove (x : node) (y : node) (z : node) = {
  require a x;
  require s1 x y;
  require ¬ a y;
  require s2 x z;
  s1 x Z := Z = z;
  in_s1 x := True;
  s2 x Y := False;
  in_s2 x := False
}

action fail (x : node) = {
  require a x;
  require x ≠ org;
  require ∀ Y, (s1 Y x → in_s2 Y);
  require ∀ Y Z, s1 Y x ∧ s2 Y Z → a Z;
  require ∀ X Y, s1 X Y ∧ s2 X x → (Y ≠ x ∧ a Y);
  a x := False;
  p x Y := False;
  s1 x Y := False;
  in_s1 x := False;
  s2 x Y := False;
  in_s2 x := False
}

action reach_org (x : node) (y : node) (z : node) = {
  require (s1 x y ∧ a y ∧ reach y) ∨ (s1 x y ∧ ¬ a y ∧ s2 x z ∧ a z ∧ reach z);
  reach x := True
}

action remove_org (x : node) (y : node) (z : node) = {
  require x ≠ org;
  require s1 x y;
  require ¬ a y ∨ ¬ reach y;
  require ∀ Z, (¬ a y) → (¬ s2 x Z ∨ s2 x z);
  require (¬ a y ∧ s2 x z) → (¬ a z ∨ ¬ reach z);
  reach x := False
}

action test (x : node) = {
  require ∀ X Y, (s1 X Y ∧ a Y ∧ reach Y) → reach X;
  require ∀ X Y Z, (s1 X Y ∧ ¬ a Y ∧ s2 X Z ∧ a Z ∧ reach Z) → reach X;
  require ∀ Y, (ring.btw x Y org ∧ a Y) → reach x;
  require a x;
  require ¬ reach x;
  require in_s1 x → ∃ y, s1 x y;
  require in_s2 x → ∃ y, s2 x y;
  error x := True
}

safety [no_error] ¬ error N

invariant [manual_1] s1 X Y → in_s1 X

invariant [manual_2] s2 X Y → in_s2 X

invariant [manual_3] reach org

invariant [manual_4] s1 X Y ∧ s1 X Z → Y = Z

invariant [manual_5] s2 X Y ∧ s2 X Z → Y = Z

invariant [manual_6] p X Y ∧ p X Z → Y = Z

invariant [manual_7] a X ∨ X ≠ org

invariant [manual_8] a X ∨ ¬ p Y X ∨ ¬ s1 X Y

invariant [manual_9] a X ∨ p Y X ∨ ¬ s1 X Y

invariant [manual_10] a X ∨ ¬ s2 X Y

invariant [manual_11] in_s1 X ∨ ¬ a X

invariant [manual_12] a Y ∨ a Z ∨ ¬ s1 X Y ∨ ¬ s2 X Z

invariant [manual_13] a Y ∨ in_s2 X ∨ ¬ a X ∨ ¬ s1 X Y

invariant [manual_14] p A B → a A

invariant [manual_15] a X ∧ p Y X ∧ s1 X Y → a Y

invariant [manual_16] ¬ ring.btw X org Y ∨ ¬ s1 X Y

invariant [manual_17] ¬ (s1 V0 V1 ∧ V1 ≠ org ∧ s2 V0 V2 ∧ ring.btw V0 org V2)

#gen_spec

#time #check_invariants

action foo = { pure () }

invariant [inv] True

def parseAutoHints : TSyntax `smtHints → TacticM (TSyntax `Auto.hints)
  | `(Smt.Tactic.smtHints| [ $[$hs:term],* ]) => `(Auto.hints| [$[$hs:term],*])
  | `(Smt.Tactic.smtHints| ) => `(Auto.hints| [])
  | _ => do throwError s!"Failure in parseAutoHints on {← getRef}"

private def solverStr (solver : Option SmtSolver := none) : String :=
  match solver with
  | some solver => s!"{solver}: "
  | none => ""

def satGoalStr (solver : Option SmtSolver := none) : String := s!"{solverStr solver}the goal is false"

def unknownGoalStr (solver : Option SmtSolver := none) : String := s!"{solverStr solver}the goal is unknown"

def failureGoalStr (solver : Option SmtSolver := none) : String := s!"{solverStr solver}solver invocation failed"

@[tactic sauto] def elabSauto : Tactic := fun stx => withMainContext do
  let hints : TSyntax `smtHints := ⟨stx[1]⟩
  let mv ← Tactic.getMainGoal
  let withTimeout := veil.smt.timeout.get (← getOptions)
  \n{modelString}"
      \n(we could not minimize this model; {modelGenerationFailureDiagnostic})"
      else ""
      let modelString := minimizationWarning ++ fostruct.mkString
      throwError s!"{satGoalStr solverUsed}:{modelString}"
    | .Unknown reason => throwError "{unknownGoalStr solverUsed}{if reason.isSome then s!": {reason.get!}" else ""}"
    | .Failure reason => throwError "{failureGoalStr solverUsed}{if reason.isSome then s!": {reason.get!}" else ""}"
    | .Unsat => mv.admit (synthetic := false)

action vote1 (n : node) = {
  require alive n;
  require ¬vote_no n;
  require ¬decide_commit n;
  require ¬decide_abort n;
  vote_yes n := True
}

action vote2(n: node) = {
  require alive n;
  require ¬vote_yes n;
  require ¬decide_commit n;
  require ¬decide_abort n;
  vote_no n := True;
  abort_flag := True;
  decide_abort n := True
}

action fail(n: node) = {
  require alive n;
  alive n := False;
  abort_flag := True
}

action go1 = {
  require ∀ N, ¬go_commit N;
  require ∀ N, ¬go_abort N;
  require ∀ N, vote_yes N;
  go_commit N := True
}

action go2 = {
  require ∀ N, ¬go_commit N;
  require ∀ N, ¬go_abort N;
  require exists n, vote_no n ∨ ¬alive n;
  go_abort N := True
}

action commit(n: node) = {
  require alive n;
  require go_commit n;
  decide_commit n := True
}

action abort(n: node) = {
  require alive n;
  require go_abort n;
  decide_abort n := True
}

safety (decide_commit N → ¬decide_abort N2) ∧ (decide_commit N -> vote_yes N2) ∧ (decide_abort N → abort_flag)

invariant [manual_1] ¬((¬(alive N) ∧ ¬(abort_flag)))

invariant [manual_2] ¬((¬(abort_flag) ∧ vote_no N))

invariant [manual_3] ¬((¬(abort_flag) ∧ go_abort N))

invariant [manual_4] ¬((¬(go_abort N) ∧ decide_abort N ∧ vote_yes N))

invariant [manual_5] ¬((¬(go_commit N) ∧ decide_commit N))

invariant [manual_6] (N0 ≠ N1) -> ¬((¬(go_commit N0) ∧ go_commit N1))

invariant [manual_7] ¬((¬(vote_yes N) ∧ go_commit N))

invariant [manual_8] ¬((go_commit N ∧ go_abort N))

#gen_spec

def wpUnfold := [``Wp.bind, ``Wp.pure, ``Wp.get, ``Wp.set, ``Wp.modifyGet,
  ``Wp.assert, ``Wp.assume, ``Wp.require, ``Wp.spec, ``Wp.lift, ``Wp.toTwoState]

def toActionKind (stx : TSyntax `actionKind) : ActionKind :=
  match stx with
  | `(actionKind|input) => ActionKind.input
  | `(actionKind|internal) => ActionKind.internal
  | `(actionKind|output) => ActionKind.output
  | _ => unreachable!

def toActionKindIdent (stx : TSyntax `actionKind) : Ident :=
  mkIdent $ match stx with
  | `(actionKind|input) => ``ActionKind.input
  | `(actionKind|internal) => ``ActionKind.internal
  | `(actionKind|output) => ``ActionKind.output
  | _ => unreachable!

def ActionKind.stx [Monad m] [MonadQuotation m] : ActionKind → m (TSyntax `actionKind)
  | .input => `(actionKind|input)
  | .internal => `(actionKind|internal)
  | .output => `(actionKind|output)

def Mode.stx [Monad m] [MonadQuotation m] : Mode → m (TSyntax `term)
  | .internal => `(term|$(mkIdent ``Mode.internal))
  | .external => `(term|$(mkIdent ``Mode.external))

def parseActionKindStx (stx : Option (TSyntax `actionKind)) : CommandElabM (TSyntax `actionKind) := do
  return stx.getD $ ← `(actionKind|internal)

def assertProcedureDeclared [Monad m] [MonadEnv m] [MonadResolveName m] [MonadError m] (nm : Name) (op : String) : m Unit := do
  let procedureExists := (← localSpecCtx.get).spec.procedures.any fun t => t.name == nm
  if !procedureExists then
    throwError "Procedure {nm} has not been declared (trying to {op})"

def registerIOActionDecl (actT : TSyntax `actionKind) (nm : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)): CommandElabM Unit := do
  assertActionDeclared nm.getId "registerIOActionDecl"
  Command.runTermElabM fun _ => do
    let name := nm.getId
    let labelTypeName := mkIdent `Label
    let br ← match br with
    | some br => toBracketedBinderArray br
    | none => pure $ TSyntaxArray.mk #[]
    let ctor ← `(ctor| | $nm:ident $br* : $labelTypeName)
    let actdecl : ActionDeclaration := {
      kind := toActionKind actT,
      name := name,
      ctor := ctor
    }
     
    localSpecCtx.modify (fun s =>
      { s with spec.procedures :=
        s.spec.actions.map fun t =>
          if t.name == nm.getId then
            { t with kind := .action actdecl }
          else t})
where assertActionDeclared (nm : Name) (op : String) := do
  let actionExists := (← localSpecCtx.get).spec.actions.any fun t => t.name == nm
  if !actionExists then
    throwError "Action {nm} has not been declared (trying to {op})"

def registerProcedureBinders [Monad m] [MonadEnv m] [MonadResolveName m] [MonadError m] (nm : Name) (br : Option (TSyntax `Lean.explicitBinders)) : m Unit := do
  assertProcedureDeclared nm "registerProcedureBinders"
  localSpecCtx.modify fun s =>
    { s with spec.procedures := s.spec.procedures.map fun t =>
      if t.name == nm then
        { t with br := br }
      else t }

def registerProcedureSyntax [Monad m] [MonadEnv m] [MonadResolveName m] [MonadError m] (nm : Name) (lang : TSyntax `Lean.Parser.Term.doSeq) : m Unit := do
  assertProcedureDeclared nm "registerProcedureSyntax"
  localSpecCtx.modify fun s =>
    { s with spec.procedures := s.spec.procedures.map fun t =>
      if t.name == nm then
        { t with lang := lang }
      else t }

def registerProcedureSpec [Monad m] [MonadEnv m] [MonadResolveName m] [MonadError m] (nm : Name) (spec : Option (TSyntax `Lean.Parser.Term.doSeq)) : m Unit := do
  assertProcedureDeclared nm "registerProcedureSpec"
  localSpecCtx.modify fun s =>
    { s with spec.procedures := s.spec.procedures.map fun t =>
      if t.name == nm then
        { t with spec := spec }
      else t }

def defineProcedureGenerators (act : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (l : doSeq) : CommandElabM (Name × Name) := do
  Command.runTermElabM fun vs => do
    let funBinders ← match br with
    | some br => toFunBinderArray br
    | none => pure #[]
    let baseName := (← getCurrNamespace) ++ act.getId
    let (genIName, _genExpI) ← genGenerator vs funBinders baseName .internal l
    let (genEName, _genExpE) ← genGenerator vs funBinders baseName .external l
    return (genIName, genEName)
where

def defineInitialActionFromGenerators (act : TSyntax `ident) (genIName genEName : Name) : CommandElabM Unit := do
    Command.runTermElabM fun _ => do
      
      let baseName := (← getCurrNamespace) ++ act.getId
      let _actIName ← genInitialAction baseName .internal genIName
      let _actEName ← genInitialAction baseName .external genEName
where

def defineActionFromGenerators (actT : TSyntax `actionKind) (act : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (genIName genEName : Name) (generateTransition : Bool := true): CommandElabM Unit := do
    let vd ← getImplicitProcedureParameters
    declareProcedure (toActionKind actT) act.getId
    registerIOActionDecl actT act br
    registerProcedureBinders act.getId br
    Command.runTermElabM fun vs => do
      
      let sectionArgs ← getSectionArgumentsStx vs
      let baseName := (← getCurrNamespace) ++ act.getId
      let (_actIName, actIPf) ← genAction baseName .internal genIName
      let (_actEName, actEPf) ← genAction baseName .external genEName
      if generateTransition then
        genTransition vs sectionArgs baseName
        if veil.gen_sound.get <| <- getOptions then
          genSoundness vd vs br baseName actIPf actEPf
where

def defineProcedureFromGenerator (proc : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (genIName : Name) : CommandElabM Unit := do
    declareProcedure .none proc.getId
    registerProcedureBinders proc.getId br
    Command.runTermElabM fun _ => do
      let baseName := (← getCurrNamespace) ++ proc.getId
      let _ ← genProcedure baseName genIName
where

def defineAction (actT : TSyntax `actionKind) (act : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (l : doSeq) : CommandElabM Unit := do
  let (genIName, genEName) ← defineProcedureGenerators act br l
  defineActionFromGenerators actT act br genIName genEName
  registerProcedureSyntax act.getId l

def defineProcedure (proc : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (l : doSeq) : CommandElabM Unit := do
  let (genIName, _genEName) ← defineProcedureGenerators proc br l
  defineProcedureFromGenerator proc br genIName
  registerProcedureSyntax proc.getId l

def genStateExtInstances : CommandElabM Unit := do
  let currName <- getCurrNamespace
  let vd := (<- getScope).varDecls
  let insts <- Command.runTermElabM fun vs => do
    let mut insts := #[]
    for (modAlias, dep) in (<- localSpecCtx.get).spec.dependencies do
      let ts ← dep.stateArguments
      let currTs <- getStateArgumentsStx vd vs
      let alia := mkIdent modAlias
      let stateExtTypeclass := mkIdent ``IsSubStateOf
      let inst <-
        `(@[actSimp]

          instance :
           $stateExtTypeclass
             (@$(mkIdent $ dep.name ++ `State) $ts*)
             (@$(mkIdent $ currName ++ `State) $currTs*) where
            setIn := fun s s' => { s' with $alia:ident := s }
            getFrom := fun s' => s'.$alia
            setIn_getFrom_idempotent := by admit /- proof elided -/

def liftProcedureGenerators (forAct : TSyntax `ident) (withBinders : Option (TSyntax `Lean.explicitBinders)) (stateTpT : TSyntax `term) (fromBaseGenerator : Name) (instatiatedWithArgs : Array Term) (isInitialAction : Bool := false) : CommandElabM (Name × Name) := do
  Command.runTermElabM fun vs => do
    let baseName := (← getCurrNamespace) ++ forAct.getId
    let (genIName, _genExpI) ← liftGenerator baseName vs withBinders fromBaseGenerator instatiatedWithArgs .internal isInitialAction
    let (genEName, _genExpE) ← liftGenerator baseName vs withBinders fromBaseGenerator instatiatedWithArgs .external isInitialAction
    return (genIName, genEName)
where
  liftGenerator (liftedActName : Name) (actVs : Array Expr) (actBinders :  Option (TSyntax `Lean.explicitBinders)) (baseNameToLift : Name) (depArgs : Array Term) (mode : Mode) (isInitialAction : Bool)  := do
    let baseGenName := toGenName baseNameToLift mode
    let (actParams, actArgs) ← match actBinders with
    | some br => pure (← toFunBinderArray br, ← explicitBindersIdents br)
    | none => pure (#[], #[])
    let infer ← `(term|_)
    let (srcWpType, typeClassInst, retType) := (infer, infer, infer)
    
    let dstWpType ← `(term|Wp $(← mode.stx) ($stateTpT))
    let liftedGenStx ← `(fun $actParams* => @monadLift $srcWpType $dstWpType $typeClassInst $retType <| @$(mkIdent baseGenName) $depArgs* $actArgs*)
    let liftedGenName := toGenName liftedActName mode
    trace[veil.info] "{liftedGenName} := {liftedGenStx}"
    let genExp <- withDeclName liftedGenName do elabTermAndSynthesize liftedGenStx .none
    let ⟨genExp, _, _⟩ <- simpWp genExp
    let genExp <- instantiateMVars <| <- mkLambdaFVarsImplicit actVs genExp
    let initAttr := if isInitialAction then #[{name := `initSimp}] else #[]
    simpleAddDefn liftedGenName genExp (attr := #[{name := `generatorSimp}, {name := `actSimp}, {name := `reducible}] ++ initAttr)
    return (liftedGenName, genExp)

def defineDepsProcedures : CommandElabM Unit := do
  let stateTpT ← liftCoreM $ getStateTpStx
  for (modAlias, dependency) in (<- localSpecCtx.get).spec.dependencies do
    
    let depArgs := dependency.arguments
    let globalCtx <- globalSpecCtx.get
    let some depCtx := globalCtx[dependency.name]? | throwError "Module {dependency.name} is not declared"
    
    let initName := dependency.name ++ `initializer
    let liftedName := mkIdent <| modAlias ++ (stripFirstComponent initName)
    trace[veil.info] "lifting {initName} from module {dependency.name} to module {← specName} as {liftedName}"
    let (genIName, genEName) ← liftProcedureGenerators liftedName .none stateTpT initName depArgs (isInitialAction := true)
    defineInitialActionFromGenerators liftedName genIName genEName
    
    for procToLift in depCtx.spec.procedures do
      let procBaseName := dependency.name ++ procToLift.name
      
      
      
      
      let actBaseName := if procToLift.hasSpec then toSpecName procBaseName else procBaseName
      let liftedName := mkIdent <| modAlias ++ (stripFirstComponent actBaseName)
      
      
      
      
      
      
      let liftedBinders ← do match procToLift.br with
        | some br => pure (Option.some (← toBindersWithMappedTypes br (← dependency.typeMapping)))
        | none => pure .none
      trace[veil.info] "lifting {procToLift.kindString} {actBaseName} from module {dependency.name} to module {← specName} as {liftedName}"
      let (genIName, genEName) ← liftProcedureGenerators liftedName liftedBinders stateTpT actBaseName depArgs
      match procToLift.kind with
      | .action decl =>
        let actionKind ← Veil.ActionKind.stx decl.kind
        defineActionFromGenerators actionKind liftedName liftedBinders genIName genEName
      | .procedure _ => defineProcedureFromGenerator liftedName liftedBinders genIName

def defineTransition (actT : TSyntax `actionKind) (nm : TSyntax `ident) (br : Option (TSyntax `Lean.explicitBinders)) (tr : Term) : CommandElabM Unit := do
  let vd ← getImplicitProcedureParameters
  let baseName := (← getCurrNamespace) ++ nm.getId
  let (origName, trName) := (toOriginalIdent nm, toTrIdent nm)
  let (originalDef, trDef) ← Command.runTermElabM fun vs => do
    let stateTpT ← getStateTpStx
    let trType <- `($stateTpT -> $stateTpT -> Prop)
    let sectionArgs ← getSectionArgumentsStx vs
    let (univBinders, args) ← match br with
    | some br => pure (← toBracketedBinderArray br, ← explicitBindersIdents br)
    | none => pure (#[], #[])
    
    let originalDef ← `(@[actSimp] def $origName $[$vd]* $univBinders* : $trType := $tr)
    
    
    
    let trDef ← do
      let (st, st') := (mkIdent `st, mkIdent `st')
      let rhs ← match br with
      | some br => `(fun ($st $st' : $stateTpT) => ∃ $br, @$origName $sectionArgs* $args* $st $st')
      | none => `(fun ($st $st' : $stateTpT) => @$origName $sectionArgs* $args* $st $st')
      `(@[actSimp] def $trName $[$vd]* : $trType := $(← unfoldWp rhs))
    return (originalDef, trDef)
  trace[veil.info] "{originalDef}"
  elabCommand originalDef
  trace[veil.info] "{trDef}"
  elabCommand trDef
  let (genIName, genEName) ← Command.runTermElabM fun vs => do
    let (genIName, _genExpI) ← genGeneratorFromTransition vs origName baseName .internal
    let (genEName, _genExpE) ← genGeneratorFromTransition vs origName baseName .external
    return (genIName, genEName)
  
  defineActionFromGenerators actT nm br genIName genEName (generateTransition := false)
where
  genGeneratorFromTransition (vs : Array Expr) (origName : Ident) (baseName : Name) (mode : Mode) := do
    let genName := toGenName baseName mode
    let sectionArgs ← getSectionArgumentsStx vs
    let (funBinders, args) ← match br with
    | some br => pure (← toFunBinderArray br, ← explicitBindersIdents br)
    | none => pure (#[], #[])
    let term ← match mode with
    | Mode.internal => `((@$origName $sectionArgs* $args*).toWp .internal)
    | Mode.external => `((@$origName $sectionArgs* $args*).toWp .external)
    let genl ← `(fun $funBinders* => $term)
    let genExp <- withDeclName genName do elabTermAndSynthesize genl none
    let genExp <- instantiateMVars <| <- mkLambdaFVarsImplicit vs genExp
    simpleAddDefn genName genExp (attr := #[{name := `generatorSimp}, {name := `actSimp}, {name := `reducible}]) («type» := ← inferType genExp)
    return (genName, genExp)

action sabotage (n: node) = {
    require ¬ honest n;
    block_confirmed n B T := *;
    transaction_confirmed TR n := *
}

safety
      ((honest N1 ∧ honest N2) → (block_confirmed N1 B T ∧ block_confirmed N2 B T) ∨ (¬ block_confirmed N1 B T ∧ ¬ block_confirmed N2 B T))
    ∧ ((honest N1 ∧ honest N2) → (transaction_confirmed TR N1 ∧ transaction_confirmed TR N2) ∨ (¬ transaction_confirmed TR N1 ∧ ¬ transaction_confirmed TR N2))
    ∧ ((honest N ∧ leader N T2 ∧ transaction_time TR T1 ∧ tot.le T1 T2 ∧ broadcasted N ∧ honest N1) → transaction_confirmed TR N1)


invariant block_found N1 B1 TI1  ∨ ¬ honest N1  ∨ ¬ broadcastable N1 B1 TI1
invariant leader N1 TI1  ∨ ¬ honest N1  ∨ ¬ broadcastable N1 B1 TI1
invariant leader N1 TI1  ∨ ¬ block_found N1 B1 TI1
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ honest N1  ∨ ¬ broadcastable N1 B1 TI2  ∨ ¬ block_found N1 B1 TI1)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ honest N1  ∨ ¬ broadcastable N1 B1 TI1  ∨ ¬ block_found N1 B1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ honest N1  ∨ ¬ broadcastable N1 B1 TI1  ∨ ¬ broadcastable N1 B1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ leader N1 TI2  ∨ ¬ honest N1  ∨ ¬ broadcastable N1 B1 TI1)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ leader N1 TI1  ∨ ¬ block_found N1 B1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ leader N1 TI2  ∨ ¬ block_found N1 B1 TI1)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ block_found N1 B1 TI1  ∨ ¬ block_found N1 B1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ leader N1 TI1  ∨ ¬ honest N1  ∨ ¬ broadcastable N1 B1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ leader N1 TI1  ∨ ¬ leader N1 TI2)
invariant (tot.le TI1 TI2  ∧ TI1 ≠ TI2) -> (¬ transaction_time TR1 TI1  ∨ ¬ transaction_time TR1 TI2)

#gen_spec

#time #check_invariants

def displaySuggestion (stx : Syntax) (theorems : Array (TSyntax `command)) (preMsg : Option String := none) := do
    Command.liftTermElabM do
    let cmd ← constructCommands theorems
    let suggestion : Suggestion := {
      suggestion := cmd
      preInfo? := preMsg
      toCodeActionTitle? := .some (fun _ => "Replace with explicit proofs.")
    }
    addSuggestion stx suggestion (header := "")

def emoji (res : SmtResult) : String :=
  match res with
  | .Unsat => "✅"
  | .Sat _ => "❌"
  | .Unknown _ => s!"❓"
  | .Failure reason => s!"💥 {reason}"

def getBaseNameForDisplay (n : Name) : Name := stripFirstComponent n

structure TheoremIdentifier where
  invName : Name
   
  actName : Option Name
  theoremName : Name
deriving Inhabited, BEq, ToJson, FromJson, Hashable

def getTimeForDisplay [Monad m] [MonadOptions m] (time : Option TimeInMs) : m String := do
  if !veil.showVerificationTime.get (← getOptions) then
    return ""
  return match time with
  | .some time => s!" ({time} ms)"
  | .none => ""

def getInitCheckResultMessages' [Monad m] [MonadOptions m]  (res: List (Name × SmtResult × Option TimeInMs)) : m (Array String) := do
  let mut msgs := #[]
  if !res.isEmpty then
    msgs := msgs.push "Initialization must establish the invariant:"
    for (invName, (r, time)) in res do
      msgs := msgs.push s!"  {getBaseNameForDisplay invName} ... {emoji r}{← getTimeForDisplay time}"
  pure msgs

def getInitCheckResultMessages [Monad m] [MonadOptions m] (res : List (TheoremIdentifier × SmtResult × Option TimeInMs)) : m (Array String) := getInitCheckResultMessages' (res.map (fun (id, r) => (id.invName, r)))

def getActCheckResultMessages' [Monad m] [MonadOptions m] (res: List (Name × Name × SmtResult × Option TimeInMs)) : m (Array String) := do
  let mut msgs := #[]
  if !res.isEmpty then
    msgs := msgs.push "The following set of actions must preserve the invariant:"
    for (actName, invResults) in group res do
      msgs := msgs.push s!"  {getBaseNameForDisplay actName}"
      for (invName, (r, time)) in invResults do
        msgs := msgs.push s!"    {getBaseNameForDisplay invName} ... {emoji r}{← getTimeForDisplay time}"
  pure msgs
where group {T : Type} (xs : List (Name × T)) : List (Name × List T) :=
  xs.foldl (fun acc (key, val) =>
    match acc.find? (fun (k, _) => k = key) with
    | some (k, vs) =>
          acc.filter (fun (k', _) => k' ≠ key) ++ [(k, vs ++ [val])]
    | none =>
      acc ++ [(key, [val])]) []

def getActCheckResultMessages [Monad m] [MonadOptions m] (res : List (TheoremIdentifier × SmtResult × Option TimeInMs)) : m (Array String) := getActCheckResultMessages' (res.map (fun (id, r) => (id.actName.get!, id.invName, r)))

def getModelStr (msg : String) : String :=
  let resWithErr := match msg.splitOn Veil.SMT.satGoalStr with
    | [_, model] => model
     
    | _ :: model :: _rest => model
    | _ => msg
   
  match resWithErr.splitOn "\n\n" with
  | [model, _] => model
  | _ => resWithErr

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  send_msg n next
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

action foo = { pure () }

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L

#gen_spec

def _root_.Lean.EnvExtension.set (ext : EnvExtension σ) (s : σ)
  [Monad m] [MonadEnv m] : m Unit := do
  Lean.setEnv $ ext.setState (<- getEnv) s

def _root_.Lean.EnvExtension.modify (ext : EnvExtension σ) (s : σ -> σ)
  [Monad m] [MonadEnv m] : m Unit := do
  Lean.modifyEnv (ext.modifyState · s)

def _root_.Lean.EnvExtension.get [Inhabited σ] (ext : EnvExtension σ)
  [Monad m] [MonadEnv m] : m σ := do
  return ext.getState (<- getEnv)

def _root_.Lean.SimpleScopedEnvExtension.get [Inhabited σ] (ext : SimpleScopedEnvExtension α σ)
  [Monad m] [MonadEnv m] : m σ := do
  return ext.getState (<- getEnv)

def _root_.Lean.SimpleScopedEnvExtension.modify
  (ext : SimpleScopedEnvExtension α σ) (s : σ -> σ)
  [Monad m] [MonadEnv m] : m Unit := do
  Lean.modifyEnv (ext.modifyState · s)

structure LocalSpecificationCtx where
  spec : ModuleSpecification
   
  stateBaseName: Option Name
   
  isolates: IsolatesInfo
   
  establishedClauses : List Name := []
deriving Inhabited

def _root_.Lean.SimpleScopedEnvExtension.getIsolates (ext : SimpleScopedEnvExtension LocalSpecificationCtx LocalSpecificationCtx)
  [Monad m] [MonadEnv m] : m IsolatesInfo := do
  return (ext.getState (<- getEnv)).isolates

def _root_.Lean.SimpleScopedEnvExtension.modifyIsolates
  (ext : SimpleScopedEnvExtension LocalSpecificationCtx LocalSpecificationCtx) (s : IsolatesInfo -> IsolatesInfo)
  [Monad m] [MonadEnv m] : m Unit := do
  Lean.modifyEnv (ext.modifyState · (fun ctx => { ctx with isolates := s ctx.isolates }))

abbrev GlobalSpecificationCtx := Std.HashMap Name LocalSpecificationCtx

def registerModuleSpecification : AttrM Unit := do
  let lctx := <- localSpecCtx.get
  let n := lctx.spec.name
  if (← globalSpecCtx.get).contains n then
    throwError "Specification {n} has already been declared"
  trace[veil] "Globally declaring specification {n}"
  globalSpecCtx.add (n, lctx)

action expire (d: deadline) = {
  expired d := True
}

safety [cancelled_after_deadline] cancelled N K V D → expired D

safety [paid_if_enough_sigs] paid N K V D → (∀ s, sig N K V D s ∧ sig_auth s)

safety [paid] paid N K V D → proposed N K V D

invariant [ic3po_global2] collect V1 D1 V2 D2 → proposed V1 D1 V2 D2

invariant [ic3po_global3] sig V1 D1 V2 D2 S1 → sig_auth S1
#gen_spec

#time #check_invariants

action fresh_with_type = {
  let b ← fresh block
}

action fresh_with_lhs_type = {
  let b : block ← fresh
}

action fresh_with_lhs_type_ok = {
  let b : block ← (fresh)
  let q : queue ← fresh
}

action fresh_with_lhs_type_2 = {
  let b : block ← fresh
  let q : queue ← fresh
}

class IsHigherOrder.{u} (t : Sort u)

instance (t₁ t₂ : Type) : IsHigherOrder (t₁ -> t₂) := ⟨⟩

instance (t₁ : Type) (t₂ : Prop) : IsHigherOrder (t₁ -> t₂) := ⟨⟩

partial def getTopLevelHOExists (e : Expr) : SimpM (Array Name) := do
  let rec go (e : Expr) (acc : Array Name) : SimpM (Array Name) := do
    
    let_expr Exists t eBody ← e | return acc
    let qs ← ← lambdaBoundedTelescope eBody (maxFVars := 1) (fun ks lBody => do
        let #[k] := ks
          | throwError "[getExistentialsOverState::go] Expected exactly one variable in the lambda telescope"
        if ← isHigherOrder t then
          let decl := (← k.fvarId!.findDecl?).get!
          return go lBody (acc.push decl.userName)
        else
          return go lBody acc
    )
    return qs
  go e #[]

partial def forallLambdaLetTelescope (type : Expr) (k : Array Expr → Expr → MetaM α) (cleanupAnnotations : Bool) : MetaM α := do
  let rec go (type : Expr) (acc : Array Expr) : MetaM α := do
    match type with
    | Expr.forallE .. => forallTelescope type (fun xs body => go body (acc ++ xs)) cleanupAnnotations
    | Expr.lam ..  | Expr.letE .. => lambdaLetTelescope type (fun xs body => go body (acc ++ xs)) cleanupAnnotations
    | _ => k acc type
  go type #[]

def allHOQuantIsTopLevelForAll (t : Expr) : MetaM Bool := do
  let t ← Meta.reduceAll t
  forallLambdaLetTelescope t (fun _ body => do return !(← hasHigherOrderQuantification body)) true

def HO_exists_push_left_impl : Simp.Simproc := fun e => do
  let_expr Exists t eBody := e | return .continue
  
  let step : Simp.Step ← lambdaBoundedTelescope eBody (maxFVars := 1) (fun ks lBody => do
      let_expr Exists t' eBody' := lBody | return .continue
      
      
      
      if (← isHigherOrder t') && !(← isHigherOrder t) && !(dependsOn t' ks)  then
        let step : Simp.Step ← lambdaBoundedTelescope eBody' (maxFVars := 1) (fun ks' lBody' => do
          
          let innerExists := mkAppN e.getAppFn #[t, ← mkLambdaFVars ks lBody']
          let outerExists := mkAppN lBody.getAppFn #[t', ← mkLambdaFVars ks' innerExists]
          let body ← mkLambdaFVars (ks ++ ks') lBody'
          let proof ← mkAppOptM ``exists_comm_eq #[t, t', body]
          return .visit { expr := outerExists, proof? := proof })
        return step
      else
        return .continue
  )
  return step
where
  dependsOn (child : Expr) (deps : Array Expr) : Bool :=
    child.find? (fun e => deps.contains e) != none

simproc HO_exists_push_left (∃ _ _, _) := HO_exists_push_left_impl

def HO_forall_push_left_impl : Simp.Simproc := fun e => do
  match e with
  | Expr.forallE _ t (Expr.forallE _ t' _ .default) .default =>
    if (← isHigherOrder t') && !(← isHigherOrder t) then
      let step ← forallBoundedTelescope e (maxFVars? := some 2) (fun ks body' => do
        let e' ← mkForallFVars ks.reverse body'
        let body ← mkLambdaFVars ks body'
        let proof ← mkAppOptM ``forall_comm_eq #[t, t', body]
        return .visit { expr := e', proof? := proof }
      )
      return step
    else
      return .continue
  | _ => return .continue

simproc HO_forall_push_left (∀_ _, _) := HO_forall_push_left_impl

def getLeanAutoNameFor (name : String) : CoreM String := do
    let mut preName := name.map (fun c => if allowed c then c else '_')
    if preName.all (fun c => c == '_') then
      preName := "pl_" ++ preName
    if preName.back.isDigit then
      preName := preName ++ "_"
    
    
    return "_" ++ preName
  where
    allowed (c : Char) :=
      let allowedStr : String :=
        "~!@$%^&*_-+=<>.?/" ++
        "ΑαΒβΓγΔδΕεΖζΗηΘθΙιΚκΛλΜμΝνΞξΟοΠπΡρΣσςΤτΥυΦφΧχΨψΩω" ++
        "₀₁₂₃₄₅₆₇₈₉"
      let allowedSet : Std.HashSet UInt32 := Std.HashSet.insertMany Std.HashSet.emptyWithCapacity (List.map Char.val allowedStr.toList)
      c.isAlphanum || allowedSet.contains c.val

def indicatorVariableName (name : Name) : CoreM String := do
  let smtName ← match veil.smt.translator.get (← getOptions) with
  | .leanAuto => getLeanAutoNameFor name.toString
  | .leanSmt => pure name.toString
  return smtName

def getQueryForGoal : TacticM String := withMainContext do
  let idents ← getPropsInContext
  let stx := ( ← `(Veil.SMT.sauto| sauto [$[$idents:ident],*])).raw
  let mv ← Tactic.getMainGoal
  let translatorToUse := veil.smt.translator.get (← getOptions)
  let cmdString ←
    match translatorToUse with
    | .leanAuto => Veil.SMT.prepareLeanAutoQuery mv (← Veil.SMT.parseAutoHints ⟨stx[1]⟩)
    | .leanSmt =>
      let (_map, hs) ← Smt.Tactic.elabHints ⟨stx[1]⟩
      Veil.SMT.prepareLeanSmtQuery mv hs.toList
  return cmdString

def translateExprToSmt (expr: Expr) : TermElabM String := do
  let g ← mkFreshExprMVar expr
  let (cmdString, [_l]) ← Tactic.run g.mvarId! (do
    Veil.tryGoal $ Veil.run `(tactic|(unhygienic intros); fast_simplify_clause)
    for mvarId in (← Tactic.getGoals) do
      liftM <| mvarId.refl <|> mvarId.inferInstance <|> pure ()
    Tactic.pruneSolvedGoals
    let cmdString ← getQueryForGoal
    return cmdString
   ) | throwError "[translateExprToSmt] expected exactly one goal after simplification"
  return cmdString

def querySolverWithIndicators (goalQuery : String) (withTimeout : Nat) (checks: Array (Array (Name × Expr))) (forceSolver : Option SmtSolver := none)
  : MetaM (List ((List Name) × SmtResult)) := do
  withTraceNode `veil.smt.perf.query (fun _ => return "querySolverWithIndicators") do
  let opts ← getOptions
    let solverName :=
      match forceSolver with
      | some s => s
      | none => veil.smt.solver.get opts
    trace[veil.smt.debug] "solver: {solverName}"
  let solver ← Veil.SMT.createSolver solverName withTimeout
  Veil.SMT.emitCommandStr solver s!"{goalQuery}\n"
  let mut ret := []
  let indicatorNames := (checks.map (fun arr => arr.map (fun (_, ind) => ind.constName!))).flatten
  for check in checks do
    trace[veil.smt.debug] "Now running solver"
    let variablesInCheck := (check.map (fun (act, _) => act)).toList
    let indicatorsInCheck := check.map (fun (_, ind) => ind.constName!)
    let checkName := indicatorsInCheck.foldl (fun acc new => s!"{mkPrintableName new}_{acc}") "_checkSatIndicator_"
    let expression ← indicatorNames.foldlM (fun acc new => do
      if indicatorsInCheck.contains new then
        return s!"{← indicatorVariableName new} {acc}"
      else return s!"(not {← indicatorVariableName new}) {acc}") ""
    try
      Veil.SMT.emitCommandStr solver s!"(define-fun {checkName} () Bool (and {expression}))\n"
      Veil.SMT.emitCommandStr solver s!"(check-sat-assuming ({checkName}))\n"
      let stdout ← Handle.readLineSkip solver.stdout
      let (checkSatResponse, _) ← Auto.Solver.SMT.getSexp stdout
      let checkSatResponse: SmtResult := match checkSatResponse with
        | .atom (.symb "sat") => SmtResult.Sat none
        | .atom (.symb "unsat") => SmtResult.Unsat
        | .atom (.symb "unknown") => SmtResult.Unknown ""
        | e => SmtResult.Failure s!"{e}"
      trace[veil.smt.debug] "Test result: {checkSatResponse}"
      ret := ret ++ [((variablesInCheck, checkSatResponse))]
    catch e =>
      let exMsg ← e.toMessageData.toString
      let stderr ← solver.stderr.readToEnd
      let stderr := if stderr.isEmpty then "" else s!"{stderr.trim}"
      trace[veil.smt.debug] "exception: {exMsg} | stderr: {stderr}"
      ret := ret ++ [((variablesInCheck, .Failure s!"{stderr}"))]

  trace[veil.smt.debug] "Results for all actions and invariants: {ret}"
  solver.kill
  return ret

safety [single_leader] leader L → le N L

invariant [inv_1] pending S D ∧ btw S N D → le N S

invariant [inv_2] pending L L → le N L

#guard_msgs in
after_init {
  assume single_leader
  assume inv_1
  require inv_2
}

ghost relation isNext (n next : node) :=
  (n ≠ next) ∧ (∀ N', (N' ≠ n ∧ N' ≠ next) → ¬ btw n N' next)

#guard_msgs in
procedure foo = {
  assert inv_1
}

#guard_msgs in

action send (n next : node) = {
  require isNext n next
  pending n next := True
  assert inv_1
}

#gen_spec

action succ (n : seq_t) = {
  let k : seq_t ← fresh
  assume seq.next n k;
  return k
}

after_init {
  n_have_privilege N := N = init_node;
  n_requesting N := False;
  n_RN N M := seq.zero;
  let one : seq_t ← succ seq.zero;
  n_token_seq N := if N = init_node then one else seq.zero;

  reqs N M I := False;

  t_for I N := (seq.next seq.zero I) ∧ N = init_node;
  t_LN I N := seq.zero;
  t_q I N := False;

  crit N := False
}

action request (n : node) = {
  require ¬ n_requesting n;
  n_requesting n := True;
  if (¬ n_have_privilege n) then
    let k ← succ (n_RN n n)
    n_RN n n := k;
    reqs N n (n_RN n n) := N ≠ n
}


action rcv_request (n : node) (m : node) (r : seq_t) = {
  require reqs n m r;
  n_RN n m := if seq.le r (n_RN n m) then n_RN n m else r;
  if (n_have_privilege n ∧ ¬ n_requesting n ∧ seq.next (t_LN (n_token_seq n) m) (n_RN n m)) then
    n_have_privilege n := False;
    let k : seq_t ← succ (n_token_seq n)
    t_for k m := True;
    t_LN k N := t_LN (n_token_seq n) N;
    t_q k N := t_q (n_token_seq n) N
}

action rcv_privilege (n: node) (t: seq_t) = {
  require t_for t n;
  require seq.lt (n_token_seq n) t;
  n_have_privilege n := True;
  n_token_seq n := t
}

action enter (n : node) = {
    require n_have_privilege n
    require n_requesting n
    
    crit n := True
}

action exit (n : node) = {
  require crit n;
  crit n := False;
  n_requesting n := False;
  t_LN (n_token_seq n) n := n_RN n n;
  t_q (n_token_seq n) N := seq.next (t_LN (n_token_seq n) N) (n_RN n N);
  if m : (t_q (n_token_seq n) m) then
    t_q (n_token_seq n) m := False;
    n_have_privilege n := False;
    let k : seq_t ← succ (n_token_seq n)
    t_for k m := True;
    t_LN k N := t_LN (n_token_seq n) N;
    t_q k N := t_q (n_token_seq n) N
}

invariant [mutex] (crit N ∧ crit M) → N = M

invariant [single_privilege] (n_have_privilege N ∧ n_have_privilege M) → N = M

invariant [allowed_in_crit] (crit N) → (n_have_privilege N ∧ n_requesting N)

invariant [unique_tokens] ((t_for I N) ∧ (t_for I M)) → N = M

invariant [corresponding_tokens] ((n_token_seq N) ≠ seq.zero) → t_for (n_token_seq N) N

invariant [current_privilege_latest_token_1] ((n_have_privilege N) ∧ N ≠ M) → seq.lt (n_token_seq M) (n_token_seq N)

invariant [current_privilege_latest_token_2] ((n_have_privilege N) ∧ (t_for I M)) → seq.le I (n_token_seq N)

invariant [no_request_to_self] (reqs N M I) → N ≠ M

invariant [no_consecutive_privilege] ((t_for I N) ∧ (seq.next J I) ∧ (t_for J M)) → N ≠ M

invariant [token_relation] ((t_for I N) ∧ (t_for J M) ∧ seq.lt I J) → seq.le I (n_token_seq N)

#gen_spec

#time #check_invariants

action foo (k : Nat) =
  requires ∀ x, r x k
  ensures True
{
  let x <- fresh node
  
  require r x k
}

#guard_msgs(drop info) in

action foo2 (k : Nat) = {
  let mut y := 0
  y := k
  if y > 0 then
    return True
  else return False
}

action foo3 (k : Nat) = {
  let x <- fresh node
  n := x
  let mut y := f 0 = 7
  let mut z := r x k
  y := f 4 > 3
  if r x k then
    r x k := True
    y <- foo2 (f k)
  else
    y := f 1 < 5
  return y
}

def declareSpecName (n : Name) : CommandElabM Unit := do
  let ctx ← localSpecCtx.get
  let existingName := ctx.spec.name
  if existingName != Name.anonymous && existingName != n then
    throwError s!"Specification already named ({existingName}); cannot rename to {n}!"
  trace[veil.info] "declaring module {n}"
  localSpecCtx.modify (fun s => { s with spec.name := n })

def specName : CommandElabM Name := do
  let ctx ← localSpecCtx.get
  return ctx.spec.name

def declareSpecParameters (vd : Array (TSyntax `Lean.Parser.Term.bracketedBinder)) : CommandElabM Unit := do
  localSpecCtx.modify (fun s => { s with spec.parameters := vd })

def checkModuleExists (id : Name) [Monad m] [MonadEnv m] [MonadError m] : m Unit := do
  let modules := (<- globalSpecCtx.get)
  unless modules.contains id do
    throwError s!"Module {id} does not exist"

def checkCorrectInstantiation (id : Name) (ts : Array Term) [Monad m] [MonadEnv m] [MonadError m] : m Unit := do
  checkModuleExists id
  let module := (<- globalSpecCtx.get)[id]!.spec
  let vd := module.parameters
  let vs := ts
  if vd.size != vs.size then
    let vdStr := "\n".intercalate (Array.toList $ vd.map (fun x => s!"{x}"))
    throwError s!"Module {id} has {vd.size} parameters, but {vs.size} were provided\nrequired parameters: {vdStr}"

def ModuleDependency.stateArguments [Monad m] [MonadError m] (dep : ModuleDependency) : m (Array Term) := do
  getStateArguments dep.parameters dep.arguments

def ModuleDependency.typeMapping [Monad m] [MonadError m] [MonadQuotation m] (dep : ModuleDependency) : m (Array (Term × Term)) := do
  let paramTerms ← bracketedBindersToTerms dep.parameters
  let pairs := paramTerms.zip dep.arguments
  let mapping ← getStateArguments dep.parameters pairs
  return mapping

def errorIfStateNotDefined : CoreM Unit := do
  let stateName := (← localSpecCtx.get).stateBaseName
  if stateName.isNone then
     throwError "State has not been declared so far: run `#gen_state`"

def warnIfNoInvariantsDefined : CoreM Unit := do
  let invariants := (← localSpecCtx.get).spec.invariants
  if invariants.isEmpty then
    logWarning "you have not defined any invariants for this specification; did you forget?"

def warnIfNoActionsDefined : CoreM Unit := do
  let actions := (← localSpecCtx.get).spec.actions
  if actions.isEmpty then
    logWarning "you have not defined any actions for this specification; did you forget?"

def assembleNext : CommandElabM Unit := do
  let vd ← getActionParameters
  elabCommand $ ← Command.runTermElabM fun vs => do
    let stateTp ← getStateTpStx
    let sectionArgs ← getSectionArgumentsStx vs
    let (st, st') := (mkIdent `st, mkIdent `st')
    let trs ← (<- localSpecCtx.get).spec.actions.mapM (fun s => do
      let nm := mkIdent $ toTrName s.name
      `(@$nm $sectionArgs* $st $st'))
    
    let next ← if trs.isEmpty then `(fun ($st $st' : $stateTp) => $st = $st') else
              `(fun ($st $st' : $stateTp) => $(← repeatedOr trs))
    trace[veil.debug] "[assembleActions] {next}"
    `(@[actSimp] def $(mkIdent $ `Next) $[$vd]* := $next)
  trace[veil.info] "Next transition assembled"

def assembleLabelType (name : Name) : CommandElabM Unit := do
  let labelTypeName := mkIdent `Label
  elabCommand $ ← Command.runTermElabM fun _ => do
    let ctors ← (<- localSpecCtx.get).spec.actions.mapM (fun s => do
      let .some decl := s.actionDecl | throwError "[assembleLabelType] {s} is not an action"
      match decl.ctor with
      | none => throwError "DSL: missing label constructor for action {s.name}"
      | some ctor => pure ctor)
    trace[veil.info] "storing constructors for {name}"
    `(inductive $labelTypeName where $[$ctors]*)
  trace[veil.info] "Label {labelTypeName} type is defined"

def assembleActionMap : CommandElabM Unit := do
  elabCommand $ ← Command.runTermElabM fun vs => do
    let ioStx ← (← localSpecCtx.get).spec.actions.mapM fun s => do
      let .some decl := s.actionDecl | throwError "[assembleActionMap] {s} is not an action"
      let ioActName := toIOActionDeclName decl.label.name
      let act ← PrettyPrinter.delab $ ← mkAppOptM ioActName (vs.map Option.some)
      `(($(quote decl.label.name), $act))
    let actMapStx ← `(IOAutomata.ActionMap.ofList [$[$ioStx],*])
    let actMapStx ← `(def $(mkIdent `actionMap) := $actMapStx)
    trace[veil.info] "{actMapStx}"
    return actMapStx

def assembleInvariant : CommandElabM Unit := do
  let vd ← getAssertionParameters
  elabCommand $ <- Command.runTermElabM fun vs => do
    let stateTp <- getStateTpStx
    let allClauses := (<- localSpecCtx.get).spec.invariants
    let exprs := allClauses.toList.map (fun p => p.expr)
    let _ ← allClauses.mapM (fun t => do trace[veil.debug] s!"{t}")
    let invs ← if allClauses.isEmpty then `(fun _ => True) else PrettyPrinter.delab $ ← combineLemmas ``And exprs vs "invariants"
    `(@[invSimp, invSimpTopLevel] def $(mkIdent `Invariant) $[$vd]* : $stateTp -> Prop := $invs)
  trace[veil.info] "Invariant assembled"

def assembleSafeties : CommandElabM Unit := do
  let vd ← getAssertionParameters
  elabCommand $ <- Command.runTermElabM fun vs => do
    let stateTp <- getStateTpStx
    let exprs := (<- localSpecCtx.get).spec.invariants.toList.filterMap (fun p => if p.kind == .safety then p.expr else none)
    let safeties ← if exprs.isEmpty then `(fun _ => True) else PrettyPrinter.delab $ ← combineLemmas ``And exprs vs "invariants"
    `(@[invSimp, invSimpTopLevel] def $(mkIdent `Safety) $[$vd]* : $stateTp -> Prop := $safeties)
  trace[veil.info] "Safety assembled"

def assembleAssumptions : CommandElabM Unit := do
  let vd ← getAssertionParameters
  elabCommand $ <- Command.runTermElabM fun vs => do
    let stateTp <- getStateTpStx
    let exprs := (<- localSpecCtx.get).spec.assumptions.toList.map (fun p => p.expr)
    let assumptions ← if exprs.isEmpty then `(fun _ => True) else PrettyPrinter.delab $ ← combineLemmas ``And exprs vs "assumptions"
    `(@[invSimp, invSimpTopLevel] def $(mkIdent `Assumptions) $[$vd]* : $stateTp -> Prop := $assumptions)
  trace[veil.info] "Assumptions assembled"

action expire (d: deadline) = {
  expired d := True
}

safety [cancelled_after_deadline] cancelled N K V D → expired D

safety [paid_if_enough_sigs] paid N K V D → (∃ q, ∀ s, (member s q) → (sig N K V D s ∧ sig_auth s))

safety [paid] paid N K V D → proposed N K V D

invariant [ic3po_global2] collect V1 D1 V2 D2 → proposed V1 D1 V2 D2

invariant [ic3po_global3] sig V1 D1 V2 D2 S1 → sig_auth S1
#gen_spec

#time #check_invariants

action send (n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv (sender n next : node) = {
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

class SCP.Background (node : outParam Type) (nset : outParam Type) where
  well_behaved : node → Prop
  intertwined : node → Prop
  intact : node → Prop
  member : node → nset → Prop
  is_quorum : nset → Prop
  blocks_slices : nset → node → Prop

  axiom_0 : ∀ (n : node), intact n → intertwined n
  axiom_1 : ∀ (n : node), intertwined n → well_behaved n
  qi_intertwined : ∀ (q1 q2 : nset),
    (∃ (n1 : node), intertwined n1 ∧ is_quorum q1 ∧ member n1 q1) ∧
    (∃ (n2 : node), intertwined n2 ∧ is_quorum q2 ∧ member n2 q2) →
    ∃ (n3 : node), well_behaved n3 ∧ member n3 q1 ∧ member n3 q2

def one_such_Background (node : Type) [fba : FBA.System node]
    (I : Set node) (hI : FBA.intact (inst := fba) I)
    (S : Set node) (hS : FBA.intertwined (inst := fba) S)
    (hIS : I ⊆ S) : SCP.Background node (Set node) where
  well_behaved n := n ∈ fba.W
  intertwined n := n ∈ S
  intact n := n ∈ I
  member n s := n ∈ s
  is_quorum := FBA.quorum (inst := fba)
  blocks_slices := FBA.blocks_slices (inst := fba)

  axiom_0 := by admit /- proof elided -/

safety [intertwined_safe]
  ∀ (n1 n2 : node) (b1 b2 : ballot) (v1 v2 : value),
    intertwined n1 ∧ intertwined n2 ∧ confirmed_committed n1 b1 v1 ∧ confirmed_committed n2 b2 v2 → v1 = v2


invariant ∀ N B V, well_behaved N ∧ accepted_committed N B V → confirmed_prepared N B V

invariant ∀ N B1 B2 V1 V2, well_behaved N ∧ accepted_prepared N B2 V2 ∧ (lt B1 B2 ∧ V1 ≠ V2) → ¬ accepted_committed N B1 V1

invariant (∃ N, intertwined N ∧ confirmed_committed N B V) →
  ∃ Q, is_quorum Q ∧ (∃ N, intertwined N ∧ member N Q) ∧ (∀ N, well_behaved N ∧ member N Q → accepted_committed N B V)
invariant (∃ N, intertwined N ∧ confirmed_prepared N B V) →
  ∃ Q, is_quorum Q ∧ (∃ N, intertwined N ∧ member N Q) ∧ (∀ N, well_behaved N ∧ member N Q → accepted_prepared N B V)

invariant ∀ N N2 B V, well_behaved N ∧ received_accept_commit N N2 B V ∧ well_behaved N2 → accepted_committed N2 B V
invariant ∀ N N2 B V, well_behaved N ∧ received_accept_prepare N N2 B V ∧ well_behaved N2 → accepted_prepared N2 B V

invariant ∀ N B V1 V2, well_behaved N ∧ accepted_prepared N B V1 ∧ accepted_prepared N B V2 → V1 = V2

#gen_spec

#time #check_invariants

action empty = {
  pure ()
}

action call_empty = {
  empty
}

action call_f (z : node) = {
  f 5 z
}

#guard_msgs(drop warning) in

action foo (z : node)= {
  let _qq ← f 5 z;
  pure 42
}

action nested_call (n : node ) = {
  call_f n
}

macro "unfold_wp" : conv =>
  `(conv| unfold
    
    Wp.pure
    Wp.bind
    Wp.assume
    Wp.assert
    Wp.require
    Wp.fresh
    Wp.get
    
    set
    modify
    modifyGet
    get
    instMonadStateOfMonadStateOf
    getThe
    MonadStateOf.modifyGet
    MonadStateOf.get
    MonadStateOf.set
    instMonadStateOfWp
    
    Wp.spec
    
    Wp.toWlp
    Wp.toBigStep
    Wp.toTwoState
    BigStep.toWp
    Function.toWp
    
    monadLift
    getFrom
    setIn
    instMonadLiftTOfMonadLift
    MonadLift.monadLift
    instMonadLiftWpOfIsSubStateOf
    instMonadLiftT)

partial def getCapitals (s : Syntax) :=
  let rec loop  (acc : Array $ TSyntax `ident ) (s : Syntax) : Array $ TSyntax `ident :=
    if s.isIdent then
      if isCapital s then
        acc.push ⟨s⟩
      else
        acc
    else
      s.getArgs.foldl (init := acc) loop
  (loop #[] s).toList.eraseDups.toArray

def closeCapitals (s : Term) : MacroM Term :=
  let caps := getCapitals s
  `(forall $[$caps]*, $s)

def throwIfImmutable (lhs : TSyntax `Lean.Parser.Term.structInstLVal) : TermElabM Unit := do
  let spec := (← localSpecCtx.get).spec
  let nm ← getIdFrom lhs
  let .some comp := spec.getStateComponent nm
    | throwErrorAt lhs "trying to assign to undeclared state component {nm}"
  if comp.isImmutable then
    throwErrorAt lhs "{comp.kind} {comp.name} was declared immutable, but trying to assign to it!"
  where getIdFrom (lhs : TSyntax `Lean.Parser.Term.structInstLVal) : TermElabM Name :=
    match lhs with
    | `(Lean.Parser.Term.structInstLVal|$id:ident) => pure id.getId
    | _ => throwErrorAt lhs "expected an identifier in the LHS of an assignment, got {repr lhs}"

def getFields [Monad m] [MonadEnv m] : m (Array Name) := do
  let spec := (← localSpecCtx.get).spec
  pure $ spec.signature.map (·.name)

def getSubInitializers [Monad m] [MonadEnv m] [MonadError m] [MonadQuotation m]: m (Array (Ident × Term)) := do
  let mut names := #[]
  let ourSpec := (← localSpecCtx.get).spec
  for (modAlias, _) in ourSpec.dependencies do
    let initName := mkIdent <| modAlias ++ `initializer
    let initTerm <- `(@$initName $(← ourSpec.arguments)*)
    names := names.push (initName, initTerm)
  return names

def getSubProcedures : TermElabM (Array (Ident × Term)) := do
   
  let mut names := #[]
  let ourSpec := (← localSpecCtx.get).spec
  for (modAlias, dependency) in ourSpec.dependencies do
    let spec := (← globalSpecCtx.get)[dependency.name]!.spec
    for proc in spec.procedures do
      let procName := mkIdent <| modAlias ++ proc.name
      
      
      let procTerm <- `(@$procName $(← ourSpec.arguments)*)
      let currMod := (← localSpecCtx.get).stateBaseName.get!
      if (<- getEnv).find? (currMod ++ procName.getId) |>.isSome then
        names := names.push (procName, procTerm)
  pure names

elab "[State]" : term => do
    let stateTp := (← localSpecCtx.get).spec.stateStx
    elabTerm (<- `(term| $stateTp)) none

macro "funcases" t:term : term => `(term| by admit /- proof elided -/
)

macro "funcases" id:ident t:term : term => `(term| by admit /- proof elided -/
)

abbrev doSeq := TSyntax ``Term.doSeq

abbrev doSeqItem := TSyntax ``Term.doSeqItem

structure Vars where
  name : Ident
  type : Term

abbrev VeilM := StateT (Array Vars) TermElabM

def getStateDestructorPattern [Monad m] [MonadEnv m] [MonadQuotation m]: m (TSyntax `term) := do
  
  let fields ← (<- getFields).mapM (fun f => return ← `(term|$(mkIdent f)@_)) 
  `(term|⟨$fields:term,*⟩)

def getStateAccessorPattern [Monad m] [MonadEnv m] [MonadQuotation m]: m (TSyntax `term) := do
  let fields ← (<- getFields).mapM (fun f => return ← `(term|$(mkIdent f)))
  `(term|⟨$fields:term,*⟩)

partial def expandDoSeqVeil (stx : doSeq) : VeilM (Array doSeqItem) :=
  match stx with
  | `(doSeq| $doS:doSeqItem*) => return Array.flatten $ ← doS.mapM expandDoElemVeil
  | _ => throwErrorAt stx s!"unexpected syntax of Veil `do`-notation sequence {stx}"

partial def expandDoElemVeil (stx : doSeqItem) : VeilM (Array doSeqItem) := do
  trace[veil.debug] "[expand doElem] {stx}"
  match stx with
  
  | `(Term.doSeqItem| $stx ;) => expandDoElemVeil $ <- `(Term.doSeqItem| $stx:doElem)
  
  
  | `(Term.doSeqItem| return $t:term) | `(Term.doSeqItem| pure $t:term)
  | `(Term.doSeqItem| require $t) | `(Term.doSeqItem| assert $t) | `(Term.doSeqItem| assume $t) => return #[stx]
  
  | `(Term.doSeqItem|let $_ : $_ ← fresh $_) | `(Term.doSeqItem|let $_ : $_ ← fresh)
  | `(Term.doSeqItem|let $_ ← fresh $_) | `(Term.doSeqItem|let $_ ← fresh) => return #[stx]
  
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn:doSeqItem* else $els:doSeq) =>
    let fs <- `(Term.doSeqItem| let $h:ident <- fresh)
    let t' <- `(Term.doSeqItem| assume $t)
    let thn := fs :: t' :: thn.toList |>.toArray
    expandDoElemVeil $ <-
      `(Term.doSeqItem| if (∃ $h:ident, $t) then $thn* else $els)
  | `(Term.doSeqItem| if $t:term then $thn:doSeq) =>
    expandDoElemVeil $ <- `(Term.doSeqItem| if $t then $thn:doSeq else pure ())
  
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn) =>
    expandDoElemVeil $ <- `(Term.doSeqItem| if $h:ident : $t:term then $thn else pure ())
  | `(Term.doSeqItem| if $t:term then $thn:doSeq else $els:doSeq) =>
    let thn <- expandDoSeqVeil thn
    let els <- expandDoSeqVeil els
    let ret ← `(Term.doSeqItem| if $t then $thn* else $els*)
    return #[ret]
  
  | `(Term.doSeqItem| $id:ident := *) =>
    let typeStx ← (<- localSpecCtx.get) |>.spec.getStateComponentTypeStx (id.getId)
    let fr := mkIdent <| <- mkFreshUserName `fresh
    modify (·.push ⟨fr, typeStx.getD (<- `(_))⟩)
    expandDoElemVeil $ <- `(Term.doSeqItem|$id:ident := $fr)
  | `(Term.doSeqItem| $idts:term := *) =>
    let some (id, ts) := TSyntax.isApp? idts | throwErrorAt stx "wrong syntax for non-deterministic assignment {stx}"
    let typeStx ← (<- localSpecCtx.get) |>.spec.getStateComponentTypeStx (id.getId)
    let fr := mkIdent <| <- mkFreshUserName `fresh
    modify (·.push ⟨fr, typeStx.getD (<- `(_))⟩)
    expandDoElemVeil $ <- `(Term.doSeqItem|$idts:term := $fr:ident $ts*)
  
  | `(Term.doSeqItem| $id:ident := $t:term) =>
    trace[veil.debug] "[expand assignment with args] {stx}"
    let name := id.getId
    if name.isAtomic then
      let id' <- `(Term.structInstLVal| $id:ident)
      let fields <- getFields
      if id.getId ∈ fields then
        throwIfImmutable id'
        
        
        let res ← withRef stx `(Term.doSeqItem| $id:ident ← modifyGet
            (fun st => (($t, {st with $id:ident := $t}))))
        return #[res]
      else
        let res ← `(Term.doSeqItem| $id:ident := $t:term)
        return #[res]
    else
      let base := mkIdent name.getPrefix
      let suff := mkIdent $ name.updatePrefix default
      expandDoElemVeil $ <- withRef stx `(Term.doSeqItem| $base:ident := { $base with $suff:ident := $t })
  | `(Term.doSeqItem| $idts:term := $t:term) =>
    trace[veil.debug] "[expand assignment with args] {stx}"
    let some (id, ts) := TSyntax.isApp? idts | return #[stx]
    let stx' <- withRef t `(term| $id[ $[$ts],* ↦ $t:term ])
    let stx <- withRef stx `(Term.doSeqItem| $id:ident := $stx')
    expandDoElemVeil stx
   
  
  
  | `(Term.doSeqItem|$t:term) =>
    let b := mkIdent <| <- mkFreshUserName `_b
    let bind <- `(Term.doSeqItem| let $b:ident ← $t:term)
    return #[bind] ++ (← refreshState) ++ #[← `(Term.doSeqItem| pure $b:ident)]
  
  
  | doE =>
    trace[veil.debug] "[expand just a doElem] {stx}"
    return #[doE] ++ (← refreshState)
where
refreshState : VeilM (Array doSeqItem) := do
  let pattern ← getStateAccessorPattern
  let refresh ← `(Term.doSeqItem| $pattern:term := ← get)
  return #[refresh]

elab (name := VeilDo) "do'" mode:term "in" stx:doSeq : term => do
   
  let mut preludeAssn : Array doSeqItem := #[]
  let doS <- match stx with
  | `(doSeq| $doE*) => pure doE
  | `(doSeq| { $doE* }) => pure doE
  | _ => throwErrorAt stx "unexpected syntax of Veil `do`-notation sequence {stx}"
  let (doS, vars) <- (expandDoSeqVeil (<- `(doSeq| $doS*))).run #[]
  \n→\n{doS}"
  elabTerm (<- `(term| ((do $doS*) : Wp $mode [State] _))) none

def getPrePost (spec : doSeq) [Monad m] [MonadError m] [MonadQuotation m] :
  m (Term × TSyntax `rcasesPat × Term) := do
  match spec with
  | `(doSeq| requires $pre ensures $id, $post:term $_:unchanged_decl ?) => pure (pre, id, post)
  | `(doSeq| requires $pre ensures $post:term $_:unchanged_decl ?) => pure (pre, <- `(rcasesPat|(_ : Unit)), post)
  | _ => throwErrorAt spec "Invalid specification: expected `requires ... ensures ...`"

action foo = { pure () }

invariant True

#gen_spec

#guard_msgs in

action random_switch = {
  let s ← fresh switch_state
  state := s
}

invariant [all] state = on ∨ state = off

invariant [neq] on ≠ off

#gen_spec

action random_switch = {
  let s ← fresh one_elem
  state := s
}

invariant [all] state = a

#gen_spec

action f (n : Nat)  = {
  pure n
}

action foo (x : node) = {
  pure ()
}

action fresh_node (yy : node) = {
  let n <- fresh node
  nd := n
}


#guard_msgs(drop warning) in
#gen_spec

action g = {
  let n <- fresh node'
  test.r' N n := True
  r'' := test.r
  r'' := test'.r
  let _ <- test.f 1
  test'.f 1
}

invariant True

#gen_spec

safety [vote_integrity]
  ∀ (src dst : node) (r : round) (v : value),
     ¬ is_byz src ∧ ¬ is_byz dst ∧ voted dst src r v → (sent src r ∧ initial_value src r v)

#gen_spec

class TotalOrder (t : Type) where
  
  le (x y : t) : Prop
  
  le_refl       (x : t) : le x x
  le_trans  (x y z : t) : le x y → le y z → le x z
  le_antisymm (x y : t) : le x y → le y x → x = y
  le_total    (x y : t) : le x y ∨ le y x

class TotalOrderWithNone (t : Type) where
  
  le (x y : t) : Prop
  none : t
  
  le_refl       (x : t) : le x x
  le_trans  (x y z : t) : le x y → le y z → le x z
  le_antisymm (x y : t) : le x y → le y x → x = y
  le_total    (x y : t) : le x y ∨ le y x

class TotalOrderWithMinimum (t : Type) where
  
  le (x y : t) : Prop
  
  le_refl (x : t) : le x x
  le_trans (x y z : t) : le x y → le y z → le x z
  le_antisymm (x y : t) : le x y → le y x → x = y
  le_total (x y : t) : le x y ∨ le y x

  
  lt (x y : t) : Prop
  le_lt (x y : t) : lt x y ↔ (le x y ∧ x ≠ y)

  
  next (x y : t) : Prop
  next_def (x y : t) : next x y ↔ (lt x y ∧ ∀ z, lt x z → le y z)

  zero : t
  zero_lt (x : t) : le zero x

class TotalOrderWithZero (t : Type) where
  
  le (x y : t) : Prop

  
  zero : t
  zero_le (x : t) : le zero x

  
  le_refl       (x : t) : le x x
  le_trans  (x y z : t) : le x y → le y z → le x z
  le_antisymm (x y : t) : le x y → le y x → x = y
  le_total    (x y : t) : le x y ∨ le y x

class Queue (α : Type) (queue : outParam Type) where
  member (x : α) (q : queue) : Prop

  is_empty (q : queue) :=
    ∀ (e : α), ¬ member e q
  enqueue (x : α) (q q' : queue) :=
    ∀ (e : α), member e q' ↔ (member e q ∨ e = x)
  
  dequeue (x : α) (q q' : queue) :=
    ∀ (e : α), member e q' ↔ (member e q ∧ e ≠ x)

class Between (node : Type) where
  
  
  btw (x y z : node) : Prop
  
  btw_ring    (x y z : node) : btw x y z → btw y z x
  btw_trans (w x y z : node) : btw w x y → btw w y z → btw w x z
  btw_side    (w x y : node) : btw w x y → ¬ btw w y x
  btw_total   (w x y : node) : btw w x y ∨ btw w y x ∨ w = x ∨ w = y ∨ x = y

class Quorum (node : Type) (quorum : outParam Type) where
  
  member (a : node) (q : quorum) : Prop
  
  quorum_intersection :
    ∀ (q1 q2 : quorum), ∃ (a : node), member a q1 ∧ member a q2

class ByzQuorum (node : Type) (is_byz : outParam (node → Prop)) (nset : outParam Type) where
  member (a : node) (s : nset) : Prop
  supermajority (s : nset) : Prop       

  supermajorities_intersect_in_honest :
    ∀ (s1 s2 : nset), ∃ (a : node), member a s1 ∧ member a s2 ∧ ¬ is_byz a

class NodeSet (node : Type) (is_byz : outParam (node → Prop)) (nset : outParam Type) where
  member (a : node) (s : nset) : Prop
  is_empty (s : nset) : Prop

   
  greater_than_third (s : nset) : Prop
   
  supermajority (s : nset) : Prop

  supermajorities_intersect_in_honest :
    ∀ (s1 s2 : nset), ∃ (a : node), member a s1 ∧ member a s2 ∧ ¬ is_byz a
  greater_than_third_one_honest :
    ∀ (s : nset), greater_than_third s → ∃ (a : node), member a s ∧ ¬ is_byz a
  supermajority_greater_than_third :
    ∀ (s : nset), supermajority s → greater_than_third s
  greater_than_third_nonempty :
    ∀ (s : nset), greater_than_third s → ¬ is_empty s

def isElaboratedCorrectly (n : Name) : MetaM Bool :=
  return !Expr.hasSyntheticSorry (← Meta.reduceAll $ ← Meta.mkConstWithFreshMVarLevels n)

class ThreeValuedType (t : Type) where
  v0 : t
  v1 : t
  vquestion : t

  
  ax1 : v0 ≠ v1
  ax2 : v0 ≠ vquestion
  ax3 : v1 ≠ vquestion
  ax4 : ∀ (x : t), x = v0 ∨ x = v1 ∨ x = vquestion

class Rabia.Background (node set_majority set_f_plus_1 : outParam Type) where
  member_maj : node → set_majority → Prop
  member_fp1 : node → set_f_plus_1 → Prop

  ax0 : ∀ (Q1 Q2 : set_majority), ∃ (N : node), member_maj N Q1 ∧ member_maj N Q2
  ax1 : ∀ (Q1 : set_majority) (Q2 : set_f_plus_1), ∃ (N : node), member_maj N Q1 ∧ member_fp1 N Q2
veil module Rabia

action initial_proposal = {
  let n : node ← fresh
  let v : proposal_value ← fresh
  assume ¬ ∃ V : proposal_value, propose n V
  assume ∀ P, ¬ ∃ V : state_value, vote_rnd1 n P V
  assume ∀ P, ¬ ∃ V : state_value, vote_rnd2 n P V
  assume ∀ P, ¬ ∃ V : state_value, decision_bc n P V
  assume ∀ P, ¬ in_phase n P
  propose n v := True
}

action decide_bc_decide_full_val = {
  let n : node ← fresh
  let p : phase ← fresh
  let q : set_majority ← fresh
  assume decision_bc n p v1
  if v : (∀ (N : node), member_maj N q → propose N v) then
    decision_full_val n p v := True
}

action decide_bc_decide_full_noval = {
  let n : node ← fresh
  let p : phase ← fresh
  assume decision_bc n p v0
  decision_full_noval n p := True
}

action initial_vote1 = {
  let n : node ← fresh
  let q : set_majority ← fresh
  assume ∃ V : proposal_value, propose n V
  assume ∀ P, ¬ ∃ V : state_value, vote_rnd1 n P V
  assume ∀ P, ¬ ∃ V : state_value, vote_rnd2 n P V
  assume ∀ P, ¬ ∃ V : state_value, decision_bc n P V
  assume ∀ P, ¬ in_phase n P

  if v : (∀ (N : node), member_maj N q → propose N v) then
    vote_rnd1 n zero v1 := True
    in_phase n zero := True
  else
    vote_rnd1 n zero v0 := True
    in_phase n zero := True
}

action phase_rnd1 = {
  let n : node ← fresh
  let p : phase ← fresh
  let q : set_majority ← fresh
  assume in_phase n p
  assume ¬ ∃ V : state_value, vote_rnd2 n p V
  assume ∀ (N : node), member_maj N q → ∃ V, vote_rnd1 N p V

  if v : (∀ (N : node), member_maj N q → vote_rnd1 N p v) then
    vote_rnd2 n p v := True
  else
    vote_rnd2 n p vquestion := True
}

action phase_rnd2 = {
  let n : node ← fresh
  let p : phase ← fresh
  let psucc : phase ← fresh
  let q : set_majority ← fresh
  assume in_phase n p
  assume ∃ V : state_value, vote_rnd2 n p V
  assume ∀ (N : node), member_maj N q → ∃ V, vote_rnd2 N p V
  assume next p psucc

  if v : (v ≠ vquestion ∧
      (∃ N0 Q, member_fp1 N0 Q ∧ (∀ N, member_fp1 N Q → member_maj N q ∧ vote_rnd2 N p v)))
  then
    decision_bc n p v := True
    vote_rnd1 n psucc v := True
    in_phase n psucc := True
    in_phase n p := False
  else
    if v : (v ≠ vquestion ∧ (∃ N, member_maj N q ∧ vote_rnd2 N p v)) then
      vote_rnd1 n psucc v := True
      in_phase n psucc := True
      in_phase n p := False
    else
      if v : (v ≠ vquestion ∧ coin p v) then
        vote_rnd1 n psucc v := True
        in_phase n psucc := True
        in_phase n p := False
      else
        let v : state_value ← fresh
        assume v ≠ vquestion
        coin p v := True
        vote_rnd1 n psucc v := True
        in_phase n psucc := True
        in_phase n p := False
}


open_isolate protocol

invariant propose N V1 ∧ propose N V2 → V1 = V2

invariant [decision_full_val_inv] decision_full_val N P V → decision_bc N P v1
invariant decision_full_val N P V →
  ∃ Q : set_majority, ∀ N : node, member_maj N Q → propose N V

invariant [decision_full_val_validity] decision_full_val N P V → ∃ N0 : node, propose N0 V

invariant [decision_full_val_agree] decision_full_val N1 P1 V1 ∧ decision_full_val N2 P2 V2 → V1 = V2

invariant [decision_full_noval_inv] decision_full_noval N P → decision_bc N P v0

invariant in_phase N P1 ∧ in_phase N P2 → P1 = P2
invariant vote_rnd1 N P1 V ∧ in_phase N P2 → le P1 P2
invariant vote_rnd2 N P1 V ∧ in_phase N P2 → le P1 P2
invariant vote_rnd2 N P V2 → ∃ V1, vote_rnd1 N P V1
invariant in_phase N P1 → ∃ V1, vote_rnd1 N P1 V1
invariant in_phase N P1 ∧ le P1 P2 ∧ P1 ≠ P2 → ¬ ∃ V1, vote_rnd1 N P2 V1
invariant in_phase N P1 ∧ le P1 P2 ∧ P1 ≠ P2 → ¬ ∃ V1, vote_rnd2 N P2 V1

invariant vote_rnd1 N P V → V ≠ vquestion
invariant vote_rnd1 N P V1 ∧ vote_rnd1 N P V2 → V1 = V2
invariant vote_rnd2 N P V1 ∧ vote_rnd2 N P V2 → V1 = V2
invariant vote_rnd2 N1 P V1 ∧ vote_rnd2 N2 P V2 ∧ V1 ≠ vquestion ∧ V2 ≠ vquestion → V1 = V2
invariant vote_rnd2 N P V ∧ V ≠ vquestion →
  ∃ Q : set_majority, ∀ N : node, member_maj N Q → vote_rnd1 N P V
invariant decision_bc N P1 V ∧ in_phase N P2 → P1 ≠ P2 ∧ le P1 P2
invariant in_phase N P → ¬ ∃ V, decision_bc N P V
invariant decision_bc N1 P1 V1 → V1 ≠ vquestion
invariant decision_bc N P V → ∃ Q : set_f_plus_1, ∀ N : node, member_fp1 N Q → vote_rnd2 N P V

invariant ¬ coin P vquestion
invariant ¬ (coin P v0 ∧ coin P v1)


invariant ∀ Q, coin P V → ∃ N : node, member_fp1 N Q ∧ vote_rnd2 N P vquestion
invariant decision_bc N P V → ¬ coin P V2

invariant coin P V → ∃ Q : set_majority, ∀ N : node, member_maj N Q → ∃ V, vote_rnd2 N P V
invariant next P P2 ∧ vote_rnd1 N P2 V →
  ∃ Q : set_majority, ∀ N : node, member_maj N Q → ∃ V, vote_rnd2 N P V
invariant next P P2 ∧ vote_rnd1 N P2 V ∧ ¬ coin P v0 ∧ ¬ coin P v1 →
  ∃ (Q : set_majority) (N : node), member_maj N Q ∧ vote_rnd2 N P V

ghost relation state_value_locked (p : phase) (v : state_value) :=
  ∀ N Valt, vote_rnd1 N p Valt → Valt = v

ghost relation strong_state_value_locked (p : phase) (v : state_value) :=
  ∃ N : node, vote_rnd1 N p v ∧ (∀ N Valt, vote_rnd1 N p Valt → Valt = v)   

ghost relation members_voted_rnd2 (q : set_majority) (p : phase) :=
  ∀ N, member_maj N q → ∃ V, vote_rnd2 N p V

invariant [vote_rnd1_pred_rnd] vote_rnd1 N1 P2 V1 ∧ next P P2 → ∃ N2, vote_rnd1 N2 P V1

invariant decision_bc N1 P V1 ∧ next P P2 → state_value_locked P2 V1

invariant state_value_locked P V1 ∧ vote_rnd2 N P V2 → V1 = V2 ∨ V2 = vquestion

invariant coin P V →
  ∃ Q : set_majority, ∀ N : node, member_maj N Q → vote_rnd2 N P vquestion

invariant state_value_locked P V → ∀ Q : set_majority, members_voted_rnd2 Q P →
  ∃ N : node, member_maj N Q ∧ vote_rnd2 N P V
invariant state_value_locked P V → ∀ Q : set_majority, members_voted_rnd2 Q P → ¬ coin P V2
invariant state_value_locked P V ∧ next P P2 → state_value_locked P2 V

invariant decision_bc N1 P V1 ∧ next P P2 → ∀ Q : set_majority, members_voted_rnd2 Q P2 →
  ∃ N : node, member_maj N Q ∧ vote_rnd2 N P2 V1
invariant decision_bc N1 P V1 ∧ next P P2 → ¬ ∃ V, coin P2 V

invariant [vl_decision_bc_agree] state_value_locked P V ∧ decision_bc N2 P V2 → V = V2

invariant decision_bc N1 P V1 ∧ next P P2 ∧ decision_bc N2 P2 V2 → V1 = V2

invariant [decision_bc_same_round_agree] decision_bc N1 P V1 ∧ decision_bc N2 P V2 → V1 = V2

invariant (∃ N V, vote_rnd1 N P V) ∧ state_value_locked P V1 ∧ state_value_locked P V2 → V1 = V2

close_isolate

ghost relation started (p : phase) := ∃ N V, vote_rnd1 N p V

ghost relation good (p : phase) :=
  started p ∧
  (∀ P0, lt P0 p → started P0) ∧
  (∀ P0 V0, lt P0 p ∧ started P0 ∧
    ((∃ N, decision_bc N P0 V0) ∨ state_value_locked P0 V0) →
      state_value_locked p V0)

open_isolate wrapper1 with protocol

invariant [good_succ_good] good P ∧ next P P2 ∧ started P2 → good P2
close_isolate

open_isolate wrapper2 with wrapper1

invariant [good_zero] started zero → good zero
close_isolate

open_isolate wrapper3 with wrapper2

invariant [started_pred] started P2 ∧ next P P2 → started P
close_isolate

open_isolate wrapper4 with protocol

invariant [decision_bc_started] decision_bc N P V2 → started P
close_isolate

open_isolate wrapper5 with protocol

invariant [vote_rnd2_vote_rnd1] vote_rnd2 N P V ∧ V ≠ vquestion → ∃ N2, vote_rnd1 N2 P V

invariant [decision_bc_vote_rnd1] decision_bc N P V → ∃ N2, vote_rnd1 N2 P V
close_isolate

#gen_spec

action foo (k : Nat) =
  requires ∀ x, r x k
  ensures True
{
  let x <- fresh node
  require r x k
}

#guard_msgs(drop warning) in
procedure foobar (k : Nat) =
  requires ∀ x, r x k
  ensures True
{
  let x <- fresh node
  require r x k
}

action bar =
  requires True
  ensures True
{
  require n = n
}

abbrev SortName := Lean.Name

abbrev UninterpretedValue := Lean.Name

def _root_.String.toSanitizedName (s : String) : Lean.Name :=
  
  let badChars := #["✝", "⁰", "¹", "²", "³", "⁴", "⁵", "⁶", "⁷", "⁸", "⁹"]
  let goodChars := #["_", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]
  let mapping := badChars.zip goodChars
  let s' := mapping.foldl (init := s) fun s (f, r) => s.replace f r
  s'.toSubstring.toName

instance : Ord SortName where
  compare a b := a.cmp b

instance : Ord UninterpretedValue where
  compare a b := a.cmp b

instance [Ord α] : Ord (Array α) where
  compare a b :=
    a.zip b |>.foldl (init := Ordering.eq) fun c (a, b) => match c with
      | Ordering.eq => compare a b
      | c => c

instance [Ord α] [Ord β] : Ord (α × β) where
  compare x y := match x, y with
    | (a, b), (a', b') => compare a a' |>.then (compare b b')

structure FiniteUninterpretedSort where
  name : SortName
  size : Nat
   
  elements : Array UninterpretedValue
deriving BEq, Hashable, Inhabited, Ord

instance : ToString FiniteUninterpretedSort where
  toString s := s!"sort {s.name} = {s.elements}"

structure InterpretedSort where
  name : SortName
  
deriving BEq, Hashable, Inhabited, Ord

instance : ToString InterpretedSort where
  toString s := s!"interpreted sort {s.name}"

def boolSortI : InterpretedSort := { name := `Bool }

def intSortI : InterpretedSort := { name := `Int }

def builtinInterpretedSorts : Std.HashMap SortName InterpretedSort :=
  Std.HashMap.ofList [(`Bool, boolSortI), (`Int, intSortI)]

def InterpretedSort.interpretation (s : InterpretedSort) : Type :=
  match s.name with
  | `Bool => Bool
  | `Int => Int
  | _ => Unit

def InterpretedSort.valToString {s : InterpretedSort} (val : s.interpretation) : String :=

instance : BEq InterpretedSort where
  beq s₁ s₂ := s₁.name == s₂.name

instance : Hashable InterpretedSort where
  hash s := (`InterpretedSort ++ s.name).hash

inductive FirstOrderSort
  | Interpreted (s : InterpretedSort)
  | Uninterpreted (s : FiniteUninterpretedSort)
deriving BEq, Hashable, Inhabited, Ord

instance : ToString FirstOrderSort where
  toString
    | FirstOrderSort.Interpreted s => toString s
    | FirstOrderSort.Uninterpreted s => toString s

def FirstOrderSort.name : FirstOrderSort → SortName
  | FirstOrderSort.Interpreted s => s.name
  | FirstOrderSort.Uninterpreted s => s.name

def FirstOrderSort.size : FirstOrderSort → Nat
  | FirstOrderSort.Interpreted _ => 1
  | FirstOrderSort.Uninterpreted s => s.size

def FirstOrderSort.cardinalityConstraint (n : Nat) : FirstOrderSort → MetaM (Option Expr)
  | FirstOrderSort.Interpreted _ => return none
  | FirstOrderSort.Uninterpreted s => do
    
    
    let mut existentials := #[]
    let varN := mkIdent (Name.mkSimple s!"x_{s.name}")
    let mut disjs := #[]
    for i in [:n] do
      let varI := mkIdent (Name.mkSimple s!"card_{s.name}_{i}")
      let disj ← `(term|($varN = $varI))
      existentials := existentials.push (varI, .some s.name)
      disjs := disjs.push disj
    let body ← `(term|forall $varN, $(← repeatedOr disjs))
    let stx ← repeatedExists existentials body
    let (expr, _) ← TermElabM.run <| elabTerm stx .none
    return expr

inductive FirstOrderValue where
  | Interpreted (s : InterpretedSort) (val : s.interpretation)
  | Uninterpreted (s : FiniteUninterpretedSort) (val : UninterpretedValue)

instance : Ord FirstOrderValue where
  compare x y := match x, y with
    | .Uninterpreted s₁ v₁, .Uninterpreted s₂ v₂ =>
      match compare s₁ s₂ with
      | Ordering.eq => compare v₁ v₂
      | o => o
    | .Interpreted s₁ _v₁, .Interpreted s₂ _v₂ =>
      match compare s₁ s₂ with
      | Ordering.eq =>
        
        Ordering.eq
      | o => o
    | .Interpreted .., .Uninterpreted .. => Ordering.lt
    | .Uninterpreted .., .Interpreted .. => Ordering.gt

def FirstOrderValue.isBoolean (val : FirstOrderValue) : Bool :=
  match val with
  | FirstOrderValue.Interpreted { name := `Bool } _ => true
  | _ => false

def FirstOrderValue.isTrue (val : FirstOrderValue) : Bool :=
  match val with
  | FirstOrderValue.Interpreted { name := `Bool } b => b
  | _ => false

instance : ToString FirstOrderValue where
  toString
    | FirstOrderValue.Interpreted s val => s.valToString val
    | FirstOrderValue.Uninterpreted _ val => toString val

def Array.funcArgsString (vals : Array FirstOrderValue) : String :=
  "(" ++ (String.intercalate ", " (vals.map toString).toList) ++ ")"

def boolSort : FirstOrderSort := FirstOrderSort.Interpreted boolSortI

def intSort : FirstOrderSort := FirstOrderSort.Interpreted intSortI

structure ConstantDecl where
  name : SortName
  sort : FirstOrderSort
deriving BEq, Hashable, Ord

instance : ToString ConstantDecl where
  toString c := s!"constant {c.name} : {c.sort}"

structure RelationDecl where
  name : SortName
  domain : Array FirstOrderSort
deriving BEq, Hashable, Ord

instance : ToString RelationDecl where
  toString r := s!"relation {r.name} : {r.domain}"

structure FunctionDecl where
  name : SortName
  domain : Array FirstOrderSort
  range : FirstOrderSort
deriving BEq, Hashable, Ord

instance : ToString FunctionDecl where
  toString f := s!"function {f.name} : {f.domain} → {f.range}"

inductive Declaration where
  | Constant (c : ConstantDecl)
  | Relation (r : RelationDecl)
  | Function (f : FunctionDecl)
deriving BEq, Hashable, Ord

instance : ToString Declaration where
  toString
    | Declaration.Constant c => toString c
    | Declaration.Relation r => toString r
    | Declaration.Function f => toString f

def Declaration.name : Declaration → SortName
  | Declaration.Constant c => c.name
  | Declaration.Relation r => r.name
  | Declaration.Function f => f.name

def Declaration.arity : Declaration → Nat
  | Declaration.Constant _ => 0
  | Declaration.Relation r => r.domain.size
  | Declaration.Function f => f.domain.size

def Declaration.domain : Declaration → Array FirstOrderSort
  | Declaration.Constant _ => #[]
  | Declaration.Relation r => r.domain
  | Declaration.Function f => f.domain

def Declaration.range : Declaration → FirstOrderSort
  | Declaration.Constant c => c.sort
  | Declaration.Relation _ => boolSort
  | Declaration.Function f => f.range

instance (priority := high) : Ord Declaration where
  compare x y := compare x.name y.name |>.then (compare x y)

def Declaration.cardinalityConstraint (decl : Declaration) (n : Nat) :  Lean.MetaM (Option Lean.Expr) :=
  match decl with
  | Declaration.Constant _ => return none
  | Declaration.Function _ => return none
  | Declaration.Relation _ => do
    
    
    
    
    
    
    
    
    let mut existentials : Array (Lean.Ident × Option SortName) := #[]
    
    let mut relInstances : Array (Array Lean.Ident) := #[]
    
    let mut universals : Array (Lean.Ident × Option SortName) := #[]
    
    for j in [0 : decl.arity] do
      let sortName := (decl.domain[j]!).name
      let varJ := Lean.mkIdent (Lean.Name.mkSimple s!"x_{decl.name}_{j}")
      
      
      if sortName == `Int then
        universals := universals.push (varJ, none)
      else
        universals := universals.push (varJ, sortName)
    
    for i in [0 : n] do
      let mut relInstanceArgs := #[]
      for j in [0 : decl.arity] do
        let sortName := (decl.domain[j]!).name
        let varI := Lean.mkIdent (Lean.Name.mkSimple s!"card_{decl.name}_{i}_{j}")
        
        
        if sortName == `Int then
          existentials := existentials.push (varI, none)
        else
          existentials := existentials.push (varI, sortName)
        relInstanceArgs := relInstanceArgs.push varI
      relInstances := relInstances.push relInstanceArgs
    let universalVars := universals.map Prod.fst
    
    let mut disjs := #[]
    for i in [0 : n] do
      let mut eqs := #[]
      for (x, c) in Array.zip universalVars relInstances[i]! do
        eqs := eqs.push <| ← `(term|($x = $c))
      disjs := disjs.push <| ← `(term|$(← repeatedAnd eqs))
    let disj ← repeatedOr disjs
    let relApp ← `(term|$(Lean.mkIdent decl.name) $universalVars*)
    let forallBody ← `(term|($relApp → $disj))
    let existsBody ← repeatedForall universals forallBody
    let stx ← repeatedExists existentials existsBody
    let (expr, _) ← Lean.Elab.Term.TermElabM.run <| Lean.Elab.Term.elabTerm stx .none
    
    return (some expr)

structure Signature where
  constants : Array ConstantDecl
  relations : Array RelationDecl
  functions : Array FunctionDecl
deriving BEq, Hashable, Ord

instance : Inhabited Signature := ⟨{ constants := #[], relations := #[], functions := #[] }⟩

def Signature.declarations (sig : Signature) : Array Declaration :=
  sig.constants.map Declaration.Constant ++
  sig.relations.map Declaration.Relation ++
  sig.functions.map Declaration.Function

abbrev InputOutputPair := (Array FirstOrderValue) × FirstOrderValue

inductive Interpretation
  | Enumeration (iopairs : Array InputOutputPair)
  | Symbolic    (expr : String)
deriving Ord, Inhabited

def Interpretation.isAlwaysFalse (interp : Interpretation) : Bool := Id.run do
  match interp with
  | .Enumeration iopairs =>
    for (_args, val) in iopairs do
      if !val.isBoolean then return false 
      if val.isTrue then return false     
    return true 
  | .Symbolic _ => return false

def Declaration.alwaysFalseMessage (decl : Declaration) : String :=
  match decl with
  | Declaration.Constant c => s!"{c.name} = false"
  | Declaration.Relation r => s!"{r.name} = ∅"
  | Declaration.Function f => s!"{f.name} = λ _ → false"

def Interpretation.toString (interp : Interpretation) (decl : Declaration) : Id String := do
  let mut out := ""
  match interp with
  | .Enumeration iopairs =>
    if interp.isAlwaysFalse then
      return s!"{decl.alwaysFalseMessage}\n"
    for (args, val) in iopairs.qsortOrd do
      match decl with
      | Declaration.Constant c => out := out ++ s!"{c.name} = {val}\n"
      | Declaration.Relation r =>
          \n"
          if val.isTrue then out := out ++ s!"{r.name}{Array.funcArgsString args} = true\n"
      | Declaration.Function f => out := out ++ s!"{f.name}{Array.funcArgsString args} = {val}\n"
  | .Symbolic str => out := out ++ s!"{decl.name} = {str}\n"
  return out

def Interpretation.push (i : Interpretation) (iop : InputOutputPair) : Interpretation :=
  match i with
  | Interpretation.Enumeration iopairs => Interpretation.Enumeration (iopairs.push iop)
  | _ => panic! s!"tried to push an input-output pair to symbolic interpretation"

abbrev ExplicitInterpretation := Std.HashMap Declaration Interpretation

instance : Ord ExplicitInterpretation where
  compare x y := compare x.toArray y.toArray

structure FirstOrderStructure where
  isMinimized : Bool

   
  domains : Array FirstOrderSort
  signature : Signature
  interp : ExplicitInterpretation
deriving Ord

def FirstOrderStructure.mkString (s : FirstOrderStructure) (printWhetherMinimized : Bool := false) : String :=
  Id.run (do
    let mut out := s!"\n"
    if printWhetherMinimized then
      let minimized := if s.isMinimized then "(this model is minimized)" else "(this model is not minimized)"
      out := out ++ s!"{minimized}\n"
    for dom in s.domains do
      out := out ++ s!"{dom}\n"
    for (decl, interp) in s.interp.toArray.qsortOrd do
      out := out ++ (← interp.toString decl)
    return out)

instance : ToString FirstOrderStructure where
  toString s := s.mkString (printWhetherMinimized := true)

def FirstOrderStructure.findSort (s : FirstOrderStructure) (name : Lean.Name) : MetaM FirstOrderSort :=
  match s.domains.find? (fun s => s.name == name) with
  | some sort => return sort
  | none => throwError s!"sort {name} used but not previously declared!"

def FirstOrderStructure.findDecl (s : FirstOrderStructure) (name : Lean.Name) : MetaM Declaration :=
  match s.signature.constants.find? (fun c => c.name == name) with
  | some c => return Declaration.Constant c
  | none => match s.signature.relations.find? (fun r => r.name == name) with
    | some r => return Declaration.Relation r
    | none => match s.signature.functions.find? (fun f => f.name == name) with
      | some f => return Declaration.Function f
      | none => throwError s!"{name} provided an interpretation for, but not previously declared!"

def FirstOrderStructure.isInterpretedByFiniteEnumeration (s : FirstOrderStructure) (decl : Declaration) : Bool :=
  match s.interp.get? decl with
  | some (Interpretation.Enumeration _) => true
  | _ => false

def FirstOrderStructure.numTrueInstances (s : FirstOrderStructure) (decl : Declaration) : MetaM Nat := do
  match s.interp.get? decl with
  | none => return 0
  | some (.Enumeration iopairs) =>
      return iopairs.foldl (init := 0) fun c (_, res) => if res.isTrue then c + 1 else c
  | _ => throwError s!"cannot call `FirstOrderStructure.numTrueInstances` on a symbolic interpretation!"

instance : Inhabited FirstOrderStructure := ⟨{ isMinimized := false, domains := #[], signature := default, interp := default }⟩

abbrev Sexpr := Auto.Parser.SMTSexp.Sexp

deriving instance Repr for LexVal
deriving instance Repr for Auto.Parser.SMTSexp.Sexp

def ModelGenerationTimeoutMsg : String := s!"z3 timeout: could not generate a model (query timed out)"

partial def extractInstructions (e : Sexpr) (depth : Int := 0): MetaM (List Sexpr) := do
  match e with
  | .atom (.symb "timeout") => throwError ModelGenerationTimeoutMsg
  | .atom _ => throwError s!"malformed model: unexpected atom at depth {depth} in {e} ({repr e})"
  | .app xs =>
      let mut instructions : List Sexpr:= if depth == 1 then [e] else []
      if depth == 0 then
        for x in xs do
          instructions := instructions ++ (← extractInstructions x (depth + 1))
      return instructions

def findSortWithName (name : Lean.Name) (struct : FirstOrderStructure) : MetaM FirstOrderSort :=
  match struct.domains.find? (fun s => s.name == name) with
  | some sort => return sort
  | none => throwError s!"sort {name} used but not previously declared!"

def findSortsArray (names : Array Sexp) (struct : FirstOrderStructure) : MetaM (Array FirstOrderSort) := do
  let mut sorts : Array FirstOrderSort := #[]
  for dom in names do
    match dom with
    | .atom (.symb domName) => sorts := sorts.push (← findSortWithName domName.toSanitizedName struct)
    | _ => throwError s!"malformed domain: {dom}"
  return sorts

def getValueOfSort (val : Sexp) (sort : FirstOrderSort) : MetaM FirstOrderValue := do
  match sort with
  | FirstOrderSort.Interpreted s => do
    match s.name with
    | `Bool => match val with
      | .atom (.symb "true") => return FirstOrderValue.Interpreted boolSortI true
      | .atom (.symb "false") => return FirstOrderValue.Interpreted boolSortI false
      | _ => throwError s!"expected a boolean value, but got {val}"
    | `Int => match val with
      | .atom (.nat n) => return FirstOrderValue.Interpreted intSortI (Int.ofNat n)
      | .atom (.symb i) => return FirstOrderValue.Interpreted intSortI i.toInt!
      | _ => throwError s!"expected an integer value, but got {val}"
    | _ => throwError s!"unsupported interpreted sort: {s}"
  | FirstOrderSort.Uninterpreted s => do
    match val with
    | .atom (.symb valName) => return FirstOrderValue.Uninterpreted s valName.toSanitizedName
    | _ => throwError s!"expected an uninterpreted value, but got {val}"

def getValueArray (vals : Array Sexp) (sorts : Array FirstOrderSort) : MetaM (Array FirstOrderValue) := do
  let mut values : Array FirstOrderValue := #[]
  for (val, sort) in Array.zip vals sorts do
    values := values.push (← getValueOfSort val sort)
  return values

def parseInstruction (inst : Sexpr) (struct : FirstOrderStructure): MetaM (FirstOrderStructure) := do
  let mut struct := struct
  match inst with
  
  | .app #[(.atom (.symb "minimized")), (.atom (.symb "true"))] => do
    struct := { struct with isMinimized := true }
  | .app #[(.atom (.symb "minimized")), (.atom (.symb "false"))] => do
    struct := { struct with isMinimized := false }
  
  
  | .app #[(.atom (.symb "sort")), (.atom (.symb sortName)), (.app els)] => do
    let sortName := sortName.toSanitizedName
    let sort: FirstOrderSort ← (match builtinInterpretedSorts.get? sortName with
    | some sortI => return .Interpreted sortI
    | none => do
      let mut elems : Array UninterpretedValue := #[]
      for elem in els do
        match elem with
        | .atom (.symb elemName) => elems := elems.push elemName.toSanitizedName
        | _ => throwError s!"malformed element: {elem}"
      return .Uninterpreted { name := sortName, size := elems.size, elements := elems }
    )
    trace[veil.smt.debug] s!"{sort}"
    struct := { struct with domains := struct.domains.push sort }

  
  | .app #[(.atom (.symb "constant")), (.atom (.symb constName)), (.atom (.symb sortName))] => do
    let constName := constName.toSanitizedName
    let sortName := sortName.toSanitizedName
    let sort ← findSortWithName sortName struct
    let decl: ConstantDecl := { name := constName, sort := sort }
    trace[veil.smt.debug] s!"{decl}"
    struct := { struct with signature := { struct.signature with constants := struct.signature.constants.push decl } }

  
  | .app #[(.atom (.symb "relation")), (.atom (.symb relName)), (.app doms)] => do
    let relName := relName.toSanitizedName
    let doms ← findSortsArray doms struct
    let decl: RelationDecl := { name := relName, domain := doms }
    trace[veil.smt.debug] s!"{decl}"
    struct := { struct with signature := { struct.signature with relations := struct.signature.relations.push decl } }

  
  | .app #[(.atom (.symb "function")), (.atom (.symb funName)), (.app doms), (.atom (.symb range))] => do
    let funName := funName.toSanitizedName
    let doms ← findSortsArray doms struct
    let range ← findSortWithName range.toSanitizedName struct
    let decl: FunctionDecl := { name := funName, domain := doms, range := range }
    trace[veil.smt.debug] s!"{decl}"
    struct := { struct with signature := { struct.signature with functions := struct.signature.functions.push decl } }

  
  
  
  | .app #[(.atom (.symb "interpret")), (.atom (.symb declName)), (.app args), val] => do
    let declName := declName.toSanitizedName
    let decl ← struct.findDecl declName
    let args ← getValueArray args decl.domain
    let val ← getValueOfSort val decl.range
    trace[veil.smt.debug] s!"interpret {declName} {args} {val}"
    let interp := struct.interp.getD decl (Interpretation.Enumeration #[])
    let interp' := interp.push (args, val)
    struct := { struct with interp := struct.interp.insert decl interp' }

  
  | .app #[(.atom (.symb "symbolic")), (.atom (.symb declName)), (.atom (.symb interp))] => do
    let declName := declName.toSanitizedName
    let decl ← struct.findDecl declName
    trace[veil.smt.debug] s!"symbolic {declName} {interp}"
    let interp := struct.interp.getD decl (Interpretation.Symbolic interp)
    struct := { struct with interp := struct.interp.insert decl interp }

  | _ => throwError s!"(parseInstruction) malformed instruction: {inst} ({repr inst})"
  return struct

def extractStructure (model : Sexpr) : MetaM FirstOrderStructure := do
  let mut struct : FirstOrderStructure := default
  let instructions ← extractInstructions model
  trace[veil.smt.debug] "instructions: {instructions}"
  for inst in instructions do
    struct := (← parseInstruction inst struct)
  return struct

safety [mutex] ¬ (has_lock X ∧ has_lock Y ∧ X ≠ Y)

invariant [manual_1] ¬ (X ≠ Y ∧ (has_lock X ∨ (msg X T ∧ ¬ le T (epoch X))) ∧ (has_lock Y ∨ (msg Y S ∧ ¬ le S (epoch Y))))

invariant [manual_2] ¬ (has_lock X ∧ (msg X T ∧ ¬ le T (epoch X)))

invariant [manual_3] ¬ (S ≠ T ∧ msg Y S ∧ msg Y T ∧ ¬ le T (epoch Y) ∧ ¬ le S (epoch Y))

#gen_spec

#time #check_invariants

action send = {
  let n : node ← fresh
  let next : node ← fresh
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  pending n next := True
}

action recv = {
  let sender : node ← fresh
  let n : node ← fresh
  let next : node ← fresh
  require ∀ Z, n ≠ next ∧ ((Z ≠ n ∧ Z ≠ next) → btw n next Z)
  require pending sender n
  
  
  pending sender n := *
  if (sender = n) then
    leader n := True
  else
    
    if (le n sender) then
      pending sender next := True
}

safety [single_leader] leader L → le N L
invariant pending S D ∧ btw S N D → le N S
invariant pending L L → le N L

#gen_spec

#guard_msgs(drop info, drop warning) in
#check_invariants

#recover_invariants_in_tr

prove_inv_inductive by admit /- proof elided -/

#split_invariants

Lake.download in Lake.Build.Actions

System.Platform.target in Init.System.Platform

System.Platform.isOSX in Init.System.Platform

System.Platform.isWindows in Init.System.Platform

ToString in Init.Data.ToString.Basic

String in Init.Prelude

Lake.LogIO in Lake.Util.Log

PUnit in Init.Prelude

System.FilePath in Init.System.FilePath

IO in Init.System.IO

IO.FS.createDirAll in Init.System.IO

Lake.proc in Lake.Util.Proc

args in Auto.Parser.TPTP

cmd in Auto.Parser.TPTP

q in Smt.Reconstruct.Certified.ModusPonens

Lake.JobM in Lake.Build.Job.Monad

Lake.Package in Lake.Config.Package

IO.FS.removeFile in Init.System.IO

Lake.env in Lake.CLI.Actions

Lake.logError in Lake.Util.Log

Lake.logInfo in Lake.Util.Log

IO.FS.removeDirAll in Init.System.IO

Array in Init.Prelude

Lake.Job.collectArray in Lake.Build.Job.Monad

Lake.buildFileAfterDep in Lake.Build.Common

Lake.inputTextFile in Lake.Build.Common

node in Test.SmtTranslation.Inductive

L in Archive.Hairer

foo in Test.EqnDef.Extract

Nat in Init.Prelude

m in Test.Playground.WHNFExamples

error in Auto.Parser.TPTP

r in Test.Playground.WHNFExamples

round in Mathlib.Algebra.Order.Round

f in Test.SmtTranslation.Trigger

Bool in Init.Prelude

Lean.Name in Init.Prelude

Lean.Expr.hasSyntheticSorry in Lean.Util.Sorry

Lean.Meta.mkConstWithFreshMVarLevels in Lean.Meta.Basic

Lean.Meta.reduceAll in Lean.Meta.Reduce

Int in Init.Data.Int.Basic

BEq in Init.Prelude

Inhabited in Init.Prelude

p in Smt.Reconstruct.Certified.ModusPonens

Lean.KVMap in Lean.Data.KVMap

Lean.KVMap.Value in Lean.Data.KVMap

query in Test.Solver.Error

le in Test.SmtTranslation.Names

outParam in Init.Prelude

member in Test.SmtTranslation.Names

quorum_intersection in Test.SmtTranslation.Names

Ring in Mathlib.Algebra.Ring.Defs

type in Auto.Lib.Rebind

t in Test.Unit.Normalize

Nat.le in Init.Prelude

Nat.lt in Init.Prelude

Set in Mathlib.Data.Set.Defs

And in Init.Prelude

DecidableEq in Init.Prelude

Nonempty in Init.Prelude

Iff in Init.Core

Unit in Init.Prelude

Lean.logError in Lean.Log

Lean.FVarId in Lean.Expr

Lean.Expr in Lean.Expr

Lean.Meta.Location in Smt.Tactic.Concretize

List in Init.Prelude

Lean.Meta.inferType in Lean.Meta.Basic

Lean.instantiateMVars in Lean.MetavarContext

Lean.mkFVar in Lean.Expr

Option in Init.Prelude

cond in Init.Prelude

Lean.Meta.SplitIf.mkDischarge? in Lean.Meta.Tactic.SplitIf

Lean.mkConst in Lean.Expr

Lean.Meta.Simp.SimprocsArray in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.SplitIf.getSimpContext in Lean.Meta.Tactic.SplitIf

reduceCtorEq in Lean.Meta.Tactic.Simp.BuiltinSimprocs.Core

Lean.Elab.Term.exprToSyntax in Lean.Elab.Term.TermElabM

Lean.mkIdent in Init.Meta.Defs

ident in Test.Examples.Demo

IO.Ref in Init.System.IO

Lean.Meta.MetaM in Lean.Meta.Basic

Lean.TSyntax in Init.Prelude

Lean.binderIdent in Init.Notation

Lean.getLocalHyps in Lean.LocalContext

Lean.mkApp in Lean.Expr

Not in Init.Prelude

Lean.Meta.throwTacticEx in Lean.Meta.Tactic.Util

Lean.LocalDecl in Lean.LocalContext

Array.filter in Init.Data.Array.Basic

Lean.PersistentArray.map in Lean.Data.PersistentArray

Lean.PersistentArray.toArray in Lean.Data.PersistentArray

Lean.isStructure in Lean.Structure

Lean.trace in Lean.Util.Trace

Option.get! in Init.Data.Option.BasicAux

Option.isSome in Init.Data.Option.Basic

Exists in Init.Core

Lean.Parser.Tactic.tacticSeq in Lean.Parser.Term.Basic

Lean.Syntax in Init.Prelude

Lean.withTraceNode in Lean.Util.Trace

Lean.ConstantInfo in Lean.Declaration

Lean.isReducible in Lean.ReducibilityAttrs

Lean.ConstantInfo.defnInfo in Lean.Declaration

Lean.ConstantInfo.thmInfo in Lean.Declaration

Lean.throwUnknownConstant in Lean.Exception

Lean.LOption in Lean.Data.LOption

Lean.isClass in Lean.Class

Lean.getExprMVarAssignment? in Lean.MetavarContext

sort in Auto.Parser.TPTP

Lean.LocalContext in Lean.LocalContext

Lean.mkFreshFVarId in Lean.Expr

Lean.throwError in Lean.Exception

StateT in Init.Control.State

IO.RealWorld in Init.System.IO

Lean.MonadCacheT in Lean.Util.MonadCache

Lean.checkCache in Lean.Util.MonadCache

MonadLiftT in Init.Prelude

ST in Init.System.ST

STWorld in Init.System.ST

liftM in Init.Prelude

Char in Init.Prelude

Char.val in Init.Prelude

List.map in Init.Prelude

Std.HashSet in Std.Data.HashSet.Basic

Std.HashSet.emptyWithCapacity in Std.Data.HashSet.Basic

Std.HashSet.insertMany in Std.Data.HashSet.Basic

UInt32 in Init.Prelude

Smt.Tactic.elabHints in Smt.Tactic.Smt

atom in Smt.Data.Sexp

Lean.Core.Context in Lean.CoreM

Lean.mkStrLit in Lean.Expr

System.FilePath.mk in Init.System.FilePath

readThe in Init.Prelude

Lean.Unhygienic.run in Lean.Hygiene

Lean.withRef in Init.Prelude

Lean.Parser.Term.bracketedBinder in Lean.Parser.Term.Basic

Lean.TSyntaxArray in Init.Prelude

Lean.explicitBinders in Init.NotationExtra

Lean.bracketedExplicitBinders in Init.NotationExtra

term in Auto.Parser.TPTP

Lean.MonadError in Lean.Exception

Lean.MonadQuotation in Init.Prelude

Monad in Init.Prelude

id in Init.Prelude

Lean.Parser.Term.funBinder in Lean.Parser.Term

Lean.MonadEnv in Lean.Environment

Lean.Parser.Command.structSimpleBinder in Lean.Parser.Command

Or in Init.Prelude

Lean.mkOr in Lean.Expr

Lean.ReducibilityHints in Lean.Declaration

Lean.ReducibilityHints.regular in Lean.Declaration

Lean.Declaration.defnDecl in Lean.Declaration

Lean.DefinitionSafety.safe in Lean.Declaration

Lean.Elab.Term.applyAttributes in Lean.Elab.Term.TermElabM

Lean.addDecl in Lean.AddDecl

Lean.enableRealizationsForConst in Lean.CoreM

Lean.mkDefinitionValEx in Lean.Declaration

Lean.Meta.mkLambdaFVars in Lean.Meta.Basic

Lean.Expr.lam in Lean.Expr

Lean.mkAppN in Lean.Expr

Lean.Parser.Term.doSeq in Lean.Parser.Do

Lean.Parser.Term.doSeqItem in Lean.Parser.Do

Lean.Elab.Tactic.Context in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.State in Lean.Elab.Term.TermElabM

Prod in Init.Prelude

Prod.fst in Init.Prelude

Lean.MVarId in Lean.Expr

modify in Init.Prelude

Lean.Meta.Simp.defaultMaxSteps in Init.MetaTypes

Lean.Meta.Simp.Result in Lean.Meta.Tactic.Simp.Types

Lean.Meta.mkFreshExprMVar in Lean.Meta.Basic

Lean.Meta.mkSimpContext in Mathlib.Tactic.Simps.Basic

Lean.Meta.whnf in Lean.Meta.Basic

Lean.Elab.Tactic.TacticM in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.evalTactic in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.withMainContext in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.getUnsolvedGoals in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.setGoals in Lean.Elab.Tactic.Basic

Lean.Meta.isProp in Lean.Meta.InferType

Lean.getStructureInfo? in Lean.Structure

Lean.StructureInfo in Lean.Structure

Lean.Parser.Tactic.simpLemma in Init.Tactics

Lean.Syntax.ident in Init.Prelude

Lean.Syntax.node in Init.Prelude

Lean.mkNode in Init.Prelude

Lean.nullKind in Init.Prelude

Lean.Syntax.TSepArray in Init.Prelude

Lean.Syntax.TSepArray.ofElems in Init.Meta.Defs

Lean.Parser.Term.explicitBinder in Lean.Parser.Term.Basic

Lean.Parser.Term.implicitBinder in Lean.Parser.Term.Basic

Lean.Parser.Term.bracketedBinderF in Lean.Parser.Term

Lean.PrettyPrinter.delab in Lean.PrettyPrinter.Delaborator.Basic

Lean.extractMacroScopes in Init.Prelude

Lean.ToMessageData in Lean.Message

Prod.snd in Init.Prelude

Lean.AttrM in Lean.Attributes

Lean.Parser.mkIdent in Lean.Parser.Types

Lean.Name.anonymous in Init.Prelude

Lean.Expr.sort in Lean.Expr

Lean.Level in Lean.Level

Lean.Level.zero in Lean.Level

Lean.Exception in Lean.Exception

Lean.throwErrorAt in Lean.Exception

Lean.pp.funBinderTypes in Lean.PrettyPrinter.Delaborator.Options

Lean.pp.motives.all in Lean.PrettyPrinter.Delaborator.Options

Command.toString in Auto.IR.SMT

Lean.Name.mkSimple in Init.Prelude

String.intercalate in Init.Data.String.Defs

Lean.Declaration.thmDecl in Lean.Declaration

Lean.mkTheoremValEx in Lean.Declaration

Command in Auto.Parser.TPTP

Hashable in Init.Prelude

Lean.FromJson in Lean.Data.Json.FromToJson.Basic

Lean.ToJson in Lean.Data.Json.FromToJson.Basic

Lean.MonadOptions in Lean.Data.Options

Smt.Preprocess.pushHintsToCtx in Smt.Preprocess.PushHintsToCtx

Smt.Translate.Command in Smt.Translate.Commands

Smt.Translate.Command.cmdsAsQuery in Smt.Translate.Commands

Smt.genUniqueFVarNames in Smt.Tactic.Smt

Smt.prepareSmtQuery in Smt.Tactic.Smt

Auto.hints in Auto.Tactic

Auto.Embedding.Lam.MutualIndInfo in Auto.Embedding.LamInductive

Auto.Embedding.Lam.REntry.valid in Auto.Embedding.LamChecker

Auto.LamReif.ReifM in Auto.Translation.LamReif

Auto.LamReif.getLamEVarTy in Auto.Translation.LamReif

Auto.LamReif.preprocess in Auto.Translation.LamReif

Auto.LamReif.printValuation in Auto.Translation.LamReif

Auto.LamReif.reifFacts in Auto.Translation.LamReif

Auto.LamReif.reifInhabitations in Auto.Translation.LamReif

Auto.LamReif.reifMutInds in Auto.Translation.LamReif

Auto.Monomorphization.monomorphize in Auto.Translation.Monomorphization

Auto.Reif.ReifM in Auto.Translation.ReifM

Auto.SMT.SMTNamingInfo in Auto.Translation.LamFOL2SMT

Auto.SimpleIndVal in Auto.Translation.Inductive

Auto.UMonoFact in Auto.Translation.Assumptions

Auto.collectAllLemmas in Auto.Tactic

Auto.computeMaxLevel in Auto.Translation.Assumptions

Auto.lamFOL2SMT in Auto.Translation.LamFOL2SMT

Auto.runAuto in Auto.Tactic

Lean.MVarId.intro1 in Lean.Meta.Tactic.Intro

Lemma.ofConst in Auto.Translation.Assumptions

Lemma.rewriteUPolyRigid in Auto.Translation.Assumptions

absurd in Init.Prelude

lamEVarTy in Auto.Parser.TPTP

leaf in Test.SmtTranslation.Inductive

IO.Process.Child in Init.System.IO

Lean.Json.arr in Lean.Data.Json.Basic

Except in Init.Prelude

Lean.Json.str in Lean.Data.Json.Basic

Auto.Parser.SMTSexp.Sexp in Auto.Parser.SMTSexp

Std.HashMap in Std.Data.HashMap.Basic

UInt64 in Init.Prelude

propext in Init.Core

Lean.Core.transform in Lean.Meta.Transform

Lean.TransformStep.continue in Lean.Meta.Transform

Lean.Meta.mkExpectedTypeHint in Lean.Meta.AppBuilder

Lean.Meta.mkFreshExprSyntheticOpaqueMVar in Lean.Meta.Tactic.Util

Decidable in Init.Prelude

Ord in Init.Data.Ord.Basic

Ordering in Init.Data.Ord.Basic

Term.toString in Auto.Parser.TPTP

Std.HashMap.ofList in Std.Data.HashMap.Basic

expr in Smt.Data.Sexp

Ordering.gt in Init.Data.Ord.Basic

Ordering.lt in Init.Data.Ord.Basic

Array.zip in Init.Data.Array.Basic

Lean.Elab.Term.TermElabM in Lean.Elab.Term.TermElabM

Lean.Elab.Term.TermElabM.run in Lean.Elab.Term.TermElabM

Lean.Elab.Term.elabTerm in Lean.Elab.Term.TermElabM

Id in Init.Control.Id

Id.run in Init.Control.Id

Auto.Parser.SMTSexp.LexVal in Auto.Parser.SMTSexp

Repr in Init.Data.Repr

timed in Smt.Reconstruct.Timed

repr in Init.Data.Repr

Sexp in Smt.Data.Sexp

Int.ofNat in Init.Data.Int.Basic

IO.FS.Handle in Init.System.IO

IO.Process.spawn in Init.System.IO

System.mkFilePath in Init.System.FilePath

Smt.smt in Smt.Tactic.Smt

Lean.logWarning in Lean.Log

Smt.Tactic.smtHints in Smt.Tactic.Smt

kind in Auto.Parser.TPTP

Lean.Parser.Command.ctor in Lean.Parser.Command

ctor in Test.LeanIssues.Matcher_Order

Lean.Expr.forallE in Lean.Expr

Lean.Expr.letE in Lean.Expr

Lean.dependsOn in Lean.MetavarContext

Or.inl in Init.Prelude

Or.inr in Init.Prelude

Classical.choice in Init.Prelude

MonadExceptOf in Init.Prelude

num in Test.Playground.WHNFExamples

List.range in Init.Data.List.Basic

List.toArray in Init.Prelude

Module in Mathlib.Algebra.Module.Defs

Array.toList in Init.Prelude

Lean.liftCommandElabM in Lean.Elab.Command

isSome in Smt.Reconstruct.Certified.Utils

Lean.Parser.Error in Lean.Parser.Types

Lean.resolveGlobalConstNoOverloadCore in Lean.ResolveName

Lean.MonadResolveName in Lean.ResolveName

Action in Mathlib.CategoryTheory.Action.Basic

Lean.TSyntaxArray.mk in Init.Prelude

Lean.Parser.Term.attrInstance in Lean.Parser.Term

Lean.Elab.Attribute in Lean.Elab.Attributes

Lean.EnvExtension in Lean.Environment

Lean.setEnv in Lean.MonadEnv

Lean.SimpleScopedEnvExtension in Lean.ScopedEnvExtension

Lean.MacroM in Init.Prelude

Lean.Parser.Term.structInstLVal in Lean.Parser.Term.Basic

Array.flatten in Init.Data.Array.Basic

sequence in Mathlib.Control.Traversable.Basic

MonadStateOf in Init.Prelude

semiOutParam in Init.Prelude

MonadLift in Init.Prelude

LE in Init.Prelude

impl in Mathlib.Deprecated.MLList.BestFirst

PUnit.unit in Init.Prelude

Classical.inhabited_of_nonempty in Init.Classical

Inhabited.mk in Init.Prelude

Lean.resolveGlobalName in Lean.ResolveName

Lean.NameHashSet in Lean.Data.NameMap.Basic

Lean.getConstInfo in Lean.MonadEnv

Lean.Json.parse in Lean.Data.Json.Parser

Lean.Json in Lean.Data.Json.Basic

parse in Auto.Parser.TPTP

String.isSubStrOf in Smt.Util

Array.mapM in Init.Data.Array.Basic

BaseIO in Init.System.IO

BaseIO.asTask in Init.System.IO

BaseIO.mapTasks in Init.System.IO

IO.CancelToken in Init.System.IO

IO.CancelToken.new in Init.System.IO

IO.monoMsNow in Init.System.IO

Language in Mathlib.Computability.Language

Lean.Core.wrapAsyncAsSnapshot in Lean.CoreM

Lean.Language.SnapshotTree in Lean.Language.Basic

Lean.logInfo in Lean.Log

List.append in Init.Prelude

Std.HashMap.emptyWithCapacity in Std.Data.HashMap.Basic

Lean.TSyntax.getId in Init.Meta.Defs

Std.HashSet.ofArray in Std.Data.HashSet.Basic
</all_available_defs>

<all_available_lemmas>
theorem foo : ∀ (p q : Prop), p → (p → q) → q

theorem foo_recon : ∀ (p q : Prop), p → (p → q) → q

theorem funextEq' {α β : Type} (f g : α → β) :
  (f = g) = ∀ x, f x = g x

@[smtSimp] theorem iff_eq_eq : (p ↔ q) = (p = q)

@[smtSimp] theorem tupleEq [DecidableEq t1] [DecidableEq t2] (a c : t1) (b d : t2):
  ((a, b) = (c, d)) = (a = c ∧ b = d)

@[smtSimp] theorem tupleForall {P : α × β → Prop}:
  (∀ (x : α × β), P x) = (∀ (a: α) (b : β), P (a, b))

@[smtSimp] theorem tupleExists {P : α × β → Prop}:
  (∃ (x : α × β), P x) = (∃ (a: α) (b : β), P (a, b))

theorem not_if {_ : Decidable c} :
  ¬ (if c then t else e) =
  if c then ¬ t else ¬ e

theorem if_app {α β : Type} {_ : Decidable c} (t e : α -> β) (a : α) :
  (if c then t else e) a =
  if c then (t a) else (e a)

theorem reachable_inclusion (sys sys' : RelationalTransitionSystem σ)
  (hinit_implies : ∀ (st : σ), sys.init st → sys'.init st)
  (hnext_implies : ∀ (st st' : σ), sys.next st st' → sys'.next st st') :
  ∀ (st : σ), reachable (sys := sys) st → reachable (sys := sys') st

theorem invariant_merge [sys : RelationalTransitionSystem σ] (p q : σ → Prop) :
  (isInvariant p ∧ isInvariant q) ↔ (isInvariant (fun s => p s ∧ q s))

theorem isInductiveInvariant_to_isInvariant [sys : RelationalTransitionSystem σ] (hassu : isInvariant sys.assumptions) (p : σ → Prop) :
  isInductiveInvariant (sys := sys) p → isInvariant (sys := sys) p

theorem invInductive_to_isInvariant [sys : RelationalTransitionSystem σ] (hassu : isInvariant sys.assumptions) :
  invInductive (sys := sys) → isInvariant (sys := sys) sys.inv

theorem Set.ne_empty_iff_exists_mem {α : Type u} {s : Set α} : s ≠ ∅ ↔ ∃ a, a ∈ s

theorem quorum_after_proj (Q S : Set Node) : quorum (inst := inst) Q → quorum (inst := inst.project S) Q

theorem intact_implies_intertwined : ∀ I, intact (inst := inst) I → intertwined I

theorem intertwined_node_is_well_behaved : ∀ n S, intertwined (inst := inst) S → n ∈ S → n ∈ W

theorem intact_node_is_well_behaved : ∀ n I, intact (inst := inst) I → n ∈ I → n ∈ W

theorem slice_blocks_ne : ∀ n S I, intact (inst := inst) I → n ∈ I → blocks_slices S n →
    S ∩ I ≠ ∅

theorem started_good.is_inv : RelationalTransitionSystem.isInvariant
  (σ := State' node set_majority set_f_plus_1 proposal_value) started_good

theorem validity_bc.is_inv : RelationalTransitionSystem.isInvariant
  (σ := State' node set_majority set_f_plus_1 proposal_value) validity_bc

theorem agreement_bc.is_inv : RelationalTransitionSystem.isInvariant
  (σ := State' node set_majority set_f_plus_1 proposal_value) agreement_bc

theorem agreement2.is_inv : RelationalTransitionSystem.isInvariant
  (σ := State' node set_majority set_f_plus_1 proposal_value) agreement2

theorem lift_transition {σ σ'} [IsSubStateOf σ σ'] (m : Mode) (tr : TwoState σ) :
  (@Wp.lift _  m σ σ' _ (tr.toWp m)).toTwoState =
  fun st st' =>
    tr (getFrom st) (getFrom st') ∧
    st' = (setIn (@getFrom σ σ' _ st') st)

theorem wp_and (act : Wp m σ ρ) [LawfulAction act] :
  act s post -> act s post' -> act s fun r s => post r s ∧ post' r s

theorem TwoState_sound [LawfulAction act] (req : SProp σ) (ens : SProp σ) :
  -- The post-condition is not trivial
  (¬ ∀ s, ens s) ->
  act.toTwoState.triple req ens -> act.triple req (fun _ => ens)

theorem TwoState_sound' [LawfulAction act] (req : SProp σ) (ens : RProp σ ρ) :
  act.triple req ens → act.toTwoState.triple req (∃ r, ens r ·)

theorem exists_over_PUnit (p : PUnit → Prop) : (∃ (u : PUnit), p u) = p ()

theorem TwoState_sound'_ret_unit [LawfulAction act] (req : SProp σ) (ens : RProp σ PUnit) :
  act.triple req ens → act.toTwoState.triple req (ens () ·)

theorem TwoState_sound'_ret_unit' [LawfulAction act] {st : σ} (ens : RProp σ PUnit) :
  act st ens → (∀ st', act.toTwoState st st' → ens () st')

theorem check_spec_lawful [LawfulAction act] (req : SProp σ) (ens : σ -> RProp σ ρ) :
  (∀ s, req s -> act s (ens s)) ->
  Wp.spec (m := .internal) req ens <= act

@[invProof]
  theorem enter_mutex_manual :
      ∀ (st : @State node) (st' : @State node),
        (@System node node_dec node_ne).assumptions st →
          (@System node node_dec node_ne).inv st →
            (@SuzukiKasamiNats.enter.tr node node_dec node_ne) st st' ->
              @SuzukiKasamiNats.mutex node node_dec node_ne st'

@[invProof]
  theorem recv_single_leader_ :
      ∀ (st st' : @State node),
        (@System node node_dec node_ne tot btwn).assumptions st →
          (@System node node_dec node_ne tot btwn).inv st →
            (@Ring.recv.tr node node_dec node_ne tot btwn) st st' →
              (@Ring.single_leader node node_dec node_ne tot btwn) st'

theorem exists_comm_eq {p : α → β → Prop} : (∃ a b, p a b) = (∃ b a, p a b)

theorem exists_and_left'_eq : (b ∧ (∃ x, p x)) = (∃ x, b ∧ p x)

theorem exists_and_right'_eq : ((∃ x, p x) ∧ b) = (∃ x, p x ∧ b)

theorem not_forall' {p : α → Prop} : (¬∀ x, p x) ↔ ∃ x, ¬p x

theorem not_forall_not' {p : α → Prop} : (¬∀ x, ¬p x) ↔ ∃ x, p x

theorem not_exists_not' {p : α → Prop} : (¬∃ x, ¬p x) ↔ ∀ x, p x

theorem exists_or_left : b ∨ (∃ x, p x) ↔ (∃ x, b ∨ p x)

theorem exists_or_right : (∃ x, p x) ∨ b ↔ (∃ x, p x ∨ b)

theorem ite_exists_push_out [IsHigherOrder α] [ne : Nonempty α] (p r : Prop) (q : α → Prop) : (if p then ∃ t, q t else r) = (∃ t, if p then q t else r)

theorem forall_comm_eq {p : α → β → Prop} : (∀ a b, p a b) = (∀ b a, p a b)

theorem forall_and_on_the_left : b ∧ (∀ x, p x) ↔ (∀ x, b ∧ p x)

theorem forall_and_on_the_right : (∀ x, p x) ∧ b ↔ (∀ x, p x ∧ b)

theorem forall_imp_left : b → (∀ x, p x) ↔ (∀ x, b → p x)

theorem ite_then_forall_push_out [IsHigherOrder α] [ne : Nonempty α] (c r : Prop) (q : α → Prop) : (if c then ∀ t, q t else r) = (∀ t, if c then q t else r)

theorem ite_else_forall_push_out [IsHigherOrder α] [ne : Nonempty α] (c r : Prop) (q : α → Prop) : (if c then r else ∀ t, q t) = (∀ t, if c then r else q t)

theorem ite_both_forall_push_out [IsHigherOrder α] [ne : Nonempty α] [ne' : Nonempty β] (p : α → Prop) (q : β → Prop) :
  (if c then ∀ a, p a else ∀ b, q b) = (∀ (a : α) (b : β), if c then p a else q b)

  theorem foo_inv_0 :
      ∀ (st : @State node),
        (@System node node_dec node_ne).assumptions st →
            (@System node node_dec node_ne).inv st →
              (@Test.foo.ext node node_dec node_ne) st fun _ (st' : @State node) =>
                @Test.inv_0 node node_dec node_ne st'
</all_available_lemmas>

<local_ctx>
import Veil.DSL.Base

namespace Veil

section Veil

open Classical

section Types

inductive Mode where
  | internal : Mode
  | external : Mode
deriving BEq

variable (m : Mode) (σ ρ : Type)

@[inline] abbrev SProp := σ -> Prop

@[inline] abbrev RProp (ρ : Type u) := ρ → SProp σ

@[inline] abbrev TwoState := σ -> σ -> Prop

abbrev Wp (m : Mode) (σ ρ : Type) := σ -> RProp σ ρ -> Prop

abbrev Wlp (m : Mode) (σ ρ : Type) := σ -> RProp σ ρ -> Prop

abbrev BigStep := σ -> ρ -> σ -> Prop

end Types

section Theory

variable {σ ρ : Type}

@[actSimp] def Wp.bind (wp : Wp m σ ρ) (wp_cont : ρ -> Wp m σ ρ') : Wp m σ ρ' :=
  fun s post => wp s (fun r s' => wp_cont r s' post)

@[actSimp] def Wp.get : Wp m σ σ := fun s post => post s s

@[actSimp] def Wp.set (s' : σ) : Wp m σ Unit := fun _ post => post () s'

@[actSimp] def Wp.modifyGet (act : σ -> ρ × σ) : Wp m σ ρ := fun s post => let (ret, s') := act s ; post ret s'

class IsSubStateOf (σ : semiOutParam Type) (σ' : Type) where
   
  setIn : σ -> σ' -> σ'
   
  getFrom : σ' -> σ

  setIn_getFrom_idempotent : ∀ σ', setIn (getFrom σ') σ' = σ'
  getFrom_setIn_idempotent : ∀ σ σ', getFrom (setIn σ σ') = σ

@[actSimp] def Wp.lift {σ σ'} [IsSubStateOf σ σ'] (act : Wp m σ ρ) : Wp m σ' ρ :=
  fun s' post => act (getFrom s') (fun r s => post r (setIn s s'))

def BigStep.lift [IsSubStateOf σ σ'] (act : BigStep σ ρ) : BigStep σ' ρ :=
  fun st r' st' => act (getFrom st) r' (getFrom st') ∧ st' = (setIn (@getFrom σ σ' _ st') st)

@[actSimp]
abbrev Wp.toWlp {σ ρ : Type} {m : Mode} (wp : Wp m σ ρ) : Wlp m σ ρ :=
  
  fun (s : σ) (post : RProp σ ρ) => ¬ wp s (fun r s' => ¬ post r s')

@[actSimp]
def Wp.toBigStep {σ} (wp : Wp m σ ρ) : BigStep σ ρ :=
  fun s r' s' =>
    wp.toWlp s (fun r₀ s₀ => r' = r₀ ∧ s' = s₀)

@[actSimp]
def BigStep.toWp {σ} (act : BigStep σ ρ) : Wp .internal σ ρ :=
  fun s post => ∀ r s', act s r s' -> post r s'

@[actSimp]
def _root_.Function.toWp (m : Mode) (r : TwoState σ) : Wp m σ Unit :=
  fun s post => ∀ s', r s s' -> post () s'

abbrev Wp.triple {σ ρ} (req : SProp σ) (act : Wp m σ ρ) (ens : RProp σ ρ) : Prop :=
  ∀ s, req s -> act s ens

abbrev Wp.alwaysSuccessfullyTerminates {σ } (req : SProp σ) (act : Wp m σ ρ)  : Prop :=
  ∀ s, req s -> act s (fun _ _ => True)

class LawfulAction {σ ρ : Type} (act : Wp m σ ρ) where
  inter {τ : Type} [Inhabited τ] (post : τ -> RProp σ ρ) :
    ∀ s : σ, (∀ t : τ, act s (post t)) -> act s (∀ t, post t · ·)

  impl (post post' : RProp σ ρ) : ∀ s,
    (∀ r s, post r s -> post' r s) -> act s post -> act s post'

section TwoStateSoundness

end TwoStateSoundness

section BigStepSoundness

end BigStepSoundness

section LawfulActionInstances

instance pure_lawful : LawfulAction (Wp.pure (σ := σ) (m := m) r) where
  inter := by admit /- proof elided -/

instance bind_lawful (act : Wp m' σ ρ) (act' : ρ -> Wp m σ ρ') [LawfulAction act] [∀ r, LawfulAction (act' r)] : LawfulAction (Wp.bind (m := m) act act') where
  inter := by admit /- proof elided -/

instance (priority := low) internal_sound (act : Wp m σ ρ) [inst : LawfulAction (m := .internal) act] : LawfulAction (m := .external) act where
  inter := inst.inter
  impl := inst.impl

instance assume_lawful : LawfulAction (Wp.assume (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance assert_lawful : LawfulAction (Wp.assert (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance require_lawful : LawfulAction (Wp.require (m := m) (σ := σ) rq) where
  inter := by admit /- proof elided -/

instance fresh_lawful : LawfulAction (Wp.fresh (m := m) (σ := σ) τ) where
  inter := by admit /- proof elided -/

instance spec_lawful : LawfulAction (Wp.spec (m := m) req ens) where
  inter := by admit /- proof elided -/

instance (r : σ -> σ -> Prop) : LawfulAction (r.toWp (m := m)) where
  inter := by admit /- proof elided -/

instance get_lawful : LawfulAction (Wp.get (m := m) (σ := σ)) where
  inter := by admit /- proof elided -/

instance set_lawful (s : σ) : LawfulAction (Wp.set s (m := m)) where
  inter := by admit /- proof elided -/

instance modifyGet_lawful : LawfulAction (Wp.modifyGet f (m := m) (σ := σ) (ρ := ρ)) where
  inter := by admit /- proof elided -/

instance if_lawful [Decidable c] [instT: LawfulAction t] [instS : LawfulAction e] : LawfulAction (ite c t e) where
  inter := by admit /- proof elided -/

instance lift_lawful (act : Wp m σ ρ) [IsSubStateOf σ σ'] [LawfulAction act] :
  LawfulAction (act.lift (σ' := σ')) where
  inter := by admit /- proof elided -/

end LawfulActionInstances

section GenBigStepInstances

class GenBigStep (σ ρ : Type) (wp : Wp .external σ ρ) (tr : outParam (BigStep σ ρ)) where
  lawful : LawfulAction wp
  equiv pre  :
    wp.alwaysSuccessfullyTerminates pre -> ∀ s, pre s -> tr s = wp.toBigStep s

instance : GenBigStep σ ρ (Wp.pure r) (BigStep.pure r) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.assume asm) (BigStep.assume asm) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.assert asm) (BigStep.assert asm) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ PUnit (Wp.require rq) (BigStep.assume rq) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ τ (Wp.fresh τ) (BigStep.fresh τ) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ Unit (Wp.set s) (BigStep.set s) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ σ (Wp.get) (BigStep.get) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ ρ (Wp.modifyGet act) (BigStep.modifyGet act) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance : GenBigStep σ ρ (Wp.spec req ens) (BigStep.spec req ens) where
  lawful := inferInstance
  equiv := by admit /- proof elided -/

instance [inst : GenBigStep σ ρ act actTr] : LawfulAction act := inst.lawful
</local_ctx>

<target_theorem>
theorem lift_transition_big_step' {σ σ'} [IsSubStateOf σ σ'] (m : Mode) (r : Wp m σ ρ) [LawfulAction r] (st : σ') :
  r.alwaysSuccessfullyTerminates (· = getFrom st) →
  (@Wp.lift _  m σ σ' _ r).toBigStep st =
  fun r' st' =>
    r.toBigStep (getFrom st) r' (getFrom st') ∧
    st' = (setIn (@getFrom σ σ' _ st') st) :=
</target_theorem>

