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>
structure SpV (valTyp : Type) where
  ind: Array Nat
  val: Array valTyp
  size: ℕ
  size_eq: ind.size = size ∧ val.size = size
  inc: ∀ (i j: Nat), i < size → j < size →  i < j → ind[i]! < ind[j]!

def sumUpTo
  (spv : SpV Int)
  (v : Array Int) (bound : ℕ) : Int := ∑ i ∈ Finset.range bound, ((spv.val)[i]! * v[(spv.ind)[i]!]!)

instance : Inhabited (SpV Int) where
  default :=
  { ind := #[],
    val := #[],
    size := 0,
    size_eq := (by admit /- proof elided -/
    ),
    inc := (fun i j h_i h_j i_lt_j => by admit /- proof elided -/
    ) }

instance: GetElem (SpV Int) Nat Int fun _ _ => True where
  getElem inst i _ :=
    match (List.zip (inst.ind.toList) (inst.val.toList)).find? fun (j, _) => j = i with
    | some pr => pr.2
    | none => 0


method VSpV
  (mut out: Array Int)
  (arr: Array Int)
  (spv: SpV Int) return (u: Unit)
  ensures out.size = 1
  ensures out[0]! = sumUpTo spv arr (spv.size)
  do
    let mut ind := 0
    out := Array.replicate 1 0
    while ind ≠ spv.size
    invariant out.size = 1
    invariant ind ≤ spv.size
    invariant out[0]! = sumUpTo spv arr ind
    done_with ind = spv.size
    do
      out[0] += (spv.val)[ind]! * arr[(spv.ind)[ind]!]!
      ind := ind + 1
    return

prove_correct VSpV by
  loom_solve


method spmv
  (mut out: Array Int)
  (arr: Array Int) (spv: SpV Int)
  (spm : Array (SpV Int)) return (u : Unit)
  ensures spm.size = out.size
  ensures ∀ i < spm.size, out[i]! = sumUpTo spm[i]! arr spm[i]!.size
  do
    out := Array.replicate spm.size 0
    let mut arrInd : Array Nat := Array.replicate spm.size 0
    let mut spmInd : Array Nat := Array.replicate spm.size 0
    while_some i :| i < arrInd.size ∧ arrInd[i]! < spm[i]!.size
    invariant arrInd.size = spm.size
    invariant out.size = spm.size
    invariant ∀ i < arrInd.size, arrInd[i]! <= spm[i]!.size
    invariant ∀ i < arrInd.size, out[i]! = sumUpTo spm[i]! arr arrInd[i]!
    done_with ∀ i < arrInd.size, arrInd[i]! = spm[i]!.size
    do
      let ind := arrInd[i]!
      let vInd := (spm[i]!.ind)[ind]!
      let mVal := (spm[i]!.val)[ind]!
      let val := mVal * arr[vInd]!
      out[i] += val
      arrInd[i] += 1
    return

prove_correct spmv by
  loom_solve

def spv_dot (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ): Int :=
  if (spv1.size) ≤ pnt1 ∨ (spv2.size) ≤ pnt2 then
    0
  else
    if (spv1.ind)[pnt1]! = (spv2.ind)[pnt2]! then
      (spv1.val)[pnt1]! * (spv2.val)[pnt2]! + spv_dot spv1 spv2 (pnt1 + 1) (pnt2 + 1)
    else
      if (spv1.ind)[pnt1]! < (spv2.ind)[pnt2]! then
        spv_dot spv1 spv2 (pnt1 + 1) pnt2
      else
        spv_dot spv1 spv2 pnt1 (pnt2 + 1)
  termination_by ((spv1.size) + (spv2.size) - pnt1 - pnt2)


method SpVSpV
  (mut out: Array Int)
  (spv1: SpV Int)
  (spv2: SpV Int) return (u: Unit)
  ensures out.size = 1
  ensures out[0]! = spv_dot spv1 spv2 0 0
  do
    out := Array.replicate 1 0
    let mut pnt1 := 0
    let mut pnt2 := 0
    while pnt1 ≠ spv1.size ∧ pnt2 ≠ spv2.size
    invariant out.size = 1
    invariant pnt1 ≤ spv1.size ∧ pnt2 ≤ spv2.size
    invariant out[0]! + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0
    done_with pnt1 = spv1.size ∨ pnt2 = spv2.size
    do
      if (spv1.ind)[pnt1]! = (spv2.ind)[pnt2]! then
        out[0] += (spv1.val)[pnt1]! * (spv2.val)[pnt2]!
        pnt1 := pnt1 + 1
        pnt2 := pnt2 + 1
      else
        if (spv1.ind)[pnt1]! < (spv2.ind)[pnt2]! then
          pnt1 := pnt1 + 1
        else
          pnt2 := pnt2 + 1
    return


method SpMSpV
  (mut out: Array Int)
  (spm: Array (SpV Int))
  (spv: SpV Int) return (u: Unit)
  ensures out.size = spm.size
  ensures ∀ i < spm.size, out[i]! = spv_dot spm[i]! spv 0 0
  do
    out := Array.replicate spm.size 0
    let mut spmInd := Array.replicate spm.size 0
    let mut spvInd := Array.replicate spm.size 0
    while_some i :| i < spm.size ∧ spmInd[i]! < spm[i]!.size ∧ spvInd[i]! < spv.size
    invariant spvInd.size = spm.size
    invariant spmInd.size = spm.size
    invariant out.size = spm.size
    invariant ∀ i < spmInd.size, spmInd[i]! <= spm[i]!.size
    invariant ∀ i < spvInd.size, spvInd[i]! <= spv.size
    invariant ∀ i < spm.size, out[i]! + spv_dot spm[i]! spv spmInd[i]! spvInd[i]! = spv_dot spm[i]! spv 0 0
    done_with ∀ i < spm.size, spmInd[i]! = spm[i]!.size ∨ spvInd[i]! = spv.size
    do
      let ind_m := spmInd[i]!
      let ind_v := spvInd[i]!
      if spm[i]!.ind[ind_m]! = spv.ind[ind_v]! then
        out[i] += spm[i]!.val[ind_m]! * spv.val[ind_v]!
        spmInd[i] += 1
        spvInd[i] += 1
      else
        if spm[i]!.ind[ind_m]! < spv.ind[ind_v]! then
          spmInd[i] += 1
        else
          spvInd[i] += 1
    return

def anyGoalsWithTag (tactic : MVarId → TacticM (Option (Name × α))) : TacticM (Array α) := do
  let mvarIds ← getGoals
  let mut res : Array α := #[]
  let mut mvarIdsNew : Array MVarId := #[]
  for mvarId in mvarIds do
    unless (← mvarId.isAssigned) do
      setGoals [mvarId]
      try
        let r ← tactic mvarId
        let goals <- getUnsolvedGoals
        if let some ⟨n, r⟩ := r then
          for goal in goals do
            goal.setTag n
          res := res.push r
          mvarIdsNew := mvarIdsNew ++ goals
      catch _ =>
        mvarIdsNew := mvarIdsNew.push mvarId
  setGoals mvarIdsNew.toList
  pure res

def anyGoals' (tactic : MVarId → TacticM Unit) : TacticM Unit := do
  let mvarIds ← getGoals
  let mut mvarIdsNew : Array MVarId := #[]
  for mvarId in mvarIds do
    unless (← mvarId.isAssigned) do
      setGoals [mvarId]
      try
        tactic mvarId
        mvarIdsNew := mvarIdsNew ++ (← getUnsolvedGoals)
      catch _ =>
        mvarIdsNew := mvarIdsNew.push mvarId
  setGoals mvarIdsNew.toList

structure SubstringResult where
  l : Nat
  r : Nat
  flag: Bool
deriving Repr, Inhabited

@[loomAbstractionSimp]
def CorrectSubstring (s : Array Char) (p : Char -> Bool) (l r : Nat) : Prop :=
  l ≤ r ∧ r < s.size ∧
  (∀ i, l ≤ i ∧ i ≤ r → p s[i]!)




method SubstringSearch (s: Array Char) (p: Char -> Bool) return (res: SubstringResult)

ensures (res.l ≤ res.r)
ensures 0 < s.size → res.r < s.size
ensures res.flag → CorrectSubstring s p res.l res.r
ensures res.flag →
  (∀ l₁ r₁, CorrectSubstring s p l₁ r₁ →
    r₁ - l₁ + 1 = res.r - res.l + 1 ∧ res.r ≤ r₁ ∨
    r₁ - l₁ + 1 < res.r - res.l + 1)
ensures ¬res.flag → ∀ i < s.size, ¬p s[i]!
do
    if s.size = 0 then
      
      return ⟨0, 0, false⟩
    let mut cnt := 0
    let mut pnt := 0
    let mut ans := 0
    let mut l_ans := 0
    let mut r_ans := 0
    while pnt < s.size
    
    invariant 0 ≤ cnt
    invariant cnt ≤ pnt
    invariant pnt ≤ s.size
    invariant l_ans ≤ r_ans
    invariant r_ans < s.size
    invariant cnt ≤ ans
    invariant r_ans ≤ pnt
    invariant ∀ j, pnt - cnt ≤ j ∧ j < pnt → p s[j]!
    invariant ans > 0 →
        ans = r_ans - l_ans + 1 ∧
        CorrectSubstring s p l_ans r_ans
    invariant ans = 0 → (∀ i, i < pnt → ¬p s[i]!)
    invariant cnt < pnt → ¬p s[pnt - cnt - 1]!
    invariant ∀ l₁ r₁,
        CorrectSubstring s p l₁ r₁ ∧ r₁ < pnt →
        r₁ - l₁ + 1 = ans ∧ r_ans ≤ r₁ ∨ r₁ - l₁ + 1 < ans
    
    
    
    decreasing s.size - pnt
    do
      
      if p s[pnt]! then
        cnt := cnt + 1
        if ans < cnt then
          l_ans := pnt + 1 - cnt
          r_ans := pnt
          ans := cnt
      else
        cnt := 0
      pnt := pnt + 1
    return ⟨l_ans, r_ans, ans > 0⟩

prove_correct SubstringSearch by
  loom_solve

private def resolveSimpIdTheorem? (simpArgTerm : Term) : TermElabM ResolveSimpIdResult := do
    let resolveExt (n : Name) : TermElabM ResolveSimpIdResult := do
      let ext₁? ← getSimpExtension? n
      let ext₂? ← Simp.getSimprocExtension? n
      if h : ext₁?.isSome || ext₂?.isSome then
        return .ext ext₁? ext₂? h
      else
        return .none
    match simpArgTerm with
    | `($id:ident) =>
      try
        if let some e ← Term.resolveId? simpArgTerm (withInfo := true) then
          if let some simprocDeclName ← isSimproc? e then
            return .simproc simprocDeclName
          else
            return .expr e
        else
          let name := id.getId.eraseMacroScopes
          if (← Simp.isBuiltinSimproc name) then
            return .simproc name
          else
            resolveExt name
      catch _ =>
        resolveExt id.getId.eraseMacroScopes
    | _ =>
      if let some e ← Term.elabCDotFunctionAlias? simpArgTerm then
        return .expr e
      else
        return .none
where
  isSimproc? (e : Expr) : MetaM (Option Name) := do
    let .const declName _ := e | return none
    unless (← Simp.isSimproc declName) do return none
    return some declName

private def applyStarArg (ctx : Simp.Context) : MetaM Simp.Context := do
  let mut simpTheorems := ctx.simpTheorems
   
  let hs ← getPropHyps
  for h in hs do
    unless simpTheorems.isErased (.fvar h) do
      simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr (config := ctx.indexConfig)
  return ctx.setSimpTheorems simpTheorems

private def elabDeclToUnfoldOrTheorem (config : Meta.ConfigWithKey) (id : Origin)
    (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM ElabSimpArgResult := do
  if e.isConst then
    let declName := e.constName!
    let info ← getConstVal declName
    if (← isProp info.type) then
      let thms ← mkSimpTheoremFromConst declName (post := post) (inv := inv)
      return .addEntries <| thms.map (SimpEntry.thm ·)
    else
      if inv then
        throwError m!"Invalid `←` modifier: `{declName}` is a declaration name to be unfolded"
          ++ .hint' m!"The simplifier cannot \"refold\" definitions by name. Use `rw` for this intead,
                      or use the `←` simp modifier with an equational lemma for `{declName}`."
      if kind == .dsimp then
        return .addEntries #[.toUnfold declName]
      else
        .addEntries <$> mkSimpEntryOfDeclToUnfold declName
  else if e.isFVar then
    let fvarId := e.fvarId!
    let decl ← fvarId.getDecl
    if (← isProp decl.type) then
      let thms ← mkSimpTheoremFromExpr id #[] e (post := post) (inv := inv) (config := config)
      return .addEntries <| thms.map (SimpEntry.thm ·)
    else if !decl.isLet then
      throwError "Invalid argument: Variable `{e}` is not a proposition or let-declaration"
    else if inv then
      throwError m!"Invalid `←` modifier: `{e}` is a let-declaration name to be unfolded"
        ++ .note "The simplifier cannot \"refold\" local declarations by name"
    else
      return .addLetToUnfold fvarId
  else
    let thms ← mkSimpTheoremFromExpr id #[] e (post := post) (inv := inv) (config := config)
    return .addEntries <| thms.map (SimpEntry.thm ·)

private def elabSimpTheorem (config : Meta.ConfigWithKey) (id : Origin) (stx : Syntax)
    (post : Bool) (inv : Bool) : TermElabM ElabSimpArgResult := do
  let thm? ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
    let e ← Term.elabTerm stx .none
    Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
    let e ← instantiateMVars e
    if e.hasSyntheticSorry then
      return .none
    let e := e.eta
    if e.hasMVar then
      let r ← abstractMVars e
      return some (r.paramNames, r.expr)
    else
      return some (#[], e)
  if let some (levelParams, proof) := thm? then
    let thms ← mkSimpTheoremFromExpr id levelParams proof (post := post) (inv := inv) (config := config)
    return .addEntries <| thms.map (SimpEntry.thm ·)
  else
    return .none

private def elabSimpArg (indexConfig : Meta.ConfigWithKey) (eraseLocal : Bool) (kind : SimpKind)
    (arg : Syntax) : TermElabM ElabSimpArgResult := withRef arg do
  try
     
    if arg.getKind == ``Lean.Parser.Tactic.simpErase then
      let fvar? ← if eraseLocal then Term.isLocalIdent? arg[1] else pure none
      if let some fvar := fvar? then
        
        return .erase (.fvar fvar.fvarId!)
      else
        let id := arg[1]
        if let .ok declName ← observing (realizeGlobalConstNoOverloadWithInfo id) then
          if (← Simp.isSimproc declName) then
            return .eraseSimproc declName
          else
            return .erase (.decl declName)
        else
          
          
          let name := id.getId.eraseMacroScopes
          if (← Simp.isBuiltinSimproc name) then
            return .eraseSimproc name
          else
            throwUnknownConstantAt id name
    else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
      let post :=
        if arg[0].isNone then
          true
        else
          arg[0][0].getKind == ``Parser.Tactic.simpPost
      let inv  := !arg[1].isNone
      let term := arg[2]
      match (← resolveSimpIdTheorem? ⟨term⟩) with
      | .expr e  =>
        let name ← mkFreshId
        elabDeclToUnfoldOrTheorem indexConfig (.stx name arg) e post inv kind
      | .simproc declName =>
        return .addSimproc declName post
      | .ext ext₁? ext₂? h =>
        return .ext ext₁? ext₂? h
      | .none    =>
        let name ← mkFreshId
        elabSimpTheorem indexConfig (.stx name arg) term post inv
    else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
      return .star
    else
      throwUnsupportedSyntax
  catch ex =>
    throw ex

def elabSimpArgs' (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsArray) (eraseLocal : Bool)
    (kind : SimpKind) (ignoreStarArg := false) : TermElabM ElabSimpArgsResult := do
  if stx.isNone then
    return { ctx, simprocs, simpArgs := #[] }
  else
     
    let go := do 
      let zetaDeltaSet ← toZetaDeltaSet stx ctx
      withTrackingZetaDeltaSet zetaDeltaSet do
        let mut starArg := false 
        let mut args : Array (Syntax × ElabSimpArgResult) := #[]
        for argStx in stx[1].getSepArgs do
          let arg ← elabSimpArg ctx.indexConfig (eraseLocal || starArg) kind argStx
          starArg := !ignoreStarArg && (starArg || arg matches .star)
          args := args.push (argStx, arg)

        let mut thmsArray := ctx.simpTheorems
        let mut thms      := thmsArray[0]!
        let mut simprocs  := simprocs
        for (ref, arg) in args do
          match arg with
          | .addEntries entries =>
            for entry in entries do
              thms := thms.uneraseSimpEntry entry
              thms := thms.addSimpEntry entry
          | .addLetToUnfold fvarId =>
            thms := thms.addLetDeclToUnfold fvarId
          | .addSimproc declName post =>
            simprocs ← simprocs.add declName post
          | .erase origin =>
            
            
            if origin matches .fvar _ then
              thms := thms.eraseCore origin
            
            else if ctx.config.autoUnfold then
              thms := thms.eraseCore origin
            else
              thms ← withRef ref <| thms.erase origin
          | .eraseSimproc name =>
            simprocs := simprocs.erase name
          | .ext simpExt? simprocExt? _ =>
            if let some simpExt := simpExt? then
              thmsArray := thmsArray.push (← simpExt.getTheorems)
            if let some simprocExt := simprocExt? then
              simprocs := simprocs.push (← simprocExt.getSimprocs)
          | .star => pure ()
          | .none => pure ()

        let mut ctx := ctx.setZetaDeltaSet zetaDeltaSet (← getZetaDeltaFVarIds)
        ctx := ctx.setSimpTheorems (thmsArray.set! 0 thms)
        if !ignoreStarArg && starArg then
          ctx ← applyStarArg ctx

        return { ctx, simprocs, simpArgs := args}
    
    
    Term.withoutErrToSorry go
where

def tacticToDischarge (tacticCode : Syntax) : TermElabM (IO.Ref Term.State × Simp.Discharge) := do
  let tacticCode ← `(tactic| try ($(⟨tacticCode⟩):tacticSeq))
  let ref ← IO.mkRef (← getThe Term.State)
  let ctx ← readThe Term.Context
  let disch : Simp.Discharge := fun e => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar e `simp.discharger
    let s ← ref.get
    let runTac? : TermElabM (Option Expr) :=
      try
         
        withoutModifyingStateWithInfoAndMessages do
          Term.withSynthesize (postpone := .no) do
            Term.runTactic (report := false) mvar.mvarId! tacticCode .term
          let result ← instantiateMVars mvar
          if result.hasExprMVar then
            return none
          else
            return some result
      catch _ =>
        return none
    let (result?, s) ← liftM (m := MetaM) <| Term.TermElabM.run runTac? ctx s
    ref.set s
    return result?
  return (ref, disch)

private def mkDischargeWrapper (optDischargeSyntax : Syntax) : TermElabM Simp.DischargeWrapper := do
  if optDischargeSyntax.isNone then
    return Simp.DischargeWrapper.default
  else
    let (ref, d) ← tacticToDischarge optDischargeSyntax[0][3]
    return Simp.DischargeWrapper.custom ref d

@[inline] def simpOnlyBuiltins' : List Name := [``eq_self, ``iff_self]

def mkSimpContext' (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
    (ignoreStarArg : Bool := false) (simpTheorems : CoreM SimpTheorems := getSimpTheorems) :
    TermElabM MkSimpContextResult := do
  if !stx[2].isNone then
    if kind == SimpKind.simpAll then
      throwError "Tactic `simp_all` does not support the `discharger` option"
    if kind == SimpKind.dsimp then
      throwError "Tactic `dsimp` does not support the `discharger' option"
  let dischargeWrapper ← mkDischargeWrapper stx[2]
  let simpOnly := !stx[simpOnlyPos].isNone
  let simpTheorems ← if simpOnly then
    simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems)
  else
    simpTheorems
  let simprocs ← if simpOnly then pure {} else Simp.getSimprocs
  let congrTheorems ← getSimpCongrTheorems
  let ctx ← Simp.mkContext
     (config := { dsimp := kind == .dsimp })
     (simpTheorems := #[simpTheorems])
     congrTheorems
  let r ← elabSimpArgs' stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) (ignoreStarArg := ignoreStarArg) ctx
  return { r with dischargeWrapper }

def Lean.Expr.runSimp (e : Expr) (stx : TermElabM (TSyntax `tactic)) : TermElabM Simp.Result := do
  let ctx <- mkSimpContext' (← stx) false
  let res <- simp e ctx.ctx (simprocs := ctx.simprocs) (discharge? := none)
  return res.1

def Lean.Expr.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

def ultimateReduce (e : Expr) : TermElabM Expr :=
  withTransparency (mode := .default) <| reduceAll e

def simpleAddThm (n : Name) (tp : Expr) (pf : Expr)
  (attr : Array Attribute := #[]) : TermElabM Unit := do
  addDecl <|
    Declaration.thmDecl <|
      mkTheoremValEx n [] tp pf []
  applyAttributes n attr

elab "#reduce!" e:term : command => do
  liftTermElabM do
    let e ← ultimateReduce <| <- Term.elabTerm e none
    logInfoAt (<- getRef) e

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

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 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 existentialIdents (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

elab "#gen_spec" name:ident args:explicitBinders ? "for" prim:term : command => do
  liftTermElabM do
    let ⟨funArgs, forallArgs, args⟩ <-
      match args with
      | .some args => do
        let funArgs    <- toFunBinderArray args
        let forallArgs <- toBracketedBinderArray args
        let args       <- existentialIdents args
        pure (funArgs, forallArgs, args)
      | .none => pure (#[], #[], #[])
    let primFun <- `(fun $funArgs* => $prim)
    let primExp <- elabTermAndSynthesize primFun none
    let (pf, primRed) <- lambdaTelescope primExp fun args primExp => do
      let primRed <- ultimateReduce primExp
      let ⟨primRed, prf, _⟩ <- Expr.runSimp primRed <| `(tactic| simp)
      let pf := prf.getD <| <- mkAppM ``Eq.refl #[primExp]
      let pf <- mkLambdaFVars args pf
      let primRed <- mkLambdaFVars args primRed
      return (pf, primRed)
    let primRed <- Term.exprToSyntax primRed
    let tp := <- elabTermAndSynthesize (<- `(forall? $forallArgs*, $prim = $primRed $args*)) none
    let ⟨tp, _, _⟩ <- Expr.runSimp tp <| `(tactic| dsimp only)
    let module <- getCurrNamespace
    simpleAddThm (module ++ name.getId) tp pf (attr := #[{name := `loomWpSimp} ])
    trace[debug] "Generated spec for {prim}:\n{tp}"

elab "#derive_lifted_wp" args:explicitBinders ? "for" "(" name:term ":" type:term ")" "as" m:ident out:ident : command => do
  let args_list ← liftTermElabM do
    match args with
    | .some args => do
      toBracketedBinderArray args
    | .none => pure #[]
  let wp_name ← mkFreshIdent name
  let thmCmd <- `(command|

elab "#derive_wp" args:explicitBinders ? "for" "(" name:term ":" type:term ")" : command => do
  let args_list ← liftTermElabM do
    match args with
    | .some args => do
      toBracketedBinderArray args
    | .none => pure #[]
  let wp_name ← mkFreshIdent name
  let thmCmd <- `(command|

def WPGen.recOption {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
   {x : m β} {y : α → m β} {val: Option α}
  (wpgx : WPGen x) (wpgy : ∀ a, WPGen (y a)) :
  WPGen (Option.recOn val x y : m β) where
  get := fun post =>
    (wpgx.get post) ⊓ (⨅ a, (wpgy a).get post)
  prop := by admit /- proof elided -/

def WPGen.recList {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
   {nl : m β} {tl : α → List α → m β → m β} {ls: List α}
  (wpgn : WPGen nl) (wpgt : ∀ (y: α) (li: List α) (mb: m β), WPGen (tl y li mb)) :
  WPGen (List.recOn ls nl tl : m β) where
  get := fun post =>
    (wpgn.get post) ⊓
    (⨅ y , ⨅ li, ⨅ mb, (wpgt y li mb).get post)
  prop := by admit /- proof elided -/

inductive mt1: Type u → Type u where
| Leaf : {β : Type u} → β → mt1 β
| Empty : {β : Type u} → mt1 β
| Node: {β : Type u} → mt1 β → mt1 β → β → mt1 β

noncomputable

def WPGen.recMT1 {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
  {ls: mt1 γ}
  {ll : γ → m β}
  {el : m β}
  {nl : mt1 γ → mt1 γ → γ → m β → m β → m β}
  (wpgl : ∀ (a: γ), WPGen (ll a))
  (wpge : WPGen el)
  (wpgn : ∀ (l r: mt1 γ) (a: γ) (ml mr: m β), WPGen (nl l r a ml mr)):
  WPGen (mt1.recOn ls ll el nl : m β) where
  get := fun post =>
    (⨅ a, (wpgl a).get post) ⊓
    (wpge.get post) ⊓
    (⨅ l, ⨅ r, ⨅ a, ⨅ ml, ⨅ mr, (wpgn l r a ml mr).get post)
  prop := by admit /- proof elided -/

def WPGen.recProd {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
  {pr: Prod α₁ α₂}
  {mkp : α₁ → α₂ → m β}
  (wpgf : ∀ (a: α₁) (b: α₂), WPGen (mkp a b)):
  WPGen (Prod.recOn pr mkp : m β) where
  get := fun post =>
    (⨅ a, ⨅ b, (wpgf a b).get post)
  prop := by admit /- proof elided -/

@[grind]
def isMax (mx: Int) (arr: Array Int) :=
    forall i, ( h: i < arr.size ) -> mx >= (arr[i]'h)

method maxElem (arr: Array Int) return (res: Int)
  require arr.size > 0
  ensures isMax res arr
  do
    let mut i := 0
    let mut mx := arr[i]!
    i := i + 1
    while i < arr.size
    invariant 0 <= i ∧ i <= arr.size
    invariant forall j, j < i -> mx >= arr[j]!
    done_with i = arr.size
    do
      let elem := arr[i]!
      if elem > mx then
        mx := elem
      else
        mx := mx
      i := i + 1
    return mx

prove_correct maxElem by
  loom_solve

namespace Loom.SMT
def smtSolverToTryOnUnknown (tried : SmtSolver) : SmtSolver :=
  match tried with
  | .z3 => .cvc5
  | .cvc5 => .z3
end Loom.SMT

namespace Loom.SMT
abbrev SolverProc := IO.Process.Child ⟨.piped, .piped, .piped⟩
end Loom.SMT

namespace Loom.SMT
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
end Loom.SMT

namespace Loom.SMT
inductive SmtResult
   
  | Sat (modelString : Option String)
  | Unsat
  | Unknown (reason : Option String)
  | Failure (reason : Option String)
deriving Inhabited
end Loom.SMT

namespace Loom.SMT
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})"
end Loom.SMT

namespace Loom.SMT
@[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
end Loom.SMT

namespace Loom.SMT
def prepareLeanAutoQuery (mv : MVarId) (hints : TSyntax `Auto.hints) : TacticM String := do
  \n" (commands.toList.map toString)
    return queryStr
end Loom.SMT

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

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

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

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

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

namespace Loom.SMT
def z3Path := buildDir / "z3"
end Loom.SMT

namespace Loom.SMT
def cvc5Path := buildDir / "cvc5"
end Loom.SMT

namespace Loom.SMT
def createSolver (name : SmtSolver) (withTimeout : Nat) : MetaM SolverProc := do
  let tlim_sec := withTimeout
  let seed := loom.solver.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 := #["
      let proc ← createAux s!"{cvc5Path}" args
      emitCommand proc (.setLogic "ALL")
      pure proc
end Loom.SMT

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

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

  | .atom (.symb "unknown") =>
    trace[loom.smt.result] "{solverName} says Unknown"
      if retryOnUnknown then
        let newSolver := smtSolverToTryOnUnknown solverName
        trace[loom.smt.debug] "Retrying with {newSolver}"
        querySolver goalQuery withTimeout (forceSolver := newSolver) (retryOnUnknown := false)
      else
        let (_, solver) ← solver.takeStdin
        let stdout ← solver.stdout.readToEnd
        let stderr ← solver.stderr.readToEnd
        trace[loom.smt.debug] "stdout: {stdout}"
        trace[loom.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)
end Loom.SMT

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

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

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

namespace Loom.SMT
def failureGoalStr (solver : Option SmtSolver := none) : String := s!"{solverStr solver}solver invocation failed"
end Loom.SMT

namespace Loom.SMT
def specifiedSmtSolver (loomSolver : LoomSolver) : Option SmtSolver :=
  match loomSolver with
  | .smt solver => some solver
  | _ => none
end Loom.SMT

namespace Loom.SMT
@[tactic loom_smt] def elabLoomSmt : Tactic := fun stx => withMainContext do
  let hints : TSyntax `Auto.hints := ⟨stx[1]⟩
  let mv ← Tactic.getMainGoal
  let opts ← getOptions
  let withTimeout := loom.solver.smt.timeout.get opts
  let cmdString ← prepareLeanAutoQuery mv hints
  let (res, solverUsed) ← querySolver cmdString withTimeout (forceSolver := specifiedSmtSolver (loom.solver.get opts)) (retryOnUnknown := loom.solver.smt.retryOnUnknown.get opts)
  match res with
  
  | .Sat none => throwError s!"{satGoalStr solverUsed}"
  | .Sat (some modelString) => 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)
end Loom.SMT

instance (σ : Type u) (l : Type u) (m : Type u -> Type v)
  [CompleteLattice l]
  [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l] : MAlgOrdered (StateT σ m) (σ -> l) where
  μ := (MAlgOrdered.μ $ (fun fs => fs.1 fs.2) <$> · ·)
  μ_ord_pure := by admit /- proof elided -/

instance (σ : Type u) (l : Type u) (m : Type u -> Type v)
  [CompleteLattice l]
  [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l] [inst': MAlgDet m l]
   : MAlgDet (StateT σ m) (σ -> l) where
    angelic := by admit /- proof elided -/

instance [Monad m] [inst : ∀ α, Lean.Order.CCPO (m α)] : Lean.Order.CCPO (StateT ε m α) :=

instance [Monad m] [∀ α, Lean.Order.CCPO (m α)] [Lean.Order.MonoBind m] : Lean.Order.MonoBind (StateT ε m) where
  bind_mono_left h₁₂ _ := by admit /- proof elided -/

instance [Monad m] [CCPOBot m] : CCPOBot (StateT σ m) where
  compBot := fun _ => CCPOBot.compBot

instance [Monad m] [inst : ∀ α, Lean.Order.CCPO (m α)] [CCPOBot m] [CCPOBotLawful m] : CCPOBotLawful (StateT σ m) where
  prop := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)] [MonoBind m]
  [MAlgPartial m] : MAlgPartial (StateT σ m) where
  csup_lift {α} chain := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)]  [MonoBind m]
  [MAlgTotal m] : MAlgTotal (StateT σ m) where
  bot_lift := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [inst': NoFailure m] : NoFailure (StateT σ m) where
  noFailure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l] :
  MAlgLift m l (StateT σ m) (σ -> l) where
    μ_lift := by admit /- proof elided -/

def z3.version := "4.15.4"

def cvc5.version := "1.3.1"

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"

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 := #["-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 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 z3 ← downloadDependency pkg (pkg.buildDir / "z3") (downloadSolver Solver.z3)
  let cvc5 ← downloadDependency pkg (pkg.buildDir / "cvc5") (downloadSolver Solver.cvc5)
  return Job.collectArray #[z3, cvc5]

def CaseStudiesRoot : Array Glob :=
  #[`CaseStudies.Extension,
    `CaseStudies.Macro,
    `CaseStudies.Tactic,
    `CaseStudies.TestingUtil,
    `CaseStudies.Theory]

def Array.sumUpTo [Inhabited α] [AddCommMonoid β] (a : Array α) (f : ℕ -> α -> β) (bound : ℕ) : β :=
  ∑ i ∈ Finset.range bound, f i a[i]!

instance [Repr α] [FinEnum α] : Repr (α -> Bool) where
  reprPrec p := fun n => Repr.reprPrec (FinEnum.toList α |>.map fun x => (x, p x)) n

instance : Repr (ℕ -> Bool) where
  reprPrec p := fun n => Repr.reprPrec (List.range 10 |>.map fun x => (x, p x)) n

structure Encoding where
  cnt: Nat
  c: Char
  deriving Inhabited

def get_cnt_sum (l: List Encoding) :=
  match l with
  | List.nil => 0
  | List.cons x xs => x.cnt + get_cnt_sum xs

@[reducible]
def is_valid_run_sequence (encoded_str: Array Encoding) :=
    forall i, ( h: i < encoded_str.size ) -> (encoded_str[i]'h).cnt > 0

method decodeStr' (encoded_str: Array Encoding)
   return (res: Array Char)
   require is_valid_run_sequence encoded_str
   ensures (res.size = get_cnt_sum encoded_str.toList)
     do
       let mut decoded := Array.replicate 0 'x'
       let mut i := 0
       while i < encoded_str.size
          invariant 0 <= i ∧ i <= encoded_str.size
          invariant decoded.size = get_cnt_sum (encoded_str.extract 0 i).toList
          done_with i = encoded_str.size
          do
            let elem := encoded_str[i]!
            let elem_decoded := Array.replicate elem.cnt elem.c
            decoded :=  decoded ++ elem_decoded
            i := i + 1
       return decoded

prove_correct decodeStr' by
  loom_solve
  · simp[*] at *
    have : decoded.size = get_cnt_sum (List.take i encoded_str.toList) := by admit /- proof elided -/

def decodeStrLeanList (encoded_str: List Encoding) : List Char :=
  match encoded_str with
  | List.nil => List.nil
  | List.cons hd tl => (List.replicate hd.cnt hd.c) ++ (decodeStrLeanList tl)

def decodeStrLean' (encoded_str: Array Encoding) : Array Char :=
  Array.mk (decodeStrLeanList encoded_str.toList)

@[grind]
def decodeStrLean (encoded_str: Array Encoding) : Array Char :=
  let mp := Array.map (fun e => Array.replicate e.cnt e.c) encoded_str
  mp.flatten

structure MProdWithNames (α β : Type u) (αName : Lean.Name := default) where
   
  fst : α
   
  snd : β

abbrev MProdWithNames.mk' {α β : Type u} (a : α) (b : β)
  (αName : Lean.Name := default) : MProdWithNames α β αName :=
  @MProdWithNames.mk _ _ αName a b

abbrev WithName (α : Sort u) (name : Lean.Name := default) := α

abbrev typeWithName {α : Type u} (β : α) (name : Lean.Name := default) := β

abbrev WithName.mk' {α : Sort u} (a : α) (name : Lean.Name := default) : WithName α name :=
  a

abbrev WithName.erase {α : Type u} {name} (a : WithName α name) : α := a

abbrev typeWithName.erase {α} {name} (a: typeWithName α name): α := a

namespace Lean.Elab.Term
private def getDoSeqElems (doSeq : Syntax) : List Syntax :=
  if doSeq.getKind == ``Parser.Term.doSeqBracketed then
    doSeq[1].getArgs.toList.map fun arg => arg[0]
  else if doSeq.getKind == ``Parser.Term.doSeqIndent then
    doSeq[0].getArgs.toList.map fun arg => arg[0]
  else
    []
end Lean.Elab.Term

namespace Lean.Elab.Term
private def getDoSeq (doStx : Syntax) : Syntax :=
  doStx[1]
end Lean.Elab.Term

namespace Lean.Elab.Term
private def liftMethodDelimiter (k : SyntaxNodeKind) : Bool :=
  k == ``Parser.Term.do ||
  k == ``Parser.Term.doSeqIndent ||
  k == ``Parser.Term.doSeqBracketed ||
  k == ``Parser.Term.termReturn ||
  k == ``Parser.Term.termUnless ||
  k == ``Parser.Term.termTry ||
  k == ``Parser.Term.termFor
end Lean.Elab.Term

namespace Lean.Elab.Term
private def letDeclArgHasBinders (letDeclArg : Syntax) : Bool :=
  let k := letDeclArg.getKind
  if k == ``Parser.Term.letPatDecl then
    false
  else if k == ``Parser.Term.letEqnsDecl then
    true
  else if k == ``Parser.Term.letIdDecl then
    
    let binders := letDeclArg[1]
    binders.getNumArgs > 0
  else
    false
end Lean.Elab.Term

namespace Lean.Elab.Term
private def letDeclHasBinders (letDecl : Syntax) : Bool :=
  letDeclArgHasBinders letDecl[0]
end Lean.Elab.Term

namespace Lean.Elab.Term
private def liftMethodForbiddenBinder (stx : Syntax) : Bool :=
  let k := stx.getKind
  
  if k == ``Parser.Term.fun || k == ``Parser.Term.matchAlts ||
     k == ``Parser.Term.doLetRec || k == ``Parser.Term.letrec then
     
    true
  
  else if k == ``Parser.Term.let then
    letDeclHasBinders stx[1]
  else if k == ``Parser.Term.doLet then
    letDeclHasBinders stx[2]
  else if k == ``Parser.Term.doLetArrow then
    letDeclArgHasBinders stx[2]
  else
    false
end Lean.Elab.Term

namespace Lean.Elab.Term
private partial def hasLiftMethod : Syntax → Bool
  | Syntax.node _ k args =>
    if liftMethodDelimiter k then false
    
    
    else if k == ``Parser.Term.liftMethod then true
    
    else if k == ``termDepIfThenElse || k == ``termIfThenElse then args.size >= 2 && hasLiftMethod args[1]!
    else args.any hasLiftMethod
  | _ => false
end Lean.Elab.Term

namespace Lean.Elab.Term
private structure ExtractMonadResult where
  m            : Expr
  returnType   : Expr
  expectedType : Expr
end Lean.Elab.Term

namespace Lean.Elab.Term
private def mkUnknownMonadResult : MetaM ExtractMonadResult := do
  let u ← mkFreshLevelMVar
  let v ← mkFreshLevelMVar
  let m ← mkFreshExprMVar (← mkArrow (mkSort (mkLevelSucc u)) (mkSort (mkLevelSucc v)))
  let returnType ← mkFreshExprMVar (mkSort (mkLevelSucc u))
  return { m, returnType, expectedType := mkApp m returnType }
end Lean.Elab.Term

namespace Lean.Elab.Term
private partial def extractBind (expectedType? : Option Expr) : TermElabM ExtractMonadResult := do
  let some expectedType := expectedType? | mkUnknownMonadResult
  let extractStep? (type : Expr) : MetaM (Option ExtractMonadResult) := do
    let .app m returnType := type | return none
    try
      let bindInstType ← mkAppM ``Bind #[m]
      discard <| Meta.synthInstance bindInstType
      return some { m, returnType, expectedType }
    catch _ =>
      return none
  let rec extract? (type : Expr) : MetaM (Option ExtractMonadResult) := do
    match (← extractStep? type) with
    | some r => return r
    | none =>
      let typeNew ← whnfCore type
      if typeNew != type then
        extract? typeNew
      else
        if typeNew.getAppFn.isMVar then
          mkUnknownMonadResult
        else match (← unfoldDefinition? typeNew) with
          | some typeNew => extract? typeNew
          | none => return none
  match (← extract? expectedType) with
  | some r => return r
  | none   => throwError "invalid `do` notation, expected type is not a monad application{indentExpr expectedType}\nYou can use the `do` notation in pure code by writing `Id.run do` instead of `do`, where `Id` is the identity monad."
end Lean.Elab.Term

namespace Lean.Elab.Term.DoNames
abbrev Var := Syntax  
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
structure Alt (σ : Type) where
  ref      : Syntax
  vars     : Array Var
  patterns : Syntax
  rhs      : σ
  deriving Inhabited
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
structure AltExpr (σ : Type) where
  ref     : Syntax
  var?    : Option Var
  funName : Syntax
  pvars   : Array Syntax
  rhs     : σ
  deriving Inhabited
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def AltExpr.vars (alt : AltExpr σ) : Array Var := Id.run do
  let mut vars := #[]
  if let some var := alt.var? then
    vars := vars.push var
  for pvar in alt.pvars do
    match pvar with
    | `(_) => pure ()
    | _ => vars := vars.push pvar
  return vars
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
inductive Code where
  | decl         (xs : Array Var) (doElem : Syntax) (k : Code)
  | reassign     (xs : Array Var) (doElem : Syntax) (k : Code)
   
  | joinpoint    (name : Name) (params : Array (Var × Bool)) (body : Code) (k : Code)
  | seq          (action : Syntax) (k : Code)
  | action       (action : Syntax)
  | break        (ref : Syntax)
  | continue     (ref : Syntax)
  | return       (ref : Syntax) (val : Syntax)
   
  | ite          (ref : Syntax) (h? : Option Var) (optIdent : Syntax) (cond : Syntax) (thenBranch : Code) (elseBranch : Code)
  | match        (ref : Syntax) (gen : Syntax) (discrs : Syntax) (optMotive : Syntax) (alts : Array (Alt Code))
  | matchExpr    (ref : Syntax) («meta» : Bool) (discr : Syntax) (alts : Array (AltExpr Code)) (elseBranch : Code)
  | jmp          (ref : Syntax) (jpName : Name) (args : Array Syntax)
  deriving Inhabited
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def Code.getRef? : Code → Option Syntax
  | .decl _ doElem _     => doElem
  | .reassign _ doElem _ => doElem
  | .joinpoint ..        => none
  | .seq a _             => a
  | .action a            => a
  | .break ref           => ref
  | .continue ref        => ref
  | .return ref _        => ref
  | .ite ref ..          => ref
  | .match ref ..        => ref
  | .matchExpr ref ..    => ref
  | .jmp ref ..          => ref
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
abbrev VarSet := Std.TreeMap Name Syntax Name.cmp
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
structure CodeBlock where
  code  : Code
  uvars : VarSet := {} 
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def varSetToArray (s : VarSet) : Array Var :=
  s.foldl (fun xs _ x => xs.push x) #[]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def varsToMessageData (vars : Array Var) : MessageData :=
  MessageData.joinSep (vars.toList.map fun n => MessageData.ofName (n.getId.simpMacroScopes)) " "
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def CodeBlock.toMessageData (codeBlock : CodeBlock) : MessageData :=
  let us := MessageData.ofList <| (varSetToArray codeBlock.uvars).toList.map MessageData.ofSyntax
  let rec loop : Code → MessageData
    | .decl xs _ k           => m!"let {varsToMessageData xs} := ...\n{loop k}"
    | .reassign xs _ k       => m!"{varsToMessageData xs} := ...\n{loop k}"
    | .joinpoint n ps body k => m!"let {n.simpMacroScopes} {varsToMessageData (ps.map Prod.fst)} := {indentD (loop body)}\n{loop k}"
    | .seq e k               => m!"{e}\n{loop k}"
    | .action e              => e
    | .ite _ _ _ c t e       => m!"if {c} then {indentD (loop t)}\nelse{loop e}"
    | .jmp _ j xs            => m!"jmp {j.simpMacroScopes} {xs.toList}"
    | .break _               => m!"break {us}"
    | .continue _            => m!"continue {us}"
    | .return _ v            => m!"return {v} {us}"
    | .match _ _ ds _ alts   =>
      m!"match {ds} with"
      ++ alts.foldl (init := m!"") fun acc alt => acc ++ m!"\n| {alt.patterns} => {loop alt.rhs}"
    | .matchExpr _ «meta» d alts elseCode =>
      let r := m!"match_expr {if «meta» then "" else "(meta := false)"} {d} with"
      let r := r ++ alts.foldl (init := m!"") fun acc alt =>
            let acc := acc ++ m!"\n| {if let some var := alt.var? then m!"{var}@" else ""}"
            let acc := acc ++ m!"{alt.funName}"
            let acc := acc ++ alt.pvars.foldl (init := m!"") fun acc pvar => acc ++ m!" {pvar}"
            acc ++ m!" => {loop alt.rhs}"
      r ++ m!"| _ => {loop elseCode}"
  loop codeBlock.code
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def hasExitPointPred (c : Code) (p : Code → Bool) : Bool :=
  let rec loop : Code → Bool
    | .decl _ _ k             => loop k
    | .reassign _ _ k         => loop k
    | .joinpoint _ _ b k      => loop b || loop k
    | .seq _ k                => loop k
    | .ite _ _ _ _ t e        => loop t || loop e
    | .match _ _ _ _ alts     => alts.any (loop ·.rhs)
    | .matchExpr _ _ _ alts e => alts.any (loop ·.rhs) || loop e
    | .jmp ..                 => false
    | c                       => p c
  loop c
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def hasExitPoint (c : Code) : Bool :=
  hasExitPointPred c fun _ => true
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def hasReturn (c : Code) : Bool :=
  hasExitPointPred c fun
    | .return .. => true
    | _ => false
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def hasTerminalAction (c : Code) : Bool :=
  hasExitPointPred c fun
    | .action _ => true
    | _ => false
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def hasBreakContinue (c : Code) : Bool :=
  hasExitPointPred c fun
    | .break _    => true
    | .continue _ => true
    | _ => false
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def hasBreakContinueReturn (c : Code) : Bool :=
  hasExitPointPred c fun
    | .break _    => true
    | .continue _ => true
    | .return _ _ => true
    | _ => false
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkAuxDeclFor {m} [Monad m] [MonadQuotation m] (e : Syntax) (mkCont : Syntax → m Code) : m Code := withRef e <| withFreshMacroScope do
  let y ← `(y)
  let doElem ← `(doElem| let y ← $e:term)
  
  let y ← `(ensure_expected_type% "type mismatch, result value" $y)
  let k ← mkCont y
  return .decl #[y] doElem k
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def convertTerminalActionIntoJmp (code : Code) (jp : Name) (xs : Array Var) : MacroM Code :=
  let rec loop : Code → MacroM Code
    | .decl xs stx k         => return .decl xs stx (← loop k)
    | .reassign xs stx k     => return .reassign xs stx (← loop k)
    | .joinpoint n ps b k    => return .joinpoint n ps (← loop b) (← loop k)
    | .seq e k               => return .seq e (← loop k)
    | .ite ref x? h c t e    => return .ite ref x? h c (← loop t) (← loop e)
    | .action e              => mkAuxDeclFor e fun y =>
      let ref := e
      
      let jmpArgs := xs.push y
      return Code.jmp ref jp jmpArgs
    | .match ref g ds t alts =>
      return .match ref g ds t (← alts.mapM fun alt => do pure { alt with rhs := (← loop alt.rhs) })
    | .matchExpr ref «meta» d alts e => do
      let alts ← alts.mapM fun alt => do pure { alt with rhs := (← loop alt.rhs) }
      let e ← loop e
      return .matchExpr ref «meta» d alts e
    | c => return c
  loop code
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
structure JPDecl where
  name : Name
  params : Array (Var × Bool)
  body : Code
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def attachJP (jpDecl : JPDecl) (k : Code) : Code :=
  Code.joinpoint jpDecl.name jpDecl.params jpDecl.body k
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def attachJPs (jpDecls : Array JPDecl) (k : Code) : Code :=
  jpDecls.foldr attachJP k
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkFreshJP (ps : Array (Var × Bool)) (body : Code) : TermElabM JPDecl := do
  let ps ← if ps.isEmpty then
    let y ← `(y)
    pure #[(y.raw, false)]
  else
    pure ps
  
  
  
  let name ← mkFreshUserName `__do_jp
  pure { name := name, params := ps, body := body }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def addFreshJP (ps : Array (Var × Bool)) (body : Code) : StateRefT (Array JPDecl) TermElabM Name := do
  let jp ← mkFreshJP ps body
  modify fun (jps : Array JPDecl) => jps.push jp
  pure jp.name
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def insertVars (rs : VarSet) (xs : Array Var) : VarSet :=
  xs.foldl (fun rs x => rs.insert x.getId x) rs
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def eraseVars (rs : VarSet) (xs : Array Var) : VarSet :=
  xs.foldl (·.erase ·.getId) rs
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def eraseOptVar (rs : VarSet) (x? : Option Var) : VarSet :=
  match x? with
  | none   => rs
  | some x => rs.insert x.getId x
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkSimpleJmp (ref : Syntax) (rs : VarSet) (c : Code) : StateRefT (Array JPDecl) TermElabM Code := do
  let xs := varSetToArray rs
  let jp ← addFreshJP (xs.map fun x => (x, true)) c
  if xs.isEmpty then
    let unit ← ``(Unit.unit)
    return Code.jmp ref jp #[unit]
  else
    return Code.jmp ref jp xs
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkJmp (ref : Syntax) (rs : VarSet) (val : Syntax) (mkJPBody : Syntax → MacroM Code) : StateRefT (Array JPDecl) TermElabM Code := do
  let xs := varSetToArray rs
  let args := xs.push val
  let yFresh ← withRef ref `(y)
  let ps := xs.map fun x => (x, true)
  let ps := ps.push (yFresh, false)
  let jpBody ← liftMacroM <| mkJPBody yFresh
  let jp ← addFreshJP ps jpBody
  return Code.jmp ref jp args
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def pullExitPointsAux (rs : VarSet) (c : Code) : StateRefT (Array JPDecl) TermElabM Code := do
  match c with
  | .decl xs stx k         => return .decl xs stx (← pullExitPointsAux (eraseVars rs xs) k)
  | .reassign xs stx k     => return .reassign xs stx (← pullExitPointsAux (insertVars rs xs) k)
  | .joinpoint j ps b k    => return .joinpoint j ps (← pullExitPointsAux rs b) (← pullExitPointsAux rs k)
  | .seq e k               => return .seq e (← pullExitPointsAux rs k)
  | .ite ref x? o c t e    => return .ite ref x? o c (← pullExitPointsAux (eraseOptVar rs x?) t) (← pullExitPointsAux (eraseOptVar rs x?) e)
  | .jmp ..                => return  c
  | .break ref             => mkSimpleJmp ref rs (.break ref)
  | .continue ref          => mkSimpleJmp ref rs (.continue ref)
  | .return ref val        => mkJmp ref rs val (fun y => return .return ref y)
  | .action e              =>
    
    mkAuxDeclFor e fun y =>
      let ref := e
      mkJmp ref rs y (fun yFresh => return .action (← ``(Pure.pure $yFresh)))
  | .match ref g ds t alts =>
    let alts ← alts.mapM fun alt => do pure { alt with rhs := (← pullExitPointsAux (eraseVars rs alt.vars) alt.rhs) }
    return .match ref g ds t alts
  | .matchExpr ref «meta» d alts e =>
    let alts ← alts.mapM fun alt => do pure { alt with rhs := (← pullExitPointsAux (eraseVars rs alt.vars) alt.rhs) }
    let e ← pullExitPointsAux rs e
    return .matchExpr ref «meta» d alts e
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def pullExitPoints (c : Code) : TermElabM Code := do
  if hasExitPoint c then
    let (c, jpDecls) ← (pullExitPointsAux {} c).run #[]
    return attachJPs jpDecls c
  else
    return c
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def extendUpdatedVarsAux (c : Code) (ws : VarSet) : TermElabM Code :=
  let rec update (c : Code) : TermElabM Code := do
    match c with
    | .joinpoint j ps b k    => return .joinpoint j ps (← update b) (← update k)
    | .seq e k               => return .seq e (← update k)
    | .match ref g ds t alts =>
      if alts.any fun alt => alt.vars.any fun x => ws.contains x.getId then
        
        pullExitPoints c
      else
        return .match ref g ds t (← alts.mapM fun alt => do pure { alt with rhs := (← update alt.rhs) })
    | .matchExpr ref «meta» d alts e =>
      if alts.any fun alt => alt.vars.any fun x => ws.contains x.getId then
        
        pullExitPoints c
      else
        let alts ← alts.mapM fun alt => do pure { alt with rhs := (← update alt.rhs) }
        let e ← update e
        return .matchExpr ref «meta» d alts e
    | .ite ref none o c t e => return .ite ref none o c (← update t) (← update e)
    | .ite ref (some h) o cond t e =>
      if ws.contains h.getId then
        
        pullExitPoints c
      else
        return Code.ite ref (some h) o cond (← update t) (← update e)
    | .reassign xs stx k => return .reassign xs stx (← update k)
    | .decl xs stx k => do
      if xs.any fun x => ws.contains x.getId then
        
        pullExitPoints c
      else
        return .decl xs stx (← update k)
    | c => return  c
  update c
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
partial def extendUpdatedVars (c : CodeBlock) (ws : VarSet) : TermElabM CodeBlock := do
  if ws.any fun x _ => !c.uvars.contains x then
    
    pure { code := (← extendUpdatedVarsAux c.code ws), uvars := ws }
  else
    pure { c with uvars := ws }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def union (s₁ s₂ : VarSet) : VarSet :=
  s₁.foldl (·.insert ·) s₂
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def homogenize (c₁ c₂ : CodeBlock) : TermElabM (CodeBlock × CodeBlock) := do
  let ws := union c₁.uvars c₂.uvars
  let c₁ ← extendUpdatedVars c₁ ws
  let c₂ ← extendUpdatedVars c₂ ws
  pure (c₁, c₂)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkVarDeclCore (xs : Array Var) (stx : Syntax) (c : CodeBlock) : CodeBlock := {
  code := Code.decl xs stx c.code,
  uvars := eraseVars c.uvars xs
}
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkReassignCore (xs : Array Var) (stx : Syntax) (c : CodeBlock) : TermElabM CodeBlock := do
  let us := c.uvars
  let ws := insertVars us xs
  
  
  let code ← if xs.any fun x => !us.contains x.getId then extendUpdatedVarsAux c.code ws else pure c.code
  pure { code := .reassign xs stx code, uvars := ws }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkSeq (action : Syntax) (c : CodeBlock) : CodeBlock :=
  { c with code := .seq action c.code }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkTerminalAction (action : Syntax) : CodeBlock :=
  { code := .action action }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkReturn (ref : Syntax) (val : Syntax) : CodeBlock :=
  { code := .return ref val }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkBreak (ref : Syntax) : CodeBlock :=
  { code := .break ref }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkContinue (ref : Syntax) : CodeBlock :=
  { code := .continue ref }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkIte (ref : Syntax) (optIdent : Syntax) (cond : Syntax) (thenBranch : CodeBlock) (elseBranch : CodeBlock) : TermElabM CodeBlock := do
  let x? := optIdent.getOptional?
  let (thenBranch, elseBranch) ← homogenize thenBranch elseBranch
  return {
    code  := .ite ref x? optIdent cond thenBranch.code elseBranch.code,
    uvars := thenBranch.uvars,
  }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def mkUnit : MacroM Syntax :=
  ``((⟨⟩ : PUnit))
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def mkPureUnit : MacroM Syntax :=
  ``(pure PUnit.unit)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkPureUnitAction : MacroM CodeBlock := do
  return mkTerminalAction (← mkPureUnit)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkUnless (cond : Syntax) (c : CodeBlock) : MacroM CodeBlock := do
  let thenBranch ← mkPureUnitAction
  return { c with code := .ite (← getRef) none mkNullNode cond thenBranch.code c.code }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkMatch (ref : Syntax) (genParam : Syntax) (discrs : Syntax) (optMotive : Syntax) (alts : Array (Alt CodeBlock)) : TermElabM CodeBlock := do
  
  let ws := alts.foldl (union · ·.rhs.uvars) {}
  let alts ← alts.mapM fun alt => do
    let rhs ← extendUpdatedVars alt.rhs ws
    return { ref := alt.ref, vars := alt.vars, patterns := alt.patterns, rhs := rhs.code : Alt Code }
  return { code := .match ref genParam discrs optMotive alts, uvars := ws }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkMatchExpr (ref : Syntax) («meta» : Bool) (discr : Syntax) (alts : Array (AltExpr CodeBlock)) (elseBranch : CodeBlock) : TermElabM CodeBlock := do
  
  let ws := alts.foldl (union · ·.rhs.uvars) {}
  let ws := union ws elseBranch.uvars
  let alts ← alts.mapM fun alt => do
    let rhs ← extendUpdatedVars alt.rhs ws
    return { alt with rhs := rhs.code : AltExpr Code }
  let elseBranch ← extendUpdatedVars elseBranch ws
  return { code := .matchExpr ref «meta» discr alts elseBranch.code, uvars := ws }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def concat (terminal : CodeBlock) (kRef : Syntax) (y? : Option Var) (k : CodeBlock) : TermElabM CodeBlock := do
  unless hasTerminalAction terminal.code do
    throwErrorAt kRef "`do` element is unreachable"
  let (terminal, k) ← homogenize terminal k
  let xs := varSetToArray k.uvars
  let y ← match y? with | some y => pure y | none => `(y)
  let ps := xs.map fun x => (x, true)
  let ps := ps.push (y, false)
  let jpDecl ← mkFreshJP ps k.code
  let jp := jpDecl.name
  let terminal ← liftMacroM <| convertTerminalActionIntoJmp terminal.code jp xs
  return { code  := attachJP jpDecl terminal, uvars := k.uvars }
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getLetIdVars (letId : Syntax) : Array Var :=
  assert! letId.isOfKind ``Parser.Term.letId
  
  if letId[0].isIdent then
    #[letId[0]]
  else if letId[0].isOfKind hygieneInfoKind then
    #[HygieneInfo.mkIdent letId[0] `this (canonical := true)]
  else
    #[]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getLetIdDeclVars (letIdDecl : Syntax) : Array Var :=
  assert! letIdDecl.isOfKind ``Parser.Term.letIdDecl
  
  
  getLetIdVars letIdDecl[0]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getPatternVarsEx (pattern : Syntax) : TermElabM (Array Var) :=
  getPatternVars pattern <|>
  Quotation.getPatternVars pattern
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getPatternsVarsEx (patterns : Array Syntax) : TermElabM (Array Var) :=
  getPatternsVars patterns <|>
  Quotation.getPatternsVars patterns
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getLetPatDeclVars (letPatDecl : Syntax) : TermElabM (Array Var) := do
  
  let pattern := letPatDecl[0]
  getPatternVarsEx pattern
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getLetEqnsDeclVars (letEqnsDecl : Syntax) : Array Var :=
  assert! letEqnsDecl.isOfKind ``Parser.Term.letEqnsDecl
  
  
  getLetIdVars letEqnsDecl[0]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getLetDeclVars (letDecl : Syntax) : TermElabM (Array Var) := do
  
  let arg := letDecl[0]
  if arg.getKind == ``Parser.Term.letIdDecl then
    return getLetIdDeclVars arg
  else if arg.getKind == ``Parser.Term.letPatDecl then
    getLetPatDeclVars arg
  else if arg.getKind == ``Parser.Term.letEqnsDecl then
    return getLetEqnsDeclVars arg
  else
    throwError "unexpected kind of let declaration"
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoLetVars (doLet : Syntax) : TermElabM (Array Var) :=
  
  getLetDeclVars doLet[2]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoHaveVars (doHave : Syntax) : TermElabM (Array Var) :=
  
  getLetDeclVars doHave[1]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoLetRecVars (doLetRec : Syntax) : TermElabM (Array Var) := do
  
  let letRecDecls := doLetRec[1][0].getSepArgs
  let letDecls := letRecDecls.map fun p => p[2]
  let mut allVars := #[]
  for letDecl in letDecls do
    let vars ← getLetDeclVars letDecl
    allVars := allVars ++ vars
  return allVars
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoIdDeclVar (doIdDecl : Syntax) : Var :=
  doIdDecl[0]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoPatDeclVars (doPatDecl : Syntax) : TermElabM (Array Var) := do
  let pattern := doPatDecl[0]
  getPatternVarsEx pattern
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoLetArrowVars (doLetArrow : Syntax) : TermElabM (Array Var) := do
  let decl := doLetArrow[2]
  if decl.getKind == ``Parser.Term.doIdDecl then
    return #[getDoIdDeclVar decl]
  else if decl.getKind == ``Parser.Term.doPatDecl then
    getDoPatDeclVars decl
  else
    throwError "unexpected kind of `do` declaration"
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def getDoReassignVars (doReassign : Syntax) : TermElabM (Array Var) := do
  let arg := doReassign[0]
  if arg.getKind == ``Parser.Term.letIdDecl then
    return getLetIdDeclVars arg
  else if arg.getKind == ``Parser.Term.letPatDecl then
    getLetPatDeclVars arg
  else
    throwError "unexpected kind of reassignment"
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def mkDoSeq (doElems : Array Syntax) : Syntax :=
  mkNode `Lean.Parser.Term.doSeqIndent #[mkNullNode <| doElems.map fun doElem => mkNullNode #[doElem, mkNullNode]]
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def expandDoIf? (stx : Syntax) : MacroM (Option Syntax) := match stx with
  | `(doElem|if $_:doIfProp then $_ else $_) => pure none
  | `(doElem|if $cond:doIfCond then $t $[else if $conds:doIfCond then $ts]* $[else $e?]?) => withRef stx do
    let mut e      := e?.getD (← `(doSeq|pure PUnit.unit))
    let mut eIsSeq := true
    for (cond, t) in Array.zip (conds.reverse.push cond) (ts.reverse.push t) do
      e ← if eIsSeq then pure e else `(doSeq|$e:doElem)
      e ← match cond with
        | `(doIfCond|let $pat := $d) => `(doElem| match $d:term with | $pat:term => $t | _ => $e)
        | `(doIfCond|let $pat ← $d)  => `(doElem| match ← $d    with | $pat:term => $t | _ => $e)
        | `(doIfCond|$cond:doIfProp) => `(doElem| if $cond:doIfProp then $t else $e)
        | _                          => `(doElem| if $(Syntax.missing) then $t else $e)
      eIsSeq := false
    return some e
  | _ => pure none
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def expandDoLetExpr? (stx : Syntax) (doElems : List Syntax) : MacroM (Option Syntax) := match stx with
  | `(doElem| let_expr $pat:matchExprPat := $discr:term | $elseBranch:doSeq) =>
    return some (← `(doElem| match_expr (meta := false) $discr:term with
                             | $pat:matchExprPat => $(mkDoSeq doElems.toArray)
                             | _ => $elseBranch))
  | `(doElem| let_expr $pat:matchExprPat ← $discr:term | $elseBranch:doSeq) =>
    return some (← `(doElem| match_expr $discr:term with
                             | $pat:matchExprPat => $(mkDoSeq doElems.toArray)
                             | _ => $elseBranch))
  | _ => return none
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
structure DoIfView where
  ref        : Syntax
  optIdent   : Syntax
  cond       : Syntax
  thenBranch : Syntax
  elseBranch : Syntax
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def mkDoIfView (doIf : Syntax) : DoIfView := {
  ref        := doIf
  optIdent   := doIf[1][0]
  cond       := doIf[1][1]
  thenBranch := doIf[3]
  elseBranch := doIf[5][1]
}
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def mkTuple (elems : Array Syntax) : MacroM Syntax := do
  if elems.size = 0 then
    mkUnit
  else if h : elems.size = 1 then
    ``(WithName.mk' $(elems[0]) $(Lean.quoteNameMk elems[0].getId))
  else
    let init <- ``(WithName.mk' $(elems.back!) $(Lean.quoteNameMk elems.back!.getId))
    elems.extract 0 (elems.size - 1) |>.foldrM (init := init) fun elem tuple => do
      let name := Lean.quoteNameMk elem.getId
      ``(MProdWithNames.mk' $elem $tuple $name)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def mkTuplePat (elems : Array Syntax) : MacroM Syntax := do
  if elems.size = 0 then
    mkUnit
  else if h : elems.size = 1 then
    return elems[0]
  else
    elems.extract 0 (elems.size - 1) |>.foldrM (init := elems.back!) fun elem tuple => do
        ``(MProdWithNames.mk $elem $tuple)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def isDoExpr? (doElem : Syntax) : Option Syntax :=
  if doElem.getKind == ``Parser.Term.doExpr then
    some doElem[0]
  else
    none
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
private def destructTuple (uvars : Array Var) (x : Syntax) (body : Syntax) : MacroM Syntax := do
  if uvars.size = 0 then
    return body
  else if h : uvars.size = 1 then
    `(let $(uvars[0]):ident := WithName.erase $x; $body)
  else
    destruct uvars.toList x body
where
  destruct (as : List Var) (x : Syntax) (body : Syntax) : MacroM Syntax := do
    match as with
      | [a, b]  => `(let $a:ident := $x.1; let $b:ident := WithName.erase $x.2; $body)
      | a :: as => withFreshMacroScope do
        let rest ← destruct as (← `(x)) body
        `(let $a:ident := $x.1; let x := $x.2; $rest)
      | _ => unreachable!
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames
def annotate [Monad m] [MonadRef m] [MonadQuotation m] (ref : Syntax) (term : Syntax) : m Syntax :=
  withRef term <| `(with_annotate_term $ref $term)
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames.ToTerm
inductive Kind where
  | regular
  | forIn
  | forInWithReturn
  | nestedBC
  | nestedPR
  | nestedSBC
  | nestedPRBC
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
instance : Inhabited Kind := ⟨Kind.regular⟩
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def Kind.isRegular : Kind → Bool
  | .regular => true
  | _        => false
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
structure Context where
   
  m          : Syntax
   
  returnType : Syntax
  uvars      : Array Var
  kind       : Kind
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
abbrev M := ReaderT Context MacroM
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkUVarTuple : M Syntax := do
  let ctx ← read
  mkTuple ctx.uvars
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def returnToTerm (val : Syntax) : M Syntax := do
  let ctx ← read
  let u ← mkUVarTuple
  match ctx.kind with
  | .regular         => if ctx.uvars.isEmpty then ``(Pure.pure $val) else ``(Pure.pure (MProdWithNames.mk $val $u))
  | .forIn           => ``(Pure.pure (ForInStep.done $u))
  | .forInWithReturn => ``(Pure.pure (ForInStep.done (MProdWithNames.mk (some $val) $u)))
  | .nestedBC        => unreachable!
  | .nestedPR        => ``(Pure.pure (DoResultPR.«return» $val $u))
  | .nestedSBC       => ``(Pure.pure (DoResultSBC.«pureReturn» $val $u))
  | .nestedPRBC      => ``(Pure.pure (DoResultPRBC.«return» $val $u))
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def continueToTerm : M Syntax := do
  let ctx ← read
  let u ← mkUVarTuple
  match ctx.kind with
  | .regular         => unreachable!
  | .forIn           => ``(Pure.pure (ForInStep.yield $u))
  | .forInWithReturn => ``(Pure.pure (ForInStep.yield (MProdWithNames.mk none $u)))
  | .nestedBC        => ``(Pure.pure (DoResultBC.«continue» $u))
  | .nestedPR        => unreachable!
  | .nestedSBC       => ``(Pure.pure (DoResultSBC.«continue» $u))
  | .nestedPRBC      => ``(Pure.pure (DoResultPRBC.«continue» $u))
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def breakToTerm : M Syntax := do
  let ctx ← read
  let u ← mkUVarTuple
  match ctx.kind with
  | .regular         => unreachable!
  | .forIn           => ``(Pure.pure (ForInStep.done $u))
  | .forInWithReturn => ``(Pure.pure (ForInStep.done (MProdWithNames.mk none $u)))
  | .nestedBC        => ``(Pure.pure (DoResultBC.«break» $u))
  | .nestedPR        => unreachable!
  | .nestedSBC       => ``(Pure.pure (DoResultSBC.«break» $u))
  | .nestedPRBC      => ``(Pure.pure (DoResultPRBC.«break» $u))
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def actionTerminalToTerm (action : Syntax) : M Syntax := withRef action <| withFreshMacroScope do
  let ctx ← read
  let u ← mkUVarTuple
  match ctx.kind with
  | .regular         => if ctx.uvars.isEmpty then pure action else ``(Bind.bind $action fun y => Pure.pure (MProdWithNames.mk y $u))
  | .forIn           => ``(Bind.bind $action fun (_ : PUnit) => Pure.pure (ForInStep.yield $u))
  | .forInWithReturn => ``(Bind.bind $action fun (_ : PUnit) => Pure.pure (ForInStep.yield (MProdWithNames.mk none $u)))
  | .nestedBC        => unreachable!
  | .nestedPR        => ``(Bind.bind $action fun y => (Pure.pure (DoResultPR.«pure» y $u)))
  | .nestedSBC       => ``(Bind.bind $action fun y => (Pure.pure (DoResultSBC.«pureReturn» y $u)))
  | .nestedPRBC      => ``(Bind.bind $action fun y => (Pure.pure (DoResultPRBC.«pure» y $u)))
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def seqToTerm (action : Syntax) (k : Syntax) : M Syntax := withRef action <| withFreshMacroScope do
  if action.getKind == ``Parser.Term.doDbgTrace then
    let msg := action[1]
    `(dbg_trace $msg; $k)
  else if action.getKind == ``Parser.Term.doAssert then
    let cond := action[1]
    `(assert! $cond; $k)
  else if action.getKind == ``Parser.Term.doDebugAssert then
    let cond := action[1]
    `(debugAssert| debug_assert! $cond; $k)
  else
    let action ← withRef action ``(($action : $((←read).m) PUnit))
    ``(Bind.bind $action (fun (_ : PUnit) => $k))
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def declToTerm (decl : Syntax) (k : Syntax) : M Syntax := withRef decl <| withFreshMacroScope do
  let kind := decl.getKind
  if kind == ``Parser.Term.doLet then
    let letDecl := decl[2]
    `(let $letDecl:letDecl; $k)
  else if kind == ``Parser.Term.doLetRec then
    let letRecToken := decl[0]
    let letRecDecls := decl[1]
    return mkNode ``Parser.Term.letrec #[letRecToken, letRecDecls, mkNullNode, k]
  else if kind == ``Parser.Term.doLetArrow then
    let arg := decl[2]
    if arg.getKind == ``Parser.Term.doIdDecl then
      let id     := arg[0]
      let type   := expandOptType id arg[1]
      let doElem := arg[3]
      
      match isDoExpr? doElem with
      | some action =>
        let action ← withRef action `(($action : $((← read).m) $type))
        ``(Bind.bind $action (fun ($id:ident : $type) => $k))
      | none        => Macro.throwErrorAt decl "unexpected kind of `do` declaration"
    else
      Macro.throwErrorAt decl "unexpected kind of `do` declaration"
  else if kind == ``Parser.Term.doHave then
    
    let args := decl.getArgs
    let args := args ++ #[mkNullNode  , k]
    return mkNode `Lean.Parser.Term.«have» args
  else
    Macro.throwErrorAt decl "unexpected kind of `do` declaration"
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def reassignToTerm (reassign : Syntax) (k : Syntax) : MacroM Syntax := withRef reassign <| withFreshMacroScope do
  match reassign with
  | `(doElem| $x:ident := $rhs) => `(let $x:ident := ensure_type_of% $x $(quote "invalid reassignment, value") $rhs; $k)
  | `(doElem| $e:term  := $rhs) => `(let $e:term  := ensure_type_of% $e $(quote "invalid reassignment, value") $rhs; $k)
  | _ =>
    
    Macro.throwErrorAt reassign "unexpected kind of `do` reassignment"
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkIte (optIdent : Syntax) (cond : Syntax) (thenBranch : Syntax) (elseBranch : Syntax) : MacroM Syntax := do
  if optIdent.isNone then
    ``(if $cond then $thenBranch else $elseBranch)
  else
    let h := optIdent[0]
    ``(if $h:ident : $cond then $thenBranch else $elseBranch)
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkJoinPoint (j : Name) (ps : Array (Syntax × Bool)) (body : Syntax) (k : Syntax) : M Syntax := withRef body <| withFreshMacroScope do
  let pTypes ← ps.mapM fun ⟨id, useTypeOf⟩ => do if useTypeOf then `(type_of% $id) else `(_)
  let ps     := ps.map (·.1)
   
  `(let_delayed $(← mkIdentFromRef j):ident $[($ps : $pTypes)]* : $((← read).m) _ := $body; $k)
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkJmp (ref : Syntax) (j : Name) (args : Array Syntax) : Syntax :=
  Syntax.mkApp (mkIdentFrom ref j) args
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
partial def toTerm (c : Code) : M Syntax := do
  let term ← go c
  if let some ref := c.getRef? then
    annotate ref term
  else
    return term
where
  go (c : Code) : M Syntax := do
    match c with
    | .return ref val     => withRef ref <| returnToTerm val
    | .continue ref       => withRef ref continueToTerm
    | .break ref          => withRef ref breakToTerm
    | .action e           => actionTerminalToTerm e
    | .joinpoint j ps b k => mkJoinPoint j ps (← toTerm b) (← toTerm k)
    | .jmp ref j args     => return mkJmp ref j args
    | .decl _ stx k       => declToTerm stx (← toTerm k)
    | .reassign _ stx k   => reassignToTerm stx (← toTerm k)
    | .seq stx k          => seqToTerm stx (← toTerm k)
    | .ite ref _ o c t e  => withRef ref <| do mkIte o c (← toTerm t) (← toTerm e)
    | .match ref genParam discrs optMotive alts =>
      let mut termAlts := #[]
      for alt in alts do
        let rhs ← toTerm alt.rhs
        let termAlt := mkNode ``Parser.Term.matchAlt #[mkAtomFrom alt.ref "|", mkNullNode #[alt.patterns], mkAtomFrom alt.ref "=>", rhs]
        termAlts := termAlts.push termAlt
      let termMatchAlts := mkNode ``Parser.Term.matchAlts #[mkNullNode termAlts]
      return mkNode ``Parser.Term.«match» #[mkAtomFrom ref "match", genParam, optMotive, discrs, mkAtomFrom ref "with", termMatchAlts]
    | .matchExpr ref «meta» d alts elseBranch => withFreshMacroScope do
      let d' ← `(discr)
      let mut termAlts := #[]
      for alt in alts do
        let rhs ← `(($(← toTerm alt.rhs) : $((← read).m) _))
        let optVar := if let some var := alt.var? then mkNullNode #[var, mkAtomFrom var "@"] else mkNullNode #[]
        let pat := mkNode ``Parser.Term.matchExprPat #[optVar, alt.funName, mkNullNode alt.pvars]
        let termAlt := mkNode ``Parser.Term.matchExprAlt #[mkAtomFrom alt.ref "|", pat, mkAtomFrom alt.ref "=>", rhs]
        termAlts := termAlts.push termAlt
      let elseBranch := mkNode ``Parser.Term.matchExprElseAlt #[mkAtomFrom ref "|", mkHole ref, mkAtomFrom ref "=>", (← toTerm elseBranch)]
      let termMatchExprAlts := mkNode ``Parser.Term.matchExprAlts #[mkNullNode termAlts, elseBranch]
      let body := mkNode ``Parser.Term.matchExpr #[mkAtomFrom ref "match_expr", d', mkAtomFrom ref "with", termMatchExprAlts]
      if «meta» then
        `(Bind.bind (instantiateMVarsIfMVarApp $d) fun discr => $body)
      else
        `(let discr := $d; $body)
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def run (code : Code) (m : Syntax) (returnType : Syntax) (uvars : Array Var := #[]) (kind := Kind.regular) : MacroM Syntax :=
  toTerm code { m, returnType, kind, uvars }
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkNestedKind (a r bc : Bool) : Kind :=
  match a, r, bc with
  | true,  false, false => .regular
  | false, true,  false => .regular
  | false, false, true  => .nestedBC
  | true,  true,  false => .nestedPR
  | true,  false, true  => .nestedSBC
  | false, true,  true  => .nestedSBC
  | true,  true,  true  => .nestedPRBC
  | false, false, false => unreachable!
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def mkNestedTerm (code : Code) (m : Syntax) (returnType : Syntax) (uvars : Array Var) (a r bc : Bool) : MacroM Syntax := do
  ToTerm.run code m returnType uvars (mkNestedKind a r bc)
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames.ToTerm
def matchNestedTermResult (term : Syntax) (uvars : Array Var) (a r bc : Bool) : MacroM (List Syntax) := do
  let toDoElems (auxDo : Syntax) : List Syntax := getDoSeqElems (getDoSeq auxDo)
  let u ← mkTuplePat uvars
  match a, r, bc with
  | true, false, false =>
    if uvars.isEmpty then
      return toDoElems (← `(do $term:term))
    else
      return toDoElems (← `(do let r ← $term:term; $u:term := r.2; pure r.1))
  | false, true, false =>
    if uvars.isEmpty then
      return toDoElems (← `(do let r ← $term:term; return r))
    else
      return toDoElems (← `(do let r ← $term:term; $u:term := r.2; return r.1))
  | false, false, true => toDoElems <$>
    `(do let r ← $term:term;
         match r with
         | .break u => $u:term := u; break
         | .continue u => $u:term := u; continue)
  | true, true, false => toDoElems <$>
    `(do let r ← $term:term;
         match r with
         | .pure a u => $u:term := u; pure a
         | .return b u => $u:term := u; return b)
  | true, false, true => toDoElems <$>
    `(do let r ← $term:term;
         match r with
         | .pureReturn a u => $u:term := u; pure a
         | .break u => $u:term := u; break
         | .continue u => $u:term := u; continue)
  | false, true, true => toDoElems <$>
    `(do let r ← $term:term;
         match r with
         | .pureReturn a u => $u:term := u; return a
         | .break u => $u:term := u; break
         | .continue u => $u:term := u; continue)
  | true, true, true => toDoElems <$>
    `(do let r ← $term:term;
         match r with
         | .pure a u => $u:term := u; pure a
         | .return a u => $u:term := u; return a
         | .break u => $u:term := u; break
         | .continue u => $u:term := u; continue)
  | false, false, false => unreachable!
end Lean.Elab.Term.DoNames.ToTerm

namespace Lean.Elab.Term.DoNames
def isMutableLet (doElem : Syntax) : Bool :=
  let kind := doElem.getKind
  (kind == ``doLetArrow || kind == ``doLet || kind == ``doLetElse)
  &&
  !doElem[1].isNone
end Lean.Elab.Term.DoNames

namespace Lean.Elab.Term.DoNames.ToCodeBlock
structure Context where
  ref         : Syntax
   
  m           : Syntax
   
  returnType  : Syntax
  mutableVars : VarSet := {}
  insideFor   : Bool := false
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
abbrev M := ReaderT Context TermElabM
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def withNewMutableVars {α} (newVars : Array Var) (mutable : Bool) (x : M α) : M α :=
  withReader (fun ctx => if mutable then { ctx with mutableVars := insertVars ctx.mutableVars newVars } else ctx) x
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def checkReassignable (xs : Array Var) : M Unit := do
  let throwInvalidReassignment (x : Name) : M Unit :=
    throwError "`{x.simpMacroScopes}` cannot be mutated, only variables declared using `let mut` can be mutated. If you did not intend to mutate but define `{x.simpMacroScopes}`, consider using `let {x.simpMacroScopes}` instead"
  let ctx ← read
  for x in xs do
    unless ctx.mutableVars.contains x.getId do
      throwInvalidReassignment x.getId
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def checkNotShadowingMutable (xs : Array Var) : M Unit := do
  let throwInvalidShadowing (x : Name) : M Unit :=
    throwError "mutable variable `{x.simpMacroScopes}` cannot be shadowed"
  let ctx ← read
  for x in xs do
    if ctx.mutableVars.contains x.getId then
      withRef x <| throwInvalidShadowing x.getId
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def withFor {α} (x : M α) : M α :=
  withReader (fun ctx => { ctx with insideFor := true }) x
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
structure ToForInTermResult where
  uvars      : Array Var
  term       : Syntax
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def mkForInBody  (_ : Syntax) (forInBody : CodeBlock) : M ToForInTermResult := do
  let ctx ← read
  let uvars := forInBody.uvars
  let uvars := varSetToArray uvars
  let term ← liftMacroM <| ToTerm.run forInBody.code ctx.m ctx.returnType uvars (if hasReturn forInBody.code then ToTerm.Kind.forInWithReturn else ToTerm.Kind.forIn)
  return ⟨uvars, term⟩
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def ensureInsideFor : M Unit :=
  unless (← read).insideFor do
    throwError "invalid `do` element, it must be inside `for`"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def ensureEOS (doElems : List Syntax) : M Unit :=
  unless doElems.isEmpty do
    throwError "must be last element in a `do` sequence"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
private partial def expandLiftMethodAux (inQuot : Bool) (inBinder : Bool) : Syntax → StateT (List Syntax) M Syntax
  | stx@(Syntax.node i k args) =>
    if k == choiceKind then do
      
      let alts ← stx.getArgs.mapM (expandLiftMethodAux inQuot inBinder · |>.run [])
      let (_, lifts) := alts[0]!
      unless alts.all (·.2 == lifts) do
        throwErrorAt stx "cannot lift `(<- ...)` over inconsistent syntax variants, consider lifting out the binding manually"
      modify (· ++ lifts)
      return .node i k (alts.map (·.1))
    else if liftMethodDelimiter k then
      return stx
    
    else if h : args.size >= 2 ∧ (k == ``termDepIfThenElse || k == ``termIfThenElse) then do
      let inAntiquot := stx.isAntiquot && !stx.isEscapedAntiquot
      let arg1 ← expandLiftMethodAux (inQuot && !inAntiquot || stx.isQuot) inBinder args[1]
      let args := args.set! 1 arg1
      return Syntax.node i k args
    else if k == ``Parser.Term.liftMethod && !inQuot then withFreshMacroScope do
      if inBinder then
        throwErrorAt stx "cannot lift `(<- ...)` over a binder, this error usually happens when you are trying to lift a method nested in a `fun`, `let`, or `match`-alternative, and it can often be fixed by adding a missing `do`"
      let term := args[1]!
      let term ← expandLiftMethodAux inQuot inBinder term
      
      let id ← mkIdentFromRef (.num baseId (← get).length)
      let auxDoElem : Syntax ← `(doElem| let $id:ident ← $term:term)
      modify fun s => s ++ [auxDoElem]
      return id
    else do
      let inAntiquot := stx.isAntiquot && !stx.isEscapedAntiquot
      let inBinder   := inBinder || (!inQuot && liftMethodForbiddenBinder stx)
      let args ← args.mapM (expandLiftMethodAux (inQuot && !inAntiquot || stx.isQuot) inBinder)
      return Syntax.node i k args
  | stx => return stx
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def expandLiftMethod (doElem : Syntax) : M (List Syntax × Syntax) := do
  if !hasLiftMethod doElem then
    return ([], doElem)
  else
    let baseId ← withFreshMacroScope (MonadQuotation.addMacroScope `__do_lift)
    let (doElem, doElemsNew) ← (expandLiftMethodAux baseId false false doElem).run []
    return (doElemsNew, doElem)
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def checkLetArrowRHS (doElem : Syntax) : M Unit := do
  let kind := doElem.getKind
  if kind == ``Parser.Term.doLetArrow ||
     kind == ``Parser.Term.doLet ||
     kind == ``Parser.Term.doLetRec ||
     kind == ``Parser.Term.doHave ||
     kind == ``Parser.Term.doReassign ||
     kind == ``Parser.Term.doReassignArrow then
    throwErrorAt doElem "invalid kind of value `{kind}` in an assignment"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def doReturnToCode (doReturn : Syntax) (doElems: List Syntax) : M CodeBlock := withRef doReturn do
  ensureEOS doElems
  let argOpt := doReturn[1]
  let arg ← if argOpt.isNone then liftMacroM mkUnit else pure argOpt[0]
  return mkReturn (← getRef) arg
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
structure Catch where
  x         : Syntax
  optType   : Syntax
  codeBlock : CodeBlock
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def getTryCatchUpdatedVars (tryCode : CodeBlock) (catches : Array Catch) (finallyCode? : Option CodeBlock) : VarSet :=
  let ws := tryCode.uvars
  let ws := catches.foldl (init := ws) fun ws alt => union alt.codeBlock.uvars ws
  let ws := match finallyCode? with
    | none   => ws
    | some c => union c.uvars ws
  ws
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def tryCatchPred (tryCode : CodeBlock) (catches : Array Catch) (finallyCode? : Option CodeBlock) (p : Code → Bool) : Bool :=
  p tryCode.code ||
  catches.any (fun «catch» => p «catch».codeBlock.code) ||
  match finallyCode? with
  | none => false
  | some finallyCode => p finallyCode.code
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def concatWith (c : CodeBlock) (doElems : List Syntax) : M CodeBlock :=
    match doElems with
    | [] => pure c
    | nextDoElem :: _  => do
      let k ← doSeqToCode doElems
      let ref := nextDoElem
      concat c ref none k
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doLetArrowToCode (doLetArrow : Syntax) (doElems : List Syntax) : M CodeBlock := do
    let decl    := doLetArrow[2]
    if decl.getKind == ``Parser.Term.doIdDecl then
      let y := decl[0]
      checkNotShadowingMutable #[y]
      let doElem := decl[3]
      let k ← withNewMutableVars #[y] (isMutableLet doLetArrow) (doSeqToCode doElems)
      match isDoExpr? doElem with
      | some _      => return mkVarDeclCore #[y] doLetArrow k
      | none =>
        checkLetArrowRHS doElem
        let c ← doSeqToCode [doElem]
        match doElems with
        | []       => pure c
        | kRef::_  => concat c kRef y k
    else if decl.getKind == ``Parser.Term.doPatDecl then
      let pattern := decl[0]
      let doElem  := decl[2]
      let optElse := decl[3]
      if optElse.isNone then withFreshMacroScope do
        let auxDo ← if isMutableLet doLetArrow then
          `(do let%$doLetArrow __discr ← $doElem; let%$doLetArrow mut $pattern:term := __discr)
        else
          `(do let%$doLetArrow __discr ← $doElem; let%$doLetArrow $pattern:term := __discr)
        doSeqToCode <| getDoSeqElems (getDoSeq auxDo) ++ doElems
      else
        let contSeq ← if isMutableLet doLetArrow then
          let vars ← (← getPatternVarsEx pattern).mapM fun var => `(doElem| let mut $var := $var)
          pure (vars ++ doElems.toArray)
        else
          pure doElems.toArray
        let contSeq := mkDoSeq contSeq
        let elseSeq := optElse[1]
        let auxDo ← `(do let%$doLetArrow __discr ← $doElem; match%$doLetArrow __discr with | $pattern:term => $contSeq | _ => $elseSeq)
        doSeqToCode <| getDoSeqElems (getDoSeq auxDo)
    else
      throwError "unexpected kind of `do` declaration"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doLetElseToCode (doLetElse : Syntax) (doElems : List Syntax) : M CodeBlock := do
    
    let pattern := doLetElse[2]
    let val     := doLetElse[4]
    let elseSeq := doLetElse[6]
    let contSeq ← if isMutableLet doLetElse then
      let vars ← (← getPatternVarsEx pattern).mapM fun var => `(doElem| let mut $var := $var)
      pure (vars ++ doElems.toArray)
    else
      pure doElems.toArray
    let contSeq := mkDoSeq contSeq
    let auxDo ← `(do match $val:term with | $pattern:term => $contSeq | _ => $elseSeq)
    doSeqToCode <| getDoSeqElems (getDoSeq auxDo)
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doReassignArrowToCode (doReassignArrow : Syntax) (doElems : List Syntax) : M CodeBlock := do
    let decl := doReassignArrow[0]
    if decl.getKind == ``Parser.Term.doIdDecl then
      let doElem := decl[3]
      let y      := decl[0]
      let auxDo ← `(do let r ← $doElem; $y:ident := r)
      doSeqToCode <| getDoSeqElems (getDoSeq auxDo) ++ doElems
    else if decl.getKind == ``Parser.Term.doPatDecl then
      let pattern := decl[0]
      let doElem  := decl[2]
      let optElse := decl[3]
      if optElse.isNone then withFreshMacroScope do
        let auxDo ← `(do let __discr ← $doElem; $pattern:term := __discr)
        doSeqToCode <| getDoSeqElems (getDoSeq auxDo) ++ doElems
      else
        throwError "reassignment with `|` (i.e., \"else clause\") is not currently supported"
    else
      throwError "unexpected kind of `do` reassignment"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doIfToCode (doIf : Syntax) (doElems : List Syntax) : M CodeBlock := do
    let view := mkDoIfView doIf
    let thenBranch ← doSeqToCode (getDoSeqElems view.thenBranch)
    let elseBranch ← doSeqToCode (getDoSeqElems view.elseBranch)
    let ite ← mkIte view.ref view.optIdent view.cond thenBranch elseBranch
    concatWith ite doElems
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doUnlessToCode (doUnless : Syntax) (doElems : List Syntax) : M CodeBlock := withRef doUnless do
    let cond  := doUnless[1]
    let doSeq := doUnless[3]
    let body ← doSeqToCode (getDoSeqElems doSeq)
    let unlessCode ← liftMacroM <| mkUnless cond body
    concatWith unlessCode doElems
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doForToCode (doFor : Syntax) (doElems : List Syntax) : M CodeBlock := do
    let doForDecls := doFor[1].getSepArgs
    if h : doForDecls.size > 1 then
       
      
      let doForDecl := doForDecls[1]!
      unless doForDecl[0].isNone do
        throwErrorAt doForDecl[0] "the proof annotation here has not been implemented yet"
      let y  := doForDecl[1]
      let ys := doForDecl[3]
      let doForDecls := doForDecls.eraseIdx 1
      let body := doFor[3]
      withFreshMacroScope do
         
        let toStreamApp ← withRef ys `(@toStream _ _ _ $ys)
        let auxDo ←
          `(do let mut s := $toStreamApp:term
               for $doForDecls:doForDecl,* do
                 match @Stream.next? _ _ _ s with
                 | none => break
                 | some ($y, s') =>
                   s := s'
                   do $body)
        doSeqToCode (getDoSeqElems (getDoSeq auxDo) ++ doElems)
    else withRef doFor do
      let h?        := if doForDecls[0]![0].isNone then none else some doForDecls[0]![0][0]
      let x         := doForDecls[0]![1]
      withRef x <| checkNotShadowingMutable (← getPatternVarsEx x)
      let xs        := doForDecls[0]![3]
      let forElems  := getDoSeqElems doFor[3]
      let forInBodyCodeBlock ← withFor (doSeqToCode forElems)
      let ⟨uvars, forInBody⟩ ← mkForInBody x forInBodyCodeBlock
      let ctx ← read
      
      
      
      let uvars := uvars.map fun v => ctx.mutableVars.getD v.getId v
      let uvarsTuple ← liftMacroM do mkTuple uvars
      let uvarsTuplePat ← liftMacroM do mkTuplePat uvars

      if hasReturn forInBodyCodeBlock.code then
        let forInBody ← liftMacroM <| destructTuple uvars (← `(r)) forInBody
        let optType ← `(Option $((← read).returnType))
        let forInTerm ← if let some h := h? then
          annotate doFor
            (← `(for_in'% $(xs) (MProdWithNames.mk (none : $optType) $uvarsTuple) fun $x $h (r : MProdWithNames $optType _) => let r := r.2; $forInBody))
        else
          annotate doFor
            (← `(for_in% $(xs) (MProdWithNames.mk (none : $optType) $uvarsTuple) fun $x (r : MProdWithNames $optType _) => let r := r.2; $forInBody))
        let auxDo ← `(do let r ← $forInTerm:term;
                         $uvarsTuplePat:term := r.2;
                         match r.1 with
                         | none => Pure.pure (ensure_expected_type% "type mismatch, `for`" PUnit.unit)
                         | some a => return ensure_expected_type% "type mismatch, `for`" a)
        doSeqToCode (getDoSeqElems (getDoSeq auxDo) ++ doElems)
      else
        let forInBody ← liftMacroM <| destructTuple uvars (← `(r)) forInBody
        let forInTerm ← if let some h := h? then
          annotate doFor (← `(for_in'% $(xs) $uvarsTuple fun $x $h r => $forInBody))
        else
          annotate doFor (← `(for_in% $(xs) $uvarsTuple fun $x r => $forInBody))
        if doElems.isEmpty then
          let auxDo ← `(do let r ← $forInTerm:term;
                           $uvarsTuplePat:term := r;
                           Pure.pure (ensure_expected_type% "type mismatch, `for`" PUnit.unit))
          doSeqToCode <| getDoSeqElems (getDoSeq auxDo)
        else
          let auxDo ← `(do let r ← $forInTerm:term; $uvarsTuplePat:term := r)
          doSeqToCode <| getDoSeqElems (getDoSeq auxDo) ++ doElems
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doMatchToCode (doMatch : Syntax) (doElems: List Syntax) : M CodeBlock := do
    let ref       := doMatch
    let genParam  := doMatch[1]
    let optMotive := doMatch[2]
    let discrs    := doMatch[3]
    let matchAlts := doMatch[5][0].getArgs 
    let matchAlts ← matchAlts.foldlM (init := #[]) fun result matchAlt => return result ++ (← liftMacroM <| expandMatchAlt matchAlt)
    let alts ←  matchAlts.mapM fun matchAlt => do
      let patterns := matchAlt[1][0]
      let vars ← getPatternsVarsEx patterns.getSepArgs
      withRef patterns <| checkNotShadowingMutable vars
      let rhs  := matchAlt[3]
      let rhs ← doSeqToCode (getDoSeqElems rhs)
      pure { ref := matchAlt, vars := vars, patterns := patterns, rhs := rhs : Alt CodeBlock }
    let matchCode ← mkMatch ref genParam discrs optMotive alts
    concatWith matchCode doElems
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doMatchExprToCode (doMatchExpr : Syntax) (doElems: List Syntax) : M CodeBlock := do
    let ref       := doMatchExpr
    let «meta»    := doMatchExpr[1].isNone
    let discr     := doMatchExpr[2]
    let alts      := doMatchExpr[4][0].getArgs 
    let alts ← alts.mapM fun alt => do
      let pat      := alt[1]
      let var?     := if pat[0].isNone then none else some pat[0][0]
      let funName  := pat[1]
      let pvars    := pat[2].getArgs
      let rhs      := alt[3]
      let rhs ← doSeqToCode (getDoSeqElems rhs)
      pure { ref, var?, funName, pvars, rhs }
    let elseBranch ← doSeqToCode (getDoSeqElems doMatchExpr[4][1][3])
    let matchCode ← mkMatchExpr ref «meta» discr alts elseBranch
    concatWith matchCode doElems
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doTryToCode (doTry : Syntax) (doElems: List Syntax) : M CodeBlock := do
    let tryCode ← doSeqToCode (getDoSeqElems doTry[1])
    let optFinally := doTry[3]
    let catches ← doTry[2].getArgs.mapM fun catchStx : Syntax => do
      if catchStx.getKind == ``Parser.Term.doCatch then
        let x       := catchStx[1]
        if x.isIdent then
          withRef x <| checkNotShadowingMutable #[x]
        let optType := catchStx[2]
        let c ← doSeqToCode (getDoSeqElems catchStx[4])
        return { x := x, optType := optType, codeBlock := c : Catch }
      else if catchStx.getKind == ``Parser.Term.doCatchMatch then
        let matchAlts := catchStx[1]
        let x ← `(ex)
        let auxDo ← `(do match ex with $matchAlts)
        let c ← doSeqToCode (getDoSeqElems (getDoSeq auxDo))
        return { x := x, codeBlock := c, optType := mkNullNode : Catch }
      else
        throwError "unexpected kind of `catch`"
    let finallyCode? ← if optFinally.isNone then pure none else some <$> doSeqToCode (getDoSeqElems optFinally[0][1])
    if catches.isEmpty && finallyCode?.isNone then
      throwError "invalid `try`, it must have a `catch` or `finally`"
    let ctx ← read
    let ws    := getTryCatchUpdatedVars tryCode catches finallyCode?
    let uvars := varSetToArray ws
    let a     := tryCatchPred tryCode catches finallyCode? hasTerminalAction
    let r     := tryCatchPred tryCode catches finallyCode? hasReturn
    let bc    := tryCatchPred tryCode catches finallyCode? hasBreakContinue
    let toTerm (codeBlock : CodeBlock) : M Syntax := do
      let codeBlock ← liftM $ extendUpdatedVars codeBlock ws
      liftMacroM <| ToTerm.mkNestedTerm codeBlock.code ctx.m ctx.returnType uvars a r bc
    let term ← toTerm tryCode
    let term ← catches.foldlM (init := term) fun term «catch» => do
      let catchTerm ← toTerm «catch».codeBlock
      if catch.optType.isNone then
        annotate doTry (← ``(MonadExcept.tryCatch $term (fun $(«catch».x):ident => $catchTerm)))
      else
        let type := «catch».optType[1]
        annotate doTry (← ``(tryCatchThe $type $term (fun $(«catch».x):ident => $catchTerm)))
    let term ← match finallyCode? with
      | none             => pure term
      | some finallyCode => withRef optFinally do
        unless finallyCode.uvars.isEmpty do
          throwError "`finally` currently does not support reassignments"
        if hasBreakContinueReturn finallyCode.code then
          throwError "`finally` currently does `return`, `break`, nor `continue`"
        let finallyTerm ← liftMacroM <| ToTerm.run finallyCode.code ctx.m ctx.returnType {} ToTerm.Kind.regular
        annotate doTry (← ``(tryFinally $term $finallyTerm))
    let doElemsNew ← liftMacroM <| ToTerm.matchNestedTermResult term uvars a r bc
    doSeqToCode (doElemsNew ++ doElems)
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
  partial def doSeqToCode : List Syntax → M CodeBlock
    | [] => do liftMacroM mkPureUnitAction
    | doElem::doElems => withIncRecDepth <| withRef doElem do
      checkSystem "`do`-expander"
      match (← liftMacroM <| expandMacro? doElem) with
      | some doElem => doSeqToCode (doElem::doElems)
      | none =>
      match (← liftMacroM <| expandDoIf? doElem) with
      | some doElem => doSeqToCode (doElem::doElems)
      | none =>
      match (← liftMacroM <| expandDoLetExpr? doElem doElems) with
      | some doElem => doSeqToCode [doElem]
      | none =>
        let (liftedDoElems, doElem) ← expandLiftMethod doElem
        if !liftedDoElems.isEmpty then
          doSeqToCode (liftedDoElems ++ [doElem] ++ doElems)
        else
          let ref := doElem
          let k := doElem.getKind
          if k == ``Parser.Term.doLet then
            let vars ← getDoLetVars doElem
            checkNotShadowingMutable vars
            mkVarDeclCore vars doElem <$> withNewMutableVars vars (isMutableLet doElem) (doSeqToCode doElems)
          else if k == ``Parser.Term.doHave then
            let vars ← getDoHaveVars doElem
            checkNotShadowingMutable vars
            mkVarDeclCore vars doElem <$> (doSeqToCode doElems)
          else if k == ``Parser.Term.doLetRec then
            let vars ← getDoLetRecVars doElem
            checkNotShadowingMutable vars
            mkVarDeclCore vars doElem <$> (doSeqToCode doElems)
          else if k == ``Parser.Term.doReassign then
            let vars ← getDoReassignVars doElem
            checkReassignable vars
            let k ← doSeqToCode doElems
            mkReassignCore vars doElem k
          else if k == ``Parser.Term.doLetArrow then
            doLetArrowToCode doElem doElems
          else if k == ``Parser.Term.doLetElse then
            doLetElseToCode doElem doElems
          else if k == ``Parser.Term.doReassignArrow then
            doReassignArrowToCode doElem doElems
          else if k == ``Parser.Term.doIf then
            doIfToCode doElem doElems
          else if k == ``Parser.Term.doUnless then
            doUnlessToCode doElem doElems
          else if k == ``Parser.Term.doFor then withFreshMacroScope do
            doForToCode doElem doElems
          else if k == ``Parser.Term.doMatch then
            doMatchToCode doElem doElems
          else if k == ``Parser.Term.doMatchExpr then
            doMatchExprToCode doElem doElems
          else if k == ``Parser.Term.doTry then
            doTryToCode doElem doElems
          else if k == ``Parser.Term.doBreak then
            ensureInsideFor
            ensureEOS doElems
            return mkBreak ref
          else if k == ``Parser.Term.doContinue then
            ensureInsideFor
            ensureEOS doElems
            return mkContinue ref
          else if k == ``Parser.Term.doReturn then
            doReturnToCode doElem doElems
          else if k == ``Parser.Term.doDbgTrace then
            return mkSeq doElem (← doSeqToCode doElems)
          else if k == ``Parser.Term.doAssert then
            return mkSeq doElem (← doSeqToCode doElems)
          else if k == ``Parser.Term.doDebugAssert then
            return mkSeq doElem (← doSeqToCode doElems)
          else if k == ``Parser.Term.doNested then
            let nestedDoSeq := doElem[1]
            doSeqToCode (getDoSeqElems nestedDoSeq ++ doElems)
          else if k == ``Parser.Term.doExpr then
            let term := doElem[0]
            if doElems.isEmpty then
              return mkTerminalAction term
            else
              return mkSeq term (← doSeqToCode doElems)
          else
            throwError "unexpected do-element of kind {doElem.getKind}:\n{doElem}"
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames.ToCodeBlock
def run (doStx : Syntax) (m : Syntax) (returnType : Syntax) : TermElabM CodeBlock :=
  (doSeqToCode <| getDoSeqElems <| getDoSeq doStx).run { ref := doStx, m, returnType }
end Lean.Elab.Term.DoNames.ToCodeBlock

namespace Lean.Elab.Term.DoNames
@[scoped term_elab «do»] def elabDo : TermElab := fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  let bindInfo ← extractBind expectedType?
  let m ← Term.exprToSyntax bindInfo.m
  let returnType ← Term.exprToSyntax bindInfo.returnType
  let codeBlock ← ToCodeBlock.run stx m returnType
  let stxNew ← liftMacroM <| ToTerm.run codeBlock.code m returnType
  trace[Elab.do] stxNew
  withMacroExpansion stx stxNew <| elabTermEnsuringType stxNew bindInfo.expectedType
end Lean.Elab.Term.DoNames

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

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

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

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

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

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

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

abbrev doSeq := TSyntax ``Term.doSeq

abbrev doSeqItem := TSyntax ``Term.doSeqItem

def termBeforeReqEnsDo := withForbidden "require" (withForbidden "ensures" Term.termBeforeDo)

private def toBracketedBinderArrayLeafny (stx : Array (TSyntax `leafny_binder)) : MetaM (TSyntaxArray `Lean.Parser.Term.bracketedBinder) := do
  let mut binders := #[]
  for b in stx do
    match b with
    | `(leafny_binder| ($id:ident : $tp:term)) => do
      let fb ← `(bracketedBinder| ($id : $tp:term))
      binders := binders.push fb
    | `(leafny_binder| (mut $id:ident : $tp:term)) => do
      let idOld := mkIdent <| id.getId.appendAfter "Old"
      let fb ← `(bracketedBinder| ($idOld : $tp:term))
      binders := binders.push fb
    | _ => throwError "unexpected syntax in leafny binder: {b}"
  return binders

def getMutTypes (stx : Array (TSyntax `leafny_binder)) : MetaM (Array (TSyntax `term)) := do
  let mut types := #[]
  for b in stx do
    match b with
    | `(leafny_binder| (mut $_:ident : $tp:term)) => do
      types := types.push tp
    | _ => pure ()
  return types

def getModIds (stx : Array (TSyntax `leafny_binder)) : MetaM (Array (Nat × Ident)) := do
  let mut ids := #[]
  let mut pos := 0
  for b in stx do
    match b with
    | `(leafny_binder| (mut $id:ident : $_:term)) => do
      ids := ids.push (pos, id)
      pos := pos + 1
    | _ => pos := pos + 1
  return ids

def getIds (stx : Array (TSyntax `leafny_binder)) : MetaM (Array Ident) := do
  let mut ids := #[]
  for b in stx do
    match b with
    | `(leafny_binder| (mut $id:ident : $_:term)) => do
      let idOld := mkIdent <| id.getId.appendAfter "Old"
      ids := ids.push idOld
    | `(leafny_binder| ($id:ident : $_:term)) => do
      ids := ids.push id
    | _ => throwError "unexpected syntax in leafny binder: {b}"
  return ids

abbrev doMatchAltExpr := Term.matchAlt (rhsParser := Term.doSeq)

partial def expandLeafnyDoSeq (modIds : Array Ident) (stx : doSeq) : TermElabM (Array doSeqItem) :=
  match stx with
  | `(doSeq| $doS:doSeqItem*) => return Array.flatten $ ← doS.mapM (expandLeafnyDoSeqItem modIds)
  | _ => throwErrorAt stx s!"unexpected syntax of Velvet `do`-notation sequence {stx}"

partial def expandLeafnyDoSeqItem (modIds : Array Ident) (stx : doSeqItem) : TermElabM (Array doSeqItem) := do
  match stx with
  
  | `(Term.doSeqItem| $stx ;) => expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| $stx:doElem)
  | `(Term.doSeqItem| return) => expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| return ())
  | `(Term.doSeqItem| return $t) =>
    let ret <-
      if modIds.size = 0 then
      `(term| $t)
     else
       `(term| ($t, $[$modIds:term],*))
    return #[<-`(Term.doSeqItem| return $ret)]
  | `(Term.doSeqItem| pure $t) =>
    let ret <-
      if modIds.size = 0 then
      `(term| $t)
     else
       `(term| ($t, $[$modIds:term],*))
    return #[<-`(Term.doSeqItem| pure $ret)]
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn:doSeq else $els:doSeq) =>
    let thn <- expandLeafnyDoSeq modIds thn
    let els <- expandLeafnyDoSeq modIds els
    let ret ← `(Term.doSeqItem| if $h:ident : $t then $thn* else $els*)
    return #[ret]
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn) =>
    expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| if $h:ident : $t:term then $thn else pure ())
  | `(Term.doSeqItem| if $t:term then $thn:doSeq) =>
    expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| if $t then $thn:doSeq else pure ())
  | `(Term.doSeqItem| match $discrs:matchDiscr,* with $[$alts:matchAlt]*) =>
    let alts' ← alts.mapM fun (alt : TSyntax _) => do
      match alt with
      | `(doMatchAltExpr| | $a,* => $rhs:doSeq) =>
        let rhs' ← expandLeafnyDoSeq modIds rhs
        let alt' ← `(doMatchAltExpr| | $a,* => $rhs'*)
        pure ⟨alt'.raw⟩
      | _ =>
        pure alt
    let ret ← `(Term.doSeqItem| match $discrs:matchDiscr,* with $[$alts':matchAlt]*)
    return #[ret]
  | `(Term.doSeqItem| if $t:term then $thn:doSeq else $els:doSeq) =>
    let thn <- expandLeafnyDoSeq modIds thn
    let els <- expandLeafnyDoSeq modIds els
    let ret ← `(Term.doSeqItem| if $t then $thn* else $els*)
    return #[ret]
  | `(Term.doSeqItem| let $id <- $trm:term) | `(Term.doSeqItem| let $id : $_ <- $trm:term) =>
    let `($t:ident $args:term*) := trm | pure #[stx]
    
    let ctx <- globalMutVarsCtx.get
    let .some ids := ctx[t.getId]? | pure #[stx]
    let mut mods := #[]
    let mut modArgs := #[]
    for (pos, a) in ids do
      let .some arg := args[pos]? | throwErrorAt stx s!"{t} is not fully applied"
      
      let argName := arg.raw.getId
      if argName.isAnonymous then throwErrorAt arg s!"mutable argument {arg} is not a name"
      if argName ∈ modArgs then throwErrorAt arg s!"mutable arguments cannot alias"
      modArgs := modArgs.push argName
      mods := mods.push $ <- withRef arg `(Term.doSeqItem| $(mkIdent argName):ident := $a:ident)
    return #[<-`(Term.doSeqItem| let $id <- $trm:term)] ++ mods
  | `(Term.doSeqItem| $trm:term) =>
    let id := mkIdent <| <- mkFreshUserName `ret
    let `($t:ident $args:term*) := trm | pure #[stx]
    
    let ctx <- globalMutVarsCtx.get
    let .some ids := ctx[t.getId]? | pure #[stx]
    let mut mods := #[]
    let mut modArgs := #[]
    for (pos, a) in ids do
      let .some arg := args[pos]? | throwErrorAt stx s!"{t} is not fully applied"
      
      let argName := arg.raw.getId
      if argName.isAnonymous then throwErrorAt arg s!"mutable argument {arg} is not a name"
      if argName ∈ modArgs then throwErrorAt arg s!"mutable arguments cannot alias"
      modArgs := modArgs.push argName
      mods := mods.push $ <- withRef arg `(Term.doSeqItem| $(mkIdent argName):ident := $a:ident)
    let ret <- withRef trm `(Term.doSeqItem| pure $id)
    return #[<- withRef trm `(Term.doSeqItem| let ⟨$id, _⟩ <- $trm:term)] ++ mods.push ret
  | `(Term.doSeqItem| while_some $id :| $p:term $invs* $done do $doSeq:doSeq) =>
    let doSeq <- expandLeafnyDoSeq modIds doSeq
    return #[<-`(Term.doSeqItem| while_some $id :| $p:term $invs* $done do $doSeq*)]
  | stx => pure #[stx]

private def Array.andListWithName (ts : Array (TSyntax `term)) (name_prefix : TSyntax `name) : TermElabM (TSyntax `term) := do
  if ts.size = 0 then `(term| True) else
    let mut t <- `(term| with_name_prefix $name_prefix:name $(ts[0]!))
    for t' in ts[1:] do
      t <- `(term| (with_name_prefix $name_prefix:name $t') ∧ $t)
    return t

private def Array.andList (ts : Array (TSyntax `term)) : TermElabM (TSyntax `term) := do
  if ts.size = 0 then `(term| True) else
    let mut t := ts[0]!
    for t' in ts[1:] do
      t <- `(term| $t' ∧ $t)
    return t

private def addPreludeToPreCond (pre : Term) (modIds : Array Ident) : CoreM (TSyntax `term) := do
  let mut pre := pre
  for modId in modIds do
    let modIdOld := mkIdent <| modId.getId.appendAfter "Old"
    pre ← `(term| let $modId:ident := $modIdOld:ident; $pre)
  pure pre

def atomicAssertion {α : Type u} (n : Name) (a : α) := a

def obtainVelvetTestingCtx (nameRaw : Ident) : CommandElabM (VelvetTestingCtx × Name) := do
  let ctxMap ← velvetTestingContextMap.get
  let name := nameRaw.getId
  unless ctxMap.contains name do
    throwError "{name} is not a Velvet program"
  return (ctxMap[name]!, name)

def elabDefiningDecidableInstancesForVelvetSpec (nameRaw : Ident)
    (pre? : Bool) (tac : Option (TSyntax `Lean.Parser.Tactic.tacticSeq)) : CommandElabM Unit := do
  let (ctx, name) ← obtainVelvetTestingCtx nameRaw
  let bindersIdents := ctx.binderIdents
  let (target, suffix, binders) :=
    if pre?
    then (ctx.pre, "PreDecidable", bindersIdents)
    else (ctx.post, "PostDecidable", bindersIdents ++ ctx.modBinders |>.push ⟨mkExplicitBinder ctx.retId ctx.retType⟩)
  let decidableInstName := name.appendAfter suffix
  
  let tac := tac.getD (← `(Lean.Parser.Tactic.tacticSeq| skip ))
  let proof := (← `(Lean.Parser.Tactic.tacticSeq|
    repeat' refine @instDecidableAnd _ _ ?_ ?_
    all_goals (try infer_instance)
    ($tac) ))
  let decidableInstDefCmd ← `(command|
    def $(mkIdent decidableInstName) $binders* :
      $(mkIdent ``Decidable) ($target) := by admit /- proof elided -/
      )
  elabCommand decidableInstDefCmd

inductive AccFrom (p : Nat -> Prop) : Nat -> Prop
    | now : p i -> AccFrom p i
    | later : ¬ p i -> AccFrom p (i + 1) -> AccFrom p i

def findNat (p : Nat -> Prop) [DecidablePred p] : Option Nat :=
  let rec aux i :=
    if p i then
      some i
    else
      aux (i + 1)
  partial_fixpoint
  aux 0

def find [Encodable α] (p : α -> Prop) [DecidablePred p] : Option α :=
  findNat (fun x => (Encodable.decode x).any (p ·)) |>.bind Encodable.decode

class WeakFindable {α : Type u} (p : α -> Prop) where
  find : Unit -> Option α
  find_some_p : find () = some x -> p x

class Findable {α : Type u} (p : α -> Prop) where
  find : Unit -> Option α
  find_none : (find ()).isNone -> ∀ x, ¬ p x
  find_some_p : find () = some x -> p x

instance WeakFindable.of_Findable {α : Type u} (p : α -> Prop) [Findable p] : WeakFindable p where
  find := Findable.find p
  find_some_p := Findable.find_some_p

instance {p : α -> Prop} [Encodable α] [DecidablePred p] : Findable p where
  find := fun _ => find p
  find_none := find_none p
  find_some_p := find_some_p p _

@[instance high]
instance {p : α -> Prop} [FinEnum α] [DecidablePred p] : Findable p where
  find := fun _ => FinEnum.toList α |>.find? p
  find_none := by admit /- proof elided -/

inductive ExtractNonDet (findable : {τ : Type u} -> (τ -> Prop) -> Type u) {m} : {α : Type u} -> NonDetT m α -> Type _ where
  | pure {α} : ∀ (x : α), ExtractNonDet findable (NonDetT.pure x)
  | vis {α} {β} (x : m β) (f : β → NonDetT m α) :
      (∀ y, ExtractNonDet findable (f y)) → ExtractNonDet findable (.vis x f)
  | pickSuchThat {α} (τ : Type u) (p : τ -> Prop) (f : τ → NonDetT m α)
    {_ : findable p}
     : (∀ x, ExtractNonDet findable (f x)) → ExtractNonDet findable (.pickCont τ p f)
  | assume {α} (p : PUnit -> Prop) (f : PUnit → NonDetT m α) {_ : Decidable (p .unit)} :
    (∀ x, ExtractNonDet findable (f x)) → ExtractNonDet findable (.pickCont PUnit p f)

def ExtractNonDet.bind {findable : {τ : Type u} -> (τ -> Prop) -> Type u} :
  (_ : ExtractNonDet findable x) -> (_ : ∀ y, ExtractNonDet findable (f y)) -> ExtractNonDet findable (x >>= f)
  | .pure x, inst => by admit /- proof elided -/
  | .vis x f inst, inst' => by admit /- proof elided -/
  | .pickSuchThat _ p f inst, inst' => by admit /- proof elided -/
  | .assume _ f inst, inst' => by admit /- proof elided -/

instance ExtractNonDet.pure' : ExtractNonDet findable (Pure.pure (f := NonDetT m) x) :=

instance ExtractNonDet.liftM (x : m α) :
  ExtractNonDet findable (liftM (n := NonDetT m) x) :=

instance ExtractNonDet.assume' {p : Prop} [Decidable p] : ExtractNonDet findable (MonadNonDet.assume (m :=  NonDetT m) p) :=

instance ExtractNonDet.pickSuchThat' {τ : Type u} (p : τ -> Prop) [Findable p] :
  ExtractNonDet Findable (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) :=

instance ExtractNonDet.pickSuchThat_weak {τ : Type u} (p : τ -> Prop) [WeakFindable p] :
  ExtractNonDet WeakFindable (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) :=

instance ExtractNonDet.if {p : Prop} {dec : Decidable p} {x y : NonDetT m α}
  (_ : ExtractNonDet findable x) (_ : ExtractNonDet findable y) :
  ExtractNonDet findable (if p then x else y) :=

instance ExtractNonDet.ForIn_list {xs : List α} {init : β} {f : α → β → NonDetT m (ForInStep β)}
  (_ : ∀ a b, ExtractNonDet findable (f a b)) :
  ExtractNonDet findable (forIn xs init f) :=

@[simp, inline]
def NonDetT.extractGen {findable : {τ : Type u} -> (τ -> Prop) -> Type u} {α : Type u}
  (findOf : ∀ {τ : Type u} (p : τ -> Prop), findable p -> Unit -> Option τ)
  : (s : NonDetT m α) -> (ex : ExtractNonDet findable s := by admit /- proof elided -/
  ) -> m α
  | .pure x, _ => Pure.pure x
  | .vis x f, .vis _ _ _ => liftM x >>= (fun x => extractGen findOf (f x))
  | .pickCont _ p f, .pickSuchThat _ _ _ _ =>
    match findOf p ‹_› () with
    | none => CCPOBot.compBot
    | some x =>  extractGen findOf (f x)
  | .pickCont _ p f, .assume _ _ _ =>
    if p .unit then
      extractGen findOf (f .unit)
    else CCPOBot.compBot

@[inline]
def NonDetT.extract {α : Type u} (s : NonDetT m α) (ex : ExtractNonDet Findable s := by admit /- proof elided -/
) : m α :=
  NonDetT.extractGen Findable.find s

def NonDetT.extractWeak {α : Type u} (s : NonDetT m α) (ex : ExtractNonDet WeakFindable s := by admit /- proof elided -/
) : m α :=
  NonDetT.extractGen WeakFindable.find s

@[inline]
def NonDetT.run {α : Type u} (s : NonDetT m α) (ex : ExtractNonDet Findable s := by admit /- proof elided -/
) : m α :=
  NonDetT.extract s ex

def NonDetT.runWeak {α : Type u} (s : NonDetT m α) (ex : ExtractNonDet WeakFindable s := by admit /- proof elided -/
) : m α :=
  NonDetT.extractWeak s ex

noncomputable

abbrev NonDetT.prop {α : Type u} : (s : NonDetT m α) -> Cont l α
  | .pure x => Pure.pure x
  | .vis x f => fun post => wlp x fun y => NonDetT.prop (f y) post
  | .pickCont _ p f => fun post =>
    (⨅ t, ⌜p t⌝ ⇨ NonDetT.prop (f t) post) ⊓ (⨆ t, ⌜p t⌝)

structure Extractable (x : NonDetT m α) where
  cond : Cont l α
  prop : ∀ post, cond post <= x.prop post

def Extractable.bind (x : NonDetT m α) (f : α -> NonDetT m β)
  (ex : Extractable x) (exf : ∀ a, Extractable (f a)) :
  Extractable (x >>= f) :=

def Extractable.pure (x : α) : Extractable (pure (f := NonDetT m) x) :=

def Extractable.liftM (x : m α) : Extractable (liftM (n := NonDetT m) x) :=

def Extractable.assume (p : Prop) :
  Extractable (MonadNonDet.assume (m := NonDetT m) p) :=

def Extractable.pickSuchThat (τ : Type u) (p : τ -> Prop) [Encodable τ] [DecidablePred p] :
  Extractable (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) :=

def Extractable.forIn (xs : List α) (init : β) (f : α -> β -> NonDetT m (ForInStep β))
  (ex: ∀ a b, Extractable (f a b)):
  Extractable (forIn xs init f) :=

def Extractable.forIn_range (m : Type -> Type v) (l : Type) {β : Type} [CompleteBooleanAlgebra l] [Monad m] [MAlgOrdered m l] (xs : Std.Range) (init : β) (f : ℕ -> β -> NonDetT m (ForInStep β))
  (ex: ∀ a b, Extractable (f a b)):
  Extractable (ForIn.forIn xs init f) :=

def Extractable.if_some {τ} {p : τ -> Prop}
  [Encodable τ]
  [DecidablePred p]
  {dec : Decidable $ ∃ x, p x} {x : τ -> NonDetT m α} {y : NonDetT m α}
  (_ : ∀ t, Extractable (x t)) (_ : Extractable y) :
  Extractable (if ∃ x, p x then MonadNonDet.pickSuchThat τ p >>= x else y) :=

def ExtractNonDet.prop {α : Type u} (s : NonDetT m α) :  ExtractNonDet WeakFindable s -> l
  | .pure x => ⊤
  | .vis x f ex => wlp x fun y => (ex y).prop
  | .pickSuchThat _ p f ex => ⨅ t ∈ WeakFindable.find p (), (ex t).prop
  | .assume p f ex =>
      if p .unit then
        (ex .unit).prop
      else ⊤

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

inductive LoomSolver : Type where
  | cvc5
  | smt (smtSolver : SmtSolver)
  | grind
  | custom

instance : ToString LoomSolver where
  toString
    | .cvc5 => "cvc5"
    | .smt .z3 => "z3"
    | .smt .cvc5 => "cvc5"
    | .grind => "grind"
    | .custom => "custom"

instance : KVMap.Value LoomSolver where
  toDataValue
    | .cvc5 => "cvc5"
    | .smt .z3 => "z3"
    | .smt .cvc5 => "cvc5"
    | .grind => "grind"
    | .custom => "custom"
  ofDataValue?
    | .ofString s =>
      match s with
      | "grind" => some .grind
      | "z3" => some (.smt .z3)
      | "cvc5" => some (.smt .cvc5)
      | "custom" => some .custom
      | _ => none
    | _ => none

instance : Inhabited LoomSolver := ⟨.grind⟩

register_option loom.solver : LoomSolver := {
  defValue := .grind
  descr :=
  "Loom solver options. Right now we support
   - `cvc5` and `z3` to use the SMT solvers via `auto` tactic
   - `grind` to use the grind tactic
   - `custom` to use a user-provided solver tactic

  In the latter case, use has to provide a `solver_tactic` manually via
  ```lean

inductive LoomSemanticsTermination : Type where
  | part
  | total
  | unspecified

instance : Inhabited LoomSemanticsTermination := ⟨.unspecified⟩

instance : KVMap.Value LoomSemanticsTermination where
  toDataValue
    | .part => "partial"
    | .total => "total"
    | .unspecified => "unspecified"
  ofDataValue?
    | .ofString s =>
      match s with
      | "partial" => some .part
      | "total" => some .total
      | "unspecified" => some .unspecified
      | _ => none
    | _ => none

register_option loom.semantics.termination : LoomSemanticsTermination := {
  defValue := LoomSemanticsTermination.unspecified
  descr := "`(partial/total)` Option to control whether to check termination of methods using the `decreasing` annotations. Default is false."
}

inductive LoomSemanticsChoice : Type where
  | angelic
  | demonic
  | unspecified

instance : Inhabited LoomSemanticsChoice := ⟨.unspecified⟩

instance : KVMap.Value LoomSemanticsChoice where
  toDataValue
    | .angelic => "angelic"
    | .demonic => "demonic"
    | .unspecified => "unspecified"
  ofDataValue?
    | .ofString s =>
      match s with
      | "angelic" => some .angelic
      | "demonic" => some .demonic
      | "unspecified" => some .unspecified
      | _ => none
    | _ => none

register_option loom.semantics.choice : LoomSemanticsChoice := {
  defValue := .unspecified
  descr :=
  "Option to control the semantics of non-deterministic choice. Right now we support
  - `demonic` semantics. In this case, the specification of the method should be justified for all possible choices.
    Note that, in total correctness semantics, one also has to prove that all choices are feasible.
  - `angelic` semantics. In this case, the specification of the method should be justified for at least one choice.
  Default is `demonic` semantics.
  "
}

private def recordOption (stx : Syntax) : CommandElabM Unit := do
  let options ← Elab.elabSetOption stx[1] stx[3]
  modify fun s => { s with maxRecDepth := maxRecDepth.get options }
  modifyScope fun scope => { scope with opts := options }

private def openScope (ident : Name) : CommandElabM Unit := do
  let openDecls ← elabOpenDecl <| <- `(openDecl|$(mkIdent ident):ident)
  modifyScope fun scope => { scope with openDecls := openDecls }

structure SpV (valTyp : Type) where
  ind: Array Nat
  val: Array valTyp
  size: ℕ
  size_eq: ind.size = size ∧ val.size = size
  inc: ∀ (i j: Nat), i < size → j < size →  i < j → ind[i]! < ind[j]!

def sumUpTo
  (spv : SpV Int)
  (v : Array Int) (bound : ℕ) : Int := ∑ i ∈ Finset.range bound, ((spv.val)[i]! * v[(spv.ind)[i]!]!)

instance : Inhabited (SpV Int) where
  default :=
  { ind := #[],
    val := #[],
    size := 0,
    size_eq := (by admit /- proof elided -/
    ),
    inc := (fun i j h_i h_j i_lt_j => by admit /- proof elided -/
    ) }

instance: GetElem (SpV Int) Nat Int fun _ _ => True where
  getElem inst i _ :=
    match (List.zip (inst.ind.toList) (inst.val.toList)).find? fun (j, _) => j = i with
    | some pr => pr.2
    | none => 0


method VSpV
  (mut out: Array Int)
  (arr: Array Int)
  (spv: SpV Int) return (u: Unit)
  ensures out.size = 1
  ensures out[0]! = sumUpTo spv arr (spv.size)
  do
    let mut ind := 0
    out := Array.replicate 1 0
    while ind ≠ spv.size
    invariant out.size = 1
    invariant ind ≤ spv.size
    invariant out[0]! = sumUpTo spv arr ind
    done_with ind = spv.size
    do
      out[0] += (spv.val)[ind]! * arr[(spv.ind)[ind]!]!
      ind := ind + 1
    return

prove_correct VSpV by
  loom_solve


method spmv
  (mut out: Array Int)
  (arr: Array Int) (spv: SpV Int)
  (spm : Array (SpV Int)) return (u : Unit)
  ensures spm.size = out.size
  ensures ∀ i < spm.size, out[i]! = sumUpTo spm[i]! arr spm[i]!.size
  do
    out := Array.replicate spm.size 0
    let mut arrInd : Array Nat := Array.replicate spm.size 0
    let mut spmInd : Array Nat := Array.replicate spm.size 0
    while_some i :| i < arrInd.size ∧ arrInd[i]! < spm[i]!.size
    invariant arrInd.size = spm.size
    invariant out.size = spm.size
    invariant ∀ i < arrInd.size, arrInd[i]! <= spm[i]!.size
    invariant ∀ i < arrInd.size, out[i]! = sumUpTo spm[i]! arr arrInd[i]!
    done_with ∀ i < arrInd.size, arrInd[i]! = spm[i]!.size
    do
      let ind := arrInd[i]!
      let vInd := (spm[i]!.ind)[ind]!
      let mVal := (spm[i]!.val)[ind]!
      let val := mVal * arr[vInd]!
      out[i] += val
      arrInd[i] += 1
    return

prove_correct spmv by
  loom_solve

def spv_dot (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ): Int :=
  if (spv1.size) ≤ pnt1 ∨ (spv2.size) ≤ pnt2 then
    0
  else
    if (spv1.ind)[pnt1]! = (spv2.ind)[pnt2]! then
      (spv1.val)[pnt1]! * (spv2.val)[pnt2]! + spv_dot spv1 spv2 (pnt1 + 1) (pnt2 + 1)
    else
      if (spv1.ind)[pnt1]! < (spv2.ind)[pnt2]! then
        spv_dot spv1 spv2 (pnt1 + 1) pnt2
      else
        spv_dot spv1 spv2 pnt1 (pnt2 + 1)
  termination_by ((spv1.size) + (spv2.size) - pnt1 - pnt2)


method SpVSpV
  (mut out: Array Int)
  (spv1: SpV Int)
  (spv2: SpV Int) return (u: Unit)
  ensures out.size = 1
  ensures out[0]! = spv_dot spv1 spv2 0 0
  do
    out := Array.replicate 1 0
    let mut pnt1 := 0
    let mut pnt2 := 0
    while pnt1 ≠ spv1.size ∧ pnt2 ≠ spv2.size
    invariant out.size = 1
    invariant pnt1 ≤ spv1.size ∧ pnt2 ≤ spv2.size
    invariant out[0]! + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0
    done_with pnt1 = spv1.size ∨ pnt2 = spv2.size
    do
      if (spv1.ind)[pnt1]! = (spv2.ind)[pnt2]! then
        out[0] += (spv1.val)[pnt1]! * (spv2.val)[pnt2]!
        pnt1 := pnt1 + 1
        pnt2 := pnt2 + 1
      else
        if (spv1.ind)[pnt1]! < (spv2.ind)[pnt2]! then
          pnt1 := pnt1 + 1
        else
          pnt2 := pnt2 + 1
    return


method SpMSpV
  (mut out: Array Int)
  (spm: Array (SpV Int))
  (spv: SpV Int) return (u: Unit)
  ensures out.size = spm.size
  ensures ∀ i < spm.size, out[i]! = spv_dot spm[i]! spv 0 0
  do
    out := Array.replicate spm.size 0
    let mut spmInd := Array.replicate spm.size 0
    let mut spvInd := Array.replicate spm.size 0
    while_some i :| i < spm.size ∧ spmInd[i]! < spm[i]!.size ∧ spvInd[i]! < spv.size
    invariant spvInd.size = spm.size
    invariant spmInd.size = spm.size
    invariant out.size = spm.size
    invariant ∀ i < spmInd.size, spmInd[i]! <= spm[i]!.size
    invariant ∀ i < spvInd.size, spvInd[i]! <= spv.size
    invariant ∀ i < spm.size, out[i]! + spv_dot spm[i]! spv spmInd[i]! spvInd[i]! = spv_dot spm[i]! spv 0 0
    done_with ∀ i < spm.size, spmInd[i]! = spm[i]!.size ∨ spvInd[i]! = spv.size
    do
      let ind_m := spmInd[i]!
      let ind_v := spvInd[i]!
      if spm[i]!.ind[ind_m]! = spv.ind[ind_v]! then
        out[i] += spm[i]!.val[ind_m]! * spv.val[ind_v]!
        spmInd[i] += 1
        spvInd[i] += 1
      else
        if spm[i]!.ind[ind_m]! < spv.ind[ind_v]! then
          spmInd[i] += 1
        else
          spvInd[i] += 1
    return

inductive AccFrom (p : Nat -> Prop) : Nat -> Prop
    | now : p i -> AccFrom p i
    | later : ¬ p i -> AccFrom p (i + 1) -> AccFrom p i

def findNat (p : Nat -> Prop) [DecidablePred p] : Option Nat :=
  let rec aux i :=
    if p i then
      some i
    else
      aux (i + 1)
  partial_fixpoint
  aux 0

def find [Encodable α] (p : α -> Prop) [DecidablePred p] : Option α :=
  findNat (fun x => (Encodable.decode x).any (p ·)) |>.bind Encodable.decode

class WeakFindable {α : Type u} (p : α -> Prop) where
  find : Unit -> Option α
  find_some_p : find () = some x -> p x

class Findable {α : Type u} (p : α -> Prop) where
  find : Unit -> Option α
  find_none : (find ()).isNone -> ∀ x, ¬ p x
  find_some_p : find () = some x -> p x

instance WeakFindable.of_Findable {α : Type u} (p : α -> Prop) [Findable p] : WeakFindable p where
  find := Findable.find p
  find_some_p := Findable.find_some_p

instance {p : α -> Prop} [Encodable α] [DecidablePred p] : Findable p where
  find := fun _ =>find p
  find_none := find_none p
  find_some_p := find_some_p p _

@[instance high]
instance {p : α -> Prop} [FinEnum α] [DecidablePred p] : Findable p where
  find := fun _ => FinEnum.toList α |>.find? p
  find_none := by admit /- proof elided -/

@[instance high]
instance {α : Type u} [Inhabited α] : Findable (α := α) (fun _ => True) where
  find := fun _ => some default
  find_none := by admit /- proof elided -/

def chain_le (a : Array Int) (h_adjacent : ∀ k, 0 ≤ k ∧ k < a.size - 1 → a[k]! ≤ a[k+1]!)
    (i j : Nat) (h_i_ge : 0 ≤ i) (h_i_lt_j : i < j) (h_j_lt_size : j < a.size) : a[i]! ≤ a[j]! :=
  if h : j = i + 1 then by
    
    rw [h]
    exact h_adjacent i ⟨h_i_ge, by admit /- proof elided -/
    ⟩
  else by
    
    have h_next : i + 1 < j := by admit /- proof elided -/

def wp (c : m α) (post : α -> l) : l := liftM (n := Cont l) c post

def triple (pre : l) (c : m α) (post : α -> l) : Prop :=
  pre ≤ wp c post

def spec (pre : l) (post : α -> l) : Cont l α :=
  fun p => pre ⊓ ⌜post ≤ p⌝

@[specialize, inline]
def Loop.forIn.loop {m : Type u -> Type v} [Monad m] [∀ α, CCPO (m α)] [MonoBind m] (f : Unit → β → m (ForInStep β)) (b : β) : m β := do
    match ← f () b with
      | ForInStep.done b  => pure b
      | ForInStep.yield b => loop f b
  partial_fixpoint

@[inline]
def Loop.forIn {β : Type u} [Monad m] [∀ α, CCPO (m α)] [MonoBind m]
  (_ : Lean.Loop) (init : β) (f : Unit → β → m (ForInStep β)) : m β :=
  Loop.forIn.loop f init

@[instance high]
instance [md : Monad m] [ccpo : ∀ α, CCPO (m α)] [mono : MonoBind m] : ForIn m Lean.Loop Unit where
  forIn {β} _ := @Loop.forIn m β md ccpo mono

def SumDigits (n: Nat): Nat :=
  if n = 0 then 0
  else (n % 10) + SumDigits (n / 10)
termination_by n
decreasing_by grind

method SumOfDigits (number: Nat) return (sum: Nat)
    ensures sum = SumDigits number
do
    let mut sum := 0
    let mut n := number
    while n > 0
        invariant sum + SumDigits n = SumDigits number
        invariant 0 ≤ sum
        done_with n = 0
    do
        let digit := n % 10
        sum := sum + digit
        n := n / 10
    return sum

abbrev VelvetM α := NonDetT DivM α

def VelvetM.extract {α : Type} (x : VelvetM α)
  [∀ α, Lean.Order.CCPO (DivM α)] [Lean.Order.MonoBind DivM] [Inhabited α] : α :=
  x.run.run

def Decidable.Nat.decidableBallLT' {p : Nat → Prop} (n : Nat)
  [∀ i, Decidable (p i)] :
  ((∀ i, i < n → p i) ↔ (∀ i, p i)) → Decidable (∀ i, p i) :=

def deriveDecidableNatUpperBound (tms : List <| TSyntax `term)
  : MacroM (TSyntax `Lean.Parser.Tactic.tacticSeq) := do
  match tms with
  | [] => `(Lean.Parser.Tactic.tacticSeq| (infer_instance) )
  | tm :: tms' =>
    let res ← deriveDecidableNatUpperBound tms'
    let h := mkIdent `h
    `(Lean.Parser.Tactic.tacticSeq|
      refine @$(mkIdent ``Decidable.Nat.decidableBallLT') _ ($tm) ?_ ?_
      on_goal 1=> intro _
      on_goal 1=>
        $res
      constructor
      next => (intro $h:ident ; intros ; apply $h:ident <;> (try split_ands) <;> (solve
          | omega
          | grind))
      next => grind)

macro "decidable_by_nat_upperbound" "[" tms:term,* "]" : term => do
  let res ← deriveDecidableNatUpperBound tms.getElems.toList
  `(term| by admit /- proof elided -/
  )

instance : MAlgOrdered Id Prop where
  μ := id
  μ_ord_pure := by admit /- proof elided -/

instance : MAlgDet Id Prop where
  demonic := by admit /- proof elided -/

inductive DivM (α : Type u) where
  | res (x : α)
  | div

def DivM.run {α : Type u} [Inhabited α] : DivM α -> α
  | DivM.res x => x
  | DivM.div => default

instance : Monad DivM where
  pure := DivM.res
  bind := fun x y => match x with
    | DivM.res x => y x
    | DivM.div => DivM.div

class CCPOBot (m : Type u -> Type v)  where
  compBot {α} : m α

class CCPOBotLawful (m : Type u -> Type v) [∀ α, Lean.Order.CCPO (m α)] [CCPOBot m] where
  prop {α} : CCPOBot.compBot (m := m) (α := α) = Lean.Order.bot

instance : LawfulMonad DivM :=

noncomputable instance : Lean.Order.CCPO (DivM α) := inferInstanceAs (Lean.Order.CCPO (Lean.Order.FlatOrder .div))

instance : CCPOBot DivM where
  compBot := .div

instance : CCPOBotLawful DivM where
  prop := by admit /- proof elided -/

instance : Lean.Order.MonoBind DivM where
  bind_mono_left := by admit /- proof elided -/

namespace PartialCorrectness
scoped instance : MAlgOrdered DivM Prop where
  μ := fun x => match x with
    | .res x => x
    | .div => ⊤
  μ_ord_pure := by admit /- proof elided -/
end PartialCorrectness

namespace PartialCorrectness
scoped instance : MAlgDet DivM Prop where
  demonic := by admit /- proof elided -/
end PartialCorrectness

namespace PartialCorrectness
instance : MAlgPartial DivM where
  csup_lift {α} chain := by admit /- proof elided -/
end PartialCorrectness

namespace PartialCorrectness
instance : NoFailure DivM where
  noFailure := by admit /- proof elided -/
end PartialCorrectness

namespace TotalCorrectness
scoped instance : MAlgOrdered DivM Prop where
  μ := fun x => match x with
    | .res x => ⌜x⌝
    | .div => ⊥
  μ_ord_pure := by admit /- proof elided -/
end TotalCorrectness

namespace TotalCorrectness
scoped instance : MAlgDet DivM Prop where
  angelic := by admit /- proof elided -/
end TotalCorrectness

namespace TotalCorrectness
instance : MAlgTotal DivM where
  bot_lift := by admit /- proof elided -/
end TotalCorrectness

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

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

def getAssertionStx : TacticM (Option Term) := withMainContext do
  let goal <- getMainTarget
  let goalStx <- ppExpr goal
  let ⟨_, ss, ns, _⟩ <- loomAssertionsMap.get
  let .some withNameExpr := goal.find? (fun e => e.isAppOf ``WithName)
    | let .some typeWithNameExpr := goal.find? (fun e => e.isAppOf ``typeWithName)
        | throwError s!"Failed to parse an assertion without names: {goalStx}"
      let nname := typeWithNameExpr.getAppArgs[2]!
      let sname <- nname.getName
      let some id1 := ns[sname]?
        | throwError s!"typeWithName {sname} not registered: {typeWithNameExpr}"
      return some ss[id1]!
  match_expr withNameExpr with
  | WithName exp name =>
    let name <- name.getName
    let some id := ns[name]?
      | let .some typeWithNameExpr := exp.find? (fun e => e.isAppOf ``typeWithName)
          | throwError s!"Failed to prove assertion without names: {goalStx}"
        let nname := typeWithNameExpr.getAppArgs[2]!
        let sname <- nname.getName
        let some id1 := ns[sname]?
          | throwError s!"typeWithName {sname} not registered: {typeWithNameExpr}"
        return some ss[id1]!
    return some ss[id]!
  | _ => throwError s!"Failed to prove assertion which is not registered4: {goalStx}"

inductive NonDetT (m : Type u -> Type v) : (α : Type u) -> Type _ where
  | pure {α} (ret : α) : NonDetT m α
  | vis {α} {β} (x : m β) (f : β → NonDetT m α) : NonDetT m α
  | pickCont {α} (τ : Type u) (p : τ -> Prop) (f : τ → NonDetT m α) : NonDetT m α

def NonDetT.bind (x : NonDetT m α) (f : α → NonDetT m β) : NonDetT m β :=
  match x with
  | pure ret => f ret
  | vis x f' => vis x fun y => bind (f' y) f
  | pickCont τ p f' => pickCont τ p fun t => bind (f' t) f

instance : Monad (NonDetT m) where
  pure := NonDetT.pure
  bind := NonDetT.bind

instance [LawfulMonad m] : LawfulMonad (NonDetT m) :=

def NonDetT.pick (τ : Type u) : NonDetT m τ :=
  NonDetT.pickCont _ (fun _ => True) pure

def NonDetT.assume (as : Prop) : NonDetT m PUnit :=
  NonDetT.pickCont PUnit (fun _ => as) fun _ => pure .unit

def NonDetT.pickSuchThat (τ : Type u) (p : τ → Prop) : NonDetT m τ :=
  NonDetT.pickCont τ p pure

class MonadNonDet (m : Type u → Type v) where
  pick : (τ : Type u) →  m τ
  pickSuchThat : (τ : Type u) → (τ → Prop) → m τ
  assume : Prop → m PUnit.{u+1}

instance : MonadNonDet (NonDetT m) where
  pick   := .pick
  assume := .assume
  pickSuchThat := .pickSuchThat

namespace DemonicChoice
def NonDetT.wp {l : Type u} {α : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m α -> Cont l α
  | .pure ret => pure ret
  | .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | .pickCont τ p f => fun post => let p : Set τ := p; ⨅ a ∈ (p : Set τ), wp (f a) post
end DemonicChoice

namespace DemonicChoice
def NonDetT.μ  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end DemonicChoice

namespace DemonicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end DemonicChoice

namespace DemonicChoice
instance {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end DemonicChoice

namespace DemonicChoice
instance [NoFailure m] : NoFailure (NonDetT m) where
  noFailure := by admit /- proof elided -/
end DemonicChoice

namespace DemonicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end DemonicChoice

namespace AngelicChoice
def   NonDetT.wp {l : Type u} {α : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m α -> Cont l α
  | .pure ret => pure ret
  | .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | .pickCont _ p f => fun post => ⨆ a, ⌜p a⌝ ⊓ wp (f a) post
end AngelicChoice

namespace AngelicChoice
def NonDetT.μ {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end AngelicChoice

namespace AngelicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end AngelicChoice

namespace AngelicChoice
instance {l : outParam (Type u)} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end AngelicChoice

namespace AngelicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end AngelicChoice

namespace Loom.Matcher
private def getForallPremises : Expr → List (Name × Expr × BinderInfo)
  | .forallE na ty body bi =>
    (na, ty, bi) :: getForallPremises body
  | _ => []
end Loom.Matcher

namespace Loom.Matcher
private def List.foldldM.{u, v, w} {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} (f : s → α → m s)
  (g : α → m s) (init : s) (l : List α) : m s :=
  match l with
  | [] => pure init
  | a :: l' => do
    let init' ← g a
    List.foldlM f init' l'
end Loom.Matcher

namespace Loom.Matcher
def WPGen.match_template.{u, v} {m : Type u → Type v} [Monad m] 
  {l : Type u} [CompleteBooleanAlgebra l] [MAlgOrdered m l] := Unit.unit
end Loom.Matcher

namespace Loom.Matcher
private partial def withinBranch (i n : Nat) (type mainGoal : Expr) : TermElabM Expr := do
  if n <= 1 then return mainGoal
  if i = n - 1 then
    let tmp ← mainGoal.mvarId!.applyConst ``inf_le_of_right_le
    return .mvar tmp[0]!
  let tmp ← mainGoal.mvarId!.applyConst ``inf_le_of_left_le
  withinBranch i (n - 1) type <| .mvar tmp[0]!
end Loom.Matcher

namespace Loom.Matcher
inductive MatcherArgCase where | dropFirst | normal
deriving BEq, Repr, ToExpr, Inhabited
end Loom.Matcher

namespace Loom.Matcher
structure MatcherWPGen where
  lvls : Array Name
  wpgenExpr : Expr
  matcherInfo : MatcherInfo
  monadRetTypePos : Nat
  monadArgPos : Nat
  monadInstPos : Nat
  omaTypePos : Nat
  firstMonadArgPos : Nat
end Loom.Matcher

namespace Loom.Matcher
def constructWPGen (matcherName : Name) : TermElabM (Option MatcherWPGen) := do
  
  
  
  let some matcherInfo ← getMatcherInfo? matcherName | return none
  let constInfo ← getConstInfo matcherName
  
  let lvlMVars ← mkFreshLevelMVars constInfo.levelParams.length

  
  
  forallBoundedTelescope (constInfo.type.instantiateLevelParams constInfo.levelParams lvlMVars) (.some matcherInfo.getFirstAltPos) fun paramsAndDiscrs partialMatcher => do
  let discrs := paramsAndDiscrs.drop matcherInfo.getFirstDiscrPos |>.take matcherInfo.numDiscrs

  
  forallTelescope (← ConstantInfo.type <$> getConstInfo ``WPGen.match_template) fun implicitArgs _ => do
  let (mExpr, monadInstExpr, lExpr, omaInstExpr) := (implicitArgs[0]!, implicitArgs[1]!, implicitArgs[2]!, implicitArgs[4]!)

  
  withLocalDecl (← mkFreshUserName `α) BinderInfo.implicit (← Expr.bindingDomain! <$> inferType mExpr) fun αExpr => do
  let mαExpr := mkApp mExpr αExpr

  
  let wpgenTypeBuilder x : MetaM Expr :=
    
    mkAppOptM ``WPGen #[.some mExpr, .some monadInstExpr, .some αExpr, .some lExpr, .none, .some omaInstExpr, .some x]
  let branchConds ← do
    pure <| Array.map (fun x => (x.1, x.2.1)) <| List.toArray <| getForallPremises partialMatcher
  let subMonadArgsWithInfo ← branchConds.mapM fun (nm, br) => do
    
    
    
    
    forallTelescope br fun xs body => do
      if xs.isEmpty then
        return ((0, MatcherArgCase.normal), (nm, mαExpr))
      let (case, xs') :=
        if xs[0]!.occurs body
        then (MatcherArgCase.normal, xs)
        else (MatcherArgCase.dropFirst, xs.drop 1)
      pure ((xs'.size, case), (nm, ← mkForallFVars xs' mαExpr))
  let (subMonadArgsInfo, subMonadArgs) := subMonadArgsWithInfo.unzip
  trace[Loom.debug] "subMonadArgs: {subMonadArgs.map Prod.snd}"
  withLocalDecls (← subMonadArgs.mapM fun (nm, t) => do
      let nm' ← mkFreshUserName nm
      pure (nm', BinderInfo.implicit, fun _ => pure t)) fun subMonadArgsFVars => do

  
  
  let subWPGenArgs ← subMonadArgs.mapIdxM fun i (nm, t) => do
    let nm' := nm.appendBefore "wpg"
    let ty ← forallTelescope t fun xs _ => do
      let tmp ← wpgenTypeBuilder <| mkAppN subMonadArgsFVars[i]! xs
      let motiveBody ← Expr.getForallBody <$> instantiateForall branchConds[i]!.2 xs
      let withEqs ← motiveBody.withApp fun _ args => do
        
        let eqs ← discrs.mapIdxM fun i lhs => mkEq lhs args[i]!
        mkArrowN eqs tmp
      
      
      mkForallFVars xs withEqs
    pure (nm', ty)
  trace[Loom.debug] "subWPGenArgs: {subWPGenArgs}"
  withLocalDeclsDND (← subWPGenArgs.mapM fun (nm, t) => do
      pure (← mkFreshUserName nm, t)) fun subWPGenArgsFVars => do

  
  let targetMatcher ← do
    let motivefv := paramsAndDiscrs[matcherInfo.getMotivePos]!
    let ty ← inferType motivefv
    let motiveArg ← forallTelescope ty fun xs _ =>
      mkLambdaFVars xs <| mkApp mExpr αExpr
    
    let subMonadArgsForMatcher ← subMonadArgsInfo.mapIdxM fun i (_, case) => do
      match case with
      | .dropFirst => mkFunUnit subMonadArgsFVars[i]!
      | .normal => pure subMonadArgsFVars[i]!
    pure <| mkAppN
      (Lean.mkConst matcherName lvlMVars)
      ((paramsAndDiscrs.set! matcherInfo.getMotivePos motiveArg) ++ subMonadArgsForMatcher)
  let targetWPGenTy ← wpgenTypeBuilder targetMatcher
  trace[Loom.debug] "targetWPGenTy: {targetWPGenTy}"

  
  let (matchEqnNames, splitter, splitterType) ← do
    let matchEqns ← Match.getEquationsFor matcherName
    
    let splitter ← mkConstWithFreshMVarLevels matchEqns.splitterName
    let splitterType ← whnfForall (← inferType <| Lean.mkConst matchEqns.splitterName lvlMVars)
    pure (matchEqns.eqnNames, splitter, splitterType)
  trace[Loom.debug] "splitter type: {splitterType}"

  
  withLocalDeclD (← mkFreshUserName `post) (← mkArrow αExpr lExpr) fun postExpr => do

  
  let (wpgenGet, backup) ← do
    let partialSplitterType ← instantiateForall splitterType paramsAndDiscrs
    let branchConds ← do
      pure <| List.map (fun x => x.2.1) <| getForallPremises partialSplitterType
    let wpgenGetBranches ← branchConds.mapIdxM fun i br => do
      let subWPGen := subWPGenArgsFVars[i]!
      let br' ← forallTelescope br fun xs motiveBody => do
        let newBody ← do
          let tmp ← motiveBody.withApp fun _ args => do
            
            let eqs ← discrs.mapIdxM fun i lhs => mkEq lhs args[i]!
            mkArrowN eqs (mkConst ``True)  
          forallTelescope tmp fun ys _ => do
            
            
            let numArgsRequired := subMonadArgsInfo[i]!.1
            let subWPGenGet ← mkAppM ``WPGen.get #[mkAppN subWPGen (xs.take numArgsRequired ++ ys), postExpr]
            mkForallFVars ys subWPGenGet
        mkForallFVars xs newBody
      trace[Loom.debug] "branch {i} after adding equalities: {br} ==> {br'}"
      
      let (dependencies, res) ← forallTelescope br' fun xs motiveBody' => do
        xs.foldrM (init := ([], motiveBody')) fun x (dependencies, e) => do
          let xty ← inferType x
          
          
          if x.occurs e then
            let tmp ← mkLambdaFVars #[x] e
            let tmp ← mkAppOptM ``iInf #[.some lExpr, .some xty, .none, .some tmp]
            pure (true :: dependencies, tmp)
          else
            let injectedProp ← mkAppOptM ``LE.pure #[.some lExpr, .none, .none, .none, .some xty]
            let tmp ← mkAppOptM ``himp #[.some lExpr, .none, .some injectedProp, .some e]
            pure (false :: dependencies, tmp)
      trace[Loom.debug] "branch {i} after transformation: {br'} ==> {res}"
      
      
      pure (res, dependencies)
    let (wpgenGetBranchesAfter, backup) := wpgenGetBranches.unzip
    
    
    let topAsInit ← mkAppOptM ``Top.top #[.some lExpr, .none]
    let bundled ← List.foldldM (g := pure) (init := topAsInit) (l := wpgenGetBranchesAfter) fun infs e =>
      mkAppOptM ``Min.min #[.some lExpr, .none, .some infs, .some e]
    let res ← mkLambdaFVars #[postExpr] bundled
    pure (res, backup.toArray)
  trace[Loom.debug] "wpgenGet: {wpgenGet}"

  
  let wpgenPost ← do
    let motive ← do
      
      let (_, discrsBuilder) ← discrs.foldlM (init := (#[], #[])) fun (xspre, res) x => do
        let nm ← mkFreshUserName (← x.fvarId!.getUserName)
        let xty ← inferType x
        let ty xspre' := pure <| xty.replaceFVars xspre xspre'
        pure (xspre.push x, res.push (nm, ty))
      
      let lhs ← instantiateLambda wpgenGet #[postExpr]
      let rhs ← mkAppOptM ``wp
        #[.some mExpr, .some monadInstExpr, .some αExpr, .some lExpr, .none,
          .some omaInstExpr, .some targetMatcher, .some postExpr]
      withLocalDeclsD discrsBuilder fun discrs' => do
        let rhs' := rhs.replaceFVars discrs discrs'
        let eqs ← discrs'.mapIdxM fun i lhs => mkEq discrs[i]! lhs
        let le ← mkAppM ``LE.le #[lhs, rhs']
        let tmp ← mkArrowN eqs le
        mkLambdaFVars discrs' tmp
    trace[Loom.debug] "motive for the splitter in proof: {motive}"
    let paramsAndDiscrs' := paramsAndDiscrs.set! matcherInfo.getMotivePos motive
    let partialSplitter := mkAppN splitter paramsAndDiscrs'
    let partialSplitterType ← inferType partialSplitter
    let numBranches := matcherInfo.numAlts    
    let branchConds ← do
      pure <| List.map (fun x => x.2.1) <| List.take numBranches <| getForallPremises partialSplitterType
    let wpgenPostSubProofs ← branchConds.toArray.mapIdxM fun i br => do
      trace[Loom.debug] "subgoal {i}: {br}"
      
      let res ← forallTelescope br fun xs body => do
        
        
        
        let body ← whnf body
        forallTelescope body fun eqs body => do

        
        let goal ← mkFreshExprMVar body
        let goals ← goal.mvarId!.casesRec fun localDecl => do
          return eqs.contains <| Expr.fvar localDecl.fvarId
        let goal := .mvar goals[0]!
        
        let goal' ← withinBranch i numBranches lExpr goal
        
        let dependencies := backup[i]!.toArray
        let (_, goal'') ← dependencies.foldlM (init := (0, goal')) fun (i, mainGoal) dep => do
          unless dep do
            let x := xs[i]!
            let xty ← inferType x
            let tmp ← mkAppOptM ``Loom.Matcher.simp1 #[.some lExpr, .none, .some xty, .some x]
            let goals ← mainGoal.mvarId!.apply tmp
            return (i.succ, .mvar goals[0]!)
          let (x, xty) ← match xs[i]? with
            | some x => pure (x, ← inferType x)
            | none =>
              let aa ← mkFreshExprMVar none
              let eq ← mkEq aa aa
              let rfl ← mkEqRefl aa
              pure (rfl, eq)
          let f ← mkFreshExprMVar (← mkArrow xty lExpr)
          let a ← mkFreshExprMVar lExpr
          let tmp ← mkAppOptM ``iInf_le_of_le #[.some lExpr, .some xty, .none,
            .some f   ,
            .some a, .some x]
          let goals ← mainGoal.mvarId!.apply tmp
          pure (i.succ, .mvar goals[0]!)
        
        let goal''' ←
          try
            let r ← goal''.mvarId!.rewrite (← goal''.mvarId!.getType) (← mkConstWithFreshMVarLevels matchEqnNames[i]!)
            let goal''' ← Expr.mvar <$> goal''.mvarId!.replaceTargetEq r.eNew r.eqProof
            for g in r.mvarIds do
              g.assumption
            pure goal'''
          catch _ => pure goal''
        
        let _ ← goal'''.mvarId!.applyConst ``WPGen.prop
        let res ← instantiateMVars goal
        mkLambdaFVars (xs ++ eqs) res
      trace[Loom.debug] "sub-proof for branch {i}: {br} ==> {res}"
      pure res
    let discrsRfls ← discrs.mapM (mkEqRefl ·)
    mkLambdaFVars #[postExpr] <| mkAppN partialSplitter (wpgenPostSubProofs ++ discrsRfls)

  
  let wpgen ← mkAppM ``WPGen.mk #[wpgenGet, wpgenPost]
  check wpgen
  let wpgen ← instantiateMVars wpgen
  let arguments :=
    #[αExpr] ++
    (paramsAndDiscrs.take matcherInfo.numParams) ++
    implicitArgs ++
    subMonadArgsFVars ++
    (paramsAndDiscrs.drop matcherInfo.getFirstDiscrPos) ++
    subWPGenArgsFVars
  let wpgen ← mkLambdaFVars arguments wpgen
  trace[Loom.debug] "generated WPGen: {wpgen}"
  trace[Loom.debug] "has mvar? {wpgen.hasMVar}"

  
  let wpgen ← levelMVarToParam wpgen
  trace[Loom.debug] "has mvar? {wpgen.hasMVar}"
  let newLvls := collectLevelParams {} wpgen |>.params

  let firstMonadArgPos := 1 + matcherInfo.numParams + implicitArgs.size
  pure <| .some {
    lvls := newLvls,
    wpgenExpr := wpgen,
    matcherInfo := matcherInfo,
    monadRetTypePos := 0,
    monadArgPos := 1 + matcherInfo.numParams,
    monadInstPos := 1 + matcherInfo.numParams + 1,
    omaTypePos := 1 + matcherInfo.numParams + 2,
    firstMonadArgPos := firstMonadArgPos,
    
    
  }
end Loom.Matcher

namespace Loom.Matcher
def partiallyInstantiateWPGen (outerArgs : Array Expr) (a : MatcherWPGen) (b : MatcherApp) : MetaM Expr := do
  let wpgen := a.wpgenExpr.instantiateLevelParams a.lvls.toList (← mkFreshLevelMVars a.lvls.size)
  try
    
    let fma := a.firstMonadArgPos
    let alts' ← do
      lambdaBoundedTelescope wpgen (fma + a.matcherInfo.numAlts) fun xs _ => do
      b.alts.mapIdxM fun i alt => do
        let numArgRequired ← Expr.getNumHeadForalls <$> inferType xs[fma + i]!
        let numArgs := alt.getNumHeadLambdas
        
        if numArgRequired + 1 == numArgs then
          return mkApp alt (mkConst ``Unit.unit)
        pure alt
    let args : Array (Option Expr) := Array.replicate fma none
     
    
    let args := args.set! a.monadRetTypePos (some outerArgs[0]!)
    let args := args.set! a.monadArgPos (some outerArgs[1]!)
    let args := args.set! a.monadInstPos (some outerArgs[2]!)
    let args := args.set! a.omaTypePos (some outerArgs[3]!)
    
    
     
    let partialwpgen ← args.foldlM (init := wpgen) fun e arg => do
      match arg with
      | .some v => pure <| mkApp e v
      | .none => pure <| mkApp e (← mkFreshExprMVar none)
    let res := mkAppN partialwpgen alts'
    check res   
    pure res
  catch ex =>
    trace[Loom.debug] m!"Error in [{decl_name%}]: {ex.toMessageData}"
    return wpgen
end Loom.Matcher

namespace Loom.Matcher
def defineWPGen (name : Name) : TermElabM Unit := do
  unless ← isMatcher name do
    throwError s!"{name} is not a matcher"
  let targetName := name ++ `WPGen
  if (← getEnv).find? targetName matches none then
    let some res ← constructWPGen name
      | throwError s!"cannot generate WPGen for matcher {name} due to error"
    addDecl <|
      Declaration.defnDecl <|
        mkDefinitionValEx targetName res.lvls.toList (← inferType res.wpgenExpr) res.wpgenExpr
        (Lean.ReducibilityHints.regular 0)
        (DefinitionSafety.safe) []
    enableRealizationsForConst targetName
    applyAttributes targetName (← do
      let attr1 ← `(Parser.Term.attrInstance| spec )
      let attr2 ← `(Parser.Term.attrInstance| loomWpSimp)
      elabAttrs #[attr1, attr2])
end Loom.Matcher

namespace Loom.Matcher
def isMatcherWPGen (env : Environment) (name : Name) : Bool := Id.run do
  let .str p s := name | return false
  unless isMatcherCore env p do return false
  match s with
  | "WPGen" =>
    unless env.isSafeDefinition p do return false
    return true
  | _ => return false
end Loom.Matcher

def Array.toMultiset (arr : Array α) := Multiset.ofList arr.toList

abbrev iwp (c : m α) : Cont l α := Cont.inv (wp c)

def wlp (c : m α) (post : α -> l) : l := iwp c post ⊔ wp c post

def NonDetT.run {α : Type u} :  NonDetT m α -> m α
  | .pure x => Pure.pure x
  | .vis x f => liftM x >>= (fun x => (f x).run)
  | @NonDetT.pickCont _ _ _ p _ f =>
    match Findable.find (p := p) () with
    | none => CCPOBot.compBot
    | some x =>  (f x).run
  | .repeatCont init f cont =>
    forIn Lean.Loop.mk init (fun _ x => (f x).run) >>= (fun x => (cont x).run)

def isDigit (c: Char) : Bool :=
  '0' ≤ c ∧ c ≤ '9'

def appearsAt (input result: Array Char) (pos: Nat) : Prop :=
  pos + result.size ≤ input.size ∧
  ∀ i, i < result.size → input[pos + i]! = result[i]!

method LeftmostMaximalDigit (input: Array Char)
  return (result: Array Char)
  ensures result.size > 0 → ∀ pos, appearsAt input result pos →
    ∀ pos', pos' < pos →
      ¬(pos' + result.size ≤ input.size ∧
        (∀ i, i < result.size → isDigit input[pos' + i]!) ∧
        (pos' = 0 ∨ ¬isDigit input[pos' - 1]!) ∧
        (pos' + result.size = input.size ∨ ¬isDigit input[pos' + result.size]!))
  do
  let mut i: Nat := 0
  let mut currentStart: Nat := 0
  let mut currentLen: Nat := 0
  let mut bestStart: Nat := 0
  let mut bestLen: Nat := 0
  let mut inDigitSubstring: Bool := false

  while i < input.size
    
    invariant ∀ pos len,
      (len > 0 ∧
       pos + len ≤ i ∧
       (∀ j, j < len → isDigit input[pos + j]!) ∧
       (pos = 0 ∨ ¬isDigit input[pos - 1]!) ∧
       (pos + len = i ∨ (pos + len < i ∧ ¬isDigit input[pos + len]!))) →
      len ≤ bestLen
  do
    let c := input[i]!

    if isDigit c then
      if inDigitSubstring then
        currentLen := currentLen + 1
      else
        currentStart := i
        currentLen := 1
        inDigitSubstring := true
    else
      if inDigitSubstring then
        if currentLen > bestLen then
          bestStart := currentStart
          bestLen := currentLen

        inDigitSubstring := false
        currentLen := 0

    i := i + 1
  pure (input.extract bestStart (bestStart + bestLen))

@[grind]
def fact (n: Nat): Nat :=
  if n = 0 then
    0
  else
    n * fact (n - 1)

method calc_fact (n: Nat) return (res: Nat)
  ensures fact n = res
  do
    if n = 0 then
      return 0
    else
      let mut i := 0
      let mut ans := 0
      let pre_res_n ← calc_fact (n - 1)
      while i < n
        invariant i <= n
        invariant i * pre_res_n = ans
        decreasing n - i
        do
          let pre_res ← calc_fact (n - 1)
          ans := ans + pre_res
          i := i + 1
      return ans

prove_correct calc_fact by
  loom_solve


method SimpleOption (x: Option Nat) return (res: Nat)
  ensures res > 0
  do
    let rs ← match x with
    | some re =>
      let s := re + 2
      pure s
    | none =>
      pure 1
    return rs

prove_correct SimpleOption by
  cases x <;> loom_solve

method SimpleList (li: List Nat) return (res: Nat)
  ensures res > 0
  do
    match li with
    | x :: xs =>
      let prev ← SimpleList xs
      return (prev + x)
    | [] =>
      return 1

prove_correct SimpleList by
  loom_solve

@[reducible]
def contains (tree: mt1 β) (elem: β) :=
  match tree with
  | .Leaf res => res = elem
  | .Empty => False
  | .Node l r res => res = elem ∨ contains l elem ∨ contains r elem

@[reducible]
def ordered_tree [LT β] (tree: mt1 β) :=
  match tree with
  | .Leaf _ => True
  | .Empty => True
  | .Node l r elem => ordered_tree l ∧ ordered_tree r ∧
    (∀ x, contains l x → x < elem) ∧
    (∀ x, contains r x → x > elem)

instance (σ : Type u) (l : Type u) (m : Type u -> Type v)
  [CompleteLattice l]
  [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l] : MAlgOrdered (ReaderT σ m) (σ -> l) where
  μ := fun rp r => inst.μ $ (· r) <$> rp r
  μ_ord_pure := by admit /- proof elided -/

instance (σ : Type u) (l : Type u) (m : Type u -> Type v)
  [CompleteLattice l]
  [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l] [inst': MAlgDet m l]
   : MAlgDet (ReaderT σ m) (σ -> l) where
    angelic := by admit /- proof elided -/

instance [Monad m] [inst : ∀ α, Lean.Order.CCPO (m α)] : Lean.Order.CCPO (ReaderT ε m α) :=

instance [Monad m] [∀ α, Lean.Order.CCPO (m α)] [Lean.Order.MonoBind m] : Lean.Order.MonoBind (ReaderT ε m) where
  bind_mono_left h₁₂ _ := by admit /- proof elided -/

instance [Monad m] [CCPOBot m] : CCPOBot (ReaderT σ m) where
  compBot := fun _ => CCPOBot.compBot

instance [Monad m] [inst : ∀ α, Lean.Order.CCPO (m α)] [CCPOBot m] [CCPOBotLawful m] : CCPOBotLawful (ReaderT σ m) where
  prop := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)] [MonoBind m]
  [MAlgPartial m] : MAlgPartial (ReaderT σ m) where
  csup_lift {α} chain := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)]  [MonoBind m]
  [MAlgTotal m] : MAlgTotal (ReaderT σ m) where
  bot_lift := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l]
  [inst': NoFailure m] : NoFailure (ReaderT σ m) where
  noFailure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l] [inst: MAlgOrdered m l] :
  MAlgLift m l (ReaderT σ m) (σ -> l) where
    μ_lift := by admit /- proof elided -/

abbrev LocMutVarsCtx := Array (Nat × Ident)

abbrev GlobalMutVarsCtx := Std.HashMap Name LocMutVarsCtx

structure VelvetObligation where
  binderIdents : TSyntaxArray `Lean.Parser.Term.bracketedBinder
  modIds : Array Ident
  ids : Array Ident
  retId : Ident
  ret : Term
  pre : Term
  post : Term
deriving Inhabited

abbrev VelvetObligations := Std.HashMap Name VelvetObligation

structure VelvetTestingCtx extends VelvetObligation where
   
  modBinders : Array (TSyntax `Lean.Parser.Term.bracketedBinder)
  retType : Term
deriving Inhabited

abbrev VelvetTestingContextMap := Std.HashMap Name VelvetTestingCtx

macro "assert" t:term : term => `(assertGadget $t)

elab "decreasing" t:term : term => do
  let opts <- getOptions
  let semantics := opts.getString (defVal := "unspecified") `loom.semantics.termination
  if semantics = "unspecified" then
    throwError "First, you need to specify the termination semantics using `set_option loom.semantics.termination <partial/total>`"
  let decr <- `(decreasingGadget $t)
  let decrIsNone := match t with
    | `(none) => true
    | _ => false
  let errorsEnabled := opts.getBool (defVal := true) `loom.linter.errors
  let warningsEnabled := opts.getBool (defVal := true) `loom.linter.warnings
  if semantics = "total" && decrIsNone && errorsEnabled then
    throwError "Decreasing annotations are required in total correctness semantics
To turn off this error, use `set_option loom.linter.errors false`."
  if semantics = "partial" && !decrIsNone && warningsEnabled then
    logWarningAt (<- getRef) "Decreasing annotations are not checked in partial correctness semantics
To turn off this warning, use `set_option loom.linter.warnings false`."
  Term.elabTerm decr none

elab "invariants" invs:term : term => do
  let opts <- getOptions
  let invsIsEmpty := match invs with
    | `([]) => true
    | _ => false
  let warningsEnabled := opts.getBool (defVal := true) `loom.linter.warnings
  if invsIsEmpty && warningsEnabled then
    logWarningAt (<- getRef) "Invariant annotations are not specified, so the loop invariant is assumed to be just `True`.
To turn off this warning, use `set_option loom.linter.warnings false`."
  Term.elabTerm (<- `(invariantGadget $invs:term)) none

instance demonic_exception: MonadExceptOf String CashmereM where
  throw e := liftM (m := ExceptT String (StateT Bal DivM)) (throw e)
  tryCatch := fun x _ => x

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

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

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

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

structure LoomAssertionsMap where
  maxId : Int
  syntaxStore : Std.HashMap Int Term
  nameStore : Std.HashMap Name Int
  nameCounter : Std.HashMap Name Int

  deriving Inhabited

def addAssertion (s : LoomAssertionsMap) (t : Term) (n : Name) (coreName: Name): LoomAssertionsMap :=
  let maxId := s.maxId + 1
  let maxIdLocal := s.nameCounter.get! coreName + 1
  { s with
    maxId := maxId
    syntaxStore := s.syntaxStore.insert maxId t
    nameStore := s.nameStore.insert n maxId
    nameCounter := s.nameCounter.insert coreName maxIdLocal }

def invariantGadget [MAlgOrdered m l] (inv : List l): m PUnit := pure .unit

@[simp]
abbrev invariantSeq (f : List l) := f.foldr (·⊓·) ⊤

def onDoneGadget {invType : Type u} (inv : invType) : m PUnit := pure .unit

def assertGadget {l : Type u} (h : l) : m PUnit := pure .unit

def decreasingGadget (measure : Option ℕ) : m PUnit := pure .unit

elab "with_name_prefix" lit:name inv:term : term => do
  let ⟨maxId, _, _, cntr⟩ <- loomAssertionsMap.get
  let newMaxId := maxId + 1
  let coreName := match (← Term.getDeclName?) with
    | some res => res
    | none => `nameless
  let localName := (Lean.Name.mkSimple (lit.getName.toString ++ "_" ++ coreName.toString))
  let cntrElem := match cntr.get? localName with
    | some resId => resId
    | none => 0
  let maxIdLocal := 1 + cntrElem
  let invName := lit.getName.toString ++ "_" ++ toString maxIdLocal.toNat |>.toName
  loomAssertionsMap.modify (fun res => {
      syntaxStore := res.syntaxStore.insert newMaxId inv
      nameStore := res.nameStore.insert invName newMaxId
      maxId := newMaxId
      nameCounter := res.nameCounter.insert localName maxIdLocal
      })
  Term.elabTerm (<- ``(WithName $inv $(Lean.quoteNameMk invName))) none

elab "type_with_name_prefix" lit:name inv:term : term => do
  let ⟨maxId, _, _, cntr⟩ <- loomAssertionsMap.get
  let newMaxId := maxId + 1
  let coreName := match (← Term.getDeclName?) with
    | some res => res
    | none => `nameless
  let localName := (Lean.Name.mkSimple (lit.getName.toString ++ "_" ++ coreName.toString))
  let cntrElem := match cntr.get? localName with
    | some resId => resId
    | none => 0
  let maxIdLocal := 1 + cntrElem
  let invName := lit.getName.toString ++ "_" ++ toString maxIdLocal.toNat |>.toName
  loomAssertionsMap.modify (fun res => {
      syntaxStore := res.syntaxStore.insert newMaxId inv
      nameStore := res.nameStore.insert invName newMaxId
      maxId := newMaxId
      nameCounter := res.nameCounter.insert localName maxIdLocal
      })
  Term.elabTerm (<- ``(typeWithName $inv $(Lean.quoteNameMk invName))) none

def termBeforeInvariant := Parser.withForbidden "invariant" Parser.termParser

structure WPGen (x : m α) where
  get : Cont l α
  
  prop : ∀ post, get post <= wp x post

def WPGen.default (x : m α) : WPGen x where
  get := wp x
  prop := by admit /- proof elided -/

def WPGen.pure (x : α) : WPGen (pure (f := m) x) where
  get := fun post => post x
  prop := by admit /- proof elided -/

def WPGen.bind {x : m α} {f : α -> m β} (wpg : WPGen x) (wpgf : ∀ a, WPGen (f a)) :
  WPGen (x >>= f) where
  get := fun post => wpg.get (fun a => (wpgf a).get post)
  prop := by admit /- proof elided -/

def WPGen.map {x : m α} {f : α -> β} (wpg : WPGen x) : WPGen (f <$> x) where
  get := fun post => wpg.get (fun a => post (f a))
  prop := by admit /- proof elided -/

def WPGen.spec_triple (x : m α) (trp : triple pre x post) : WPGen x where
  get := spec pre post
  prop := by admit /- proof elided -/

def WPGen.spec_wp wp' (x : m α) (trp : wp x = wp') : WPGen x where
  get := wp'
  prop := by admit /- proof elided -/

def WPGen.forWithInvariant {xs : Std.Range} {init : β} {f : ℕ → β → m (ForInStep β)}
  (inv : ℕ → β → List l) (wpg : ∀ i b, WPGen (f i b)) (xs1 : xs.step = 1) (xs_le : xs.start <= xs.stop := by admit /- proof elided -/
  ) :
    WPGen (forIn xs init (fun i b => do invariantGadget (inv i b); (f i b))) where
    get := ⌜∀ i b, invariantSeq (inv i b) <= (wpg i b).get fun
      | .yield b' => invariantSeq <| inv (i + 1) b'
      | .done b'  => invariantSeq <| inv xs.stop b'⌝
      ⊓ spec
      ((inv xs.start init).foldr (·⊓·) ⊤)
      (fun b => (inv xs.stop b).foldr (·⊓·) ⊤)
    prop := by admit /- proof elided -/

def WPGen.assert {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l] (h : l) : WPGen (assertGadget (m := m) h) where
  get := fun post => h ⊓ (h ⇨ post .unit)
  prop := by admit /- proof elided -/

def WPGen.if {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
  {hd : Decidable h} {x y : m α}
  (wpgx : h → WPGen x) (wpgy : ¬h → WPGen y)
  : WPGen (if h then x else y) where
  get := fun post =>
    (⨅ hc : WithName h (Lean.Name.anonymous.mkStr "if_pos"), (wpgx hc).get post) ⊓
    (⨅ hc : WithName (¬h) (Lean.Name.anonymous.mkStr "if_neg"), (wpgy hc).get post)
  prop := by admit /- proof elided -/

def WPGen.let  {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteBooleanAlgebra l] [MAlgOrdered m l]
  (y : β) {x : β -> m α} (wpgx : ∀ y, WPGen (x y)) : WPGen (let z := y; x z) where
  get := fun post => ⨅ z, ⌜z = y⌝ ⇨ (wpgx z).get post
  prop := by admit /- proof elided -/

noncomputable def LE.pure {l : Type u} [inst: LE l] [OrderTop l] [OrderBot l] : Prop -> l := fun p =>
  if p then ⊤ else ⊥

macro "⌜" p:term "⌝" : term => `(LE.pure $p)

@[app_unexpander LE.pure] def unexpandPure : Lean.PrettyPrinter.Unexpander
  | `($(_) $p:term) => `(⌜$p:term⌝)
  | _ => throw ()

class MAlg [Monad m] (l : outParam (Type v)) where
  μ : m l -> l
  pure : ∀ l, μ (pure l) = l
  bind : ∀ {α : Type v} (x : m α) (f g : α -> m l),
    μ ∘ f = μ ∘ g ->
    μ (x >>= f) = μ (x >>= g)

abbrev MAlg.lift {m : Type u -> Type v} {l : Type u} [Monad m] [MAlg m l] :
  {α : Type u} -> m α -> Cont l α := fun x f => μ $ f <$> x

instance (l : Type u) {m : Type u -> Type v} [Monad m] [MAlg m l] : MonadLiftT m (Cont l) where
  monadLift := MAlg.lift

instance EffectObservationOfMAlg (l : Type u) {m : Type u -> Type v} [Monad m] [LawfulMonad m] [MAlg m l] : LawfulMonadLiftT m (Cont l) where
  monadLift_pure := by admit /- proof elided -/

class MAlgOrdered (l : outParam (Type v)) [Monad m] [CompleteLattice l] where
  μ : m l -> l
  μ_ord_pure : ∀ l, μ (pure l) = l
  μ_ord_bind {α : Type v} :
    ∀ (f g : α -> m l), μ ∘ f ≤ μ ∘ g ->
      ∀ x : m α, μ (x >>= f) ≤ μ (x >>= g)

instance OfMAlgPartialOrdered {m : Type u -> Type v} {l : Type u} [Monad m] [CompleteLattice l] [mprop : MAlgOrdered m l] : MAlg m l where
  μ := MAlgOrdered.μ
  pure := MAlgOrdered.μ_ord_pure
  bind := by admit /- proof elided -/

class MAlgDet (l : outParam (Type v)) [Monad m] [CompleteLattice l] [MAlgOrdered m l] where
   
  demonic {α ι : Type v} (c : m α) (p : ι -> α -> l) [Nonempty ι] :
    ⨅ i, MAlg.lift c (p i) ≤ MAlg.lift c (fun x => ⨅ i, p i x)
   
  angelic {α ι : Type v} (c : m α) (p : ι -> α -> l) [Nonempty ι] :
    ⨆ i, MAlg.lift c (p i) ≥ MAlg.lift c (fun x => ⨆ i, p i x)

class MAlgPartial (m : Type u -> Type v) [Monad m] [∀ α, Lean.Order.CCPO (m α)]
  [CompleteLattice l] [MAlgOrdered m l] where
  csup_lift {α : Type u} (xc : Set (m α)) (post : α -> l) :
    Lean.Order.chain xc ->
    ⨅ x ∈ xc, MAlg.lift x post <= MAlg.lift (Lean.Order.CCPO.csup xc) post

class MAlgTotal (m : Type u -> Type v) [Monad m] [∀ α, Lean.Order.CCPO (m α)]
  [CompleteLattice l] [MAlgOrdered m l] where
  bot_lift {α : Type u} (post : α -> l) :
    MAlg.lift (Lean.Order.bot : m α) post <= ⊥

class NoFailure (m : Type u -> Type v) [Monad m] [CompleteLattice l] [MAlgOrdered m l] where
  noFailure {α : Type u} (c : m α) :
    MAlg.lift c (fun _ => ⊤) = ⊤

class LogicLiftT (l : (Type u)) ( k : Type u) [CompleteLattice l] [CompleteLattice k] where
  [lift : MonadLiftT (Cont l) (Cont k)]
  lift_top {α : Type u} :
    monadLift (m := Cont l) (n := Cont k) (fun (_ : α -> l) => ⊤) = ⊤
  lift_bot {α : Type u} :
    monadLift (m := Cont l) (n := Cont k) (fun (_ : α -> l) => ⊥) = ⊥

class LogicLift (l : outParam (Type u)) ( k : Type u) [CompleteLattice l] [CompleteLattice k] where
  [lift : MonadLift (Cont l) (Cont k)]
  lift_top {α : Type u} :
    monadLift (m := Cont l) (n := Cont k) (fun (_ : α -> l) => ⊤) = ⊤
  lift_bot {α : Type u} :
    monadLift (m := Cont l) (n := Cont k) (fun (_ : α -> l) => ⊥) = ⊥

def LogicLift.refl [CompleteLattice l] : LogicLift l l where
  lift := by admit /- proof elided -/

instance [CompleteLattice l] [CompleteLattice k] [LogicLiftT l k] : MonadLiftT (Cont l) (Cont k) where
  monadLift := LogicLiftT.lift.monadLift

instance [CompleteLattice l] [CompleteLattice k] [LogicLift l k] : MonadLift (Cont l) (Cont k) where
  monadLift := LogicLift.lift.monadLift

instance {l} [CompleteLattice l] : LogicLiftT l l where
  lift_top := by admit /- proof elided -/

instance [CompleteLattice l] [CompleteLattice k] [CompleteLattice p] [linst₁ : LogicLiftT l k] [linst₂ : LogicLift k p] : LogicLiftT l p where
  lift_top := by admit /- proof elided -/

instance {l σ : Type u} [CompleteLattice l] : LogicLift l (σ -> l) where
  lift_top := by admit /- proof elided -/

class MAlgLift
  (m : semiOutParam (Type u -> Type v)) (l : semiOutParam (Type u)) [Monad m] [CompleteLattice l] [MAlgOrdered m l]
  (n : (Type u -> Type w)) (k : outParam (Type u)) [Monad n] [CompleteLattice k] [MAlgOrdered n k]
  [MonadLiftT m n]
  where
    [cl : LogicLift l k]
    μ_lift (x : m α) : MAlg.lift (liftM (n := n) x) f = liftM (n := Cont k) (MAlg.lift x) f

def MAlgLift.mk_rep  (m : semiOutParam (Type u -> Type v)) (l : semiOutParam (Type u)) [Monad m] [CompleteLattice l] [MAlgOrdered m l]
  (n : (Type u -> Type w)) (σ : Type u) [LawfulMonad m] [Monad n] [LawfulMonad n] [CompleteLattice k] [MAlgOrdered n (σ -> l)]
  [MonadLiftT m n] [LawfulMonadLiftT m n]
  (μ_lift : ∀ (x : m (σ → l)),
    MAlgOrdered.μ (liftM (n := n) x) =
    fun s => MAlgOrdered.μ ((· s) <$> x)) : MAlgLift m l n (σ → l) :=

def MAlgLift.mk_id  (m : semiOutParam (Type u -> Type v)) (l : semiOutParam (Type u)) [Monad m] [CompleteLattice l] [MAlgOrdered m l]
  (n : (Type u -> Type w)) [LawfulMonad m] [Monad n] [LawfulMonad n] [CompleteLattice k] [MAlgOrdered n l]
  [MonadLiftT m n] [LawfulMonadLiftT m n]
  (μ_lift : ∀ (x : m l),
    MAlgOrdered.μ (liftM (n := n) x) =
    MAlgOrdered.μ x) : MAlgLift m l n l :=

class MAlgLiftT
  (m : (Type u -> Type v)) (l : (Type u)) [Monad m] [CompleteLattice l] [MAlgOrdered m l]
  (n : (Type u -> Type w)) (k : outParam (Type u)) [Monad n] [CompleteLattice k] [MAlgOrdered n k]
  [MonadLiftT m n]
  where
    [cl : LogicLiftT l k]
    μ_lift (x : m α) : MAlg.lift (liftM (n := n) x) f = liftM (n := Cont k) (MAlg.lift x) f

instance MAlgLiftTRefl [Monad m] [CompleteLattice l] [LawfulMonad m] [MAlgOrdered m l] :
  MAlgLiftT m l m l where
    μ_lift := by admit /- proof elided -/

instance MAlgLiftTTrans
  [Monad m] [CompleteLattice l] [LawfulMonad m] [MAlgOrdered m l]
  [Monad n] [CompleteLattice k] [LawfulMonad n] [MAlgOrdered n k] [MonadLiftT m n]
  [Monad p] [CompleteLattice q] [LawfulMonad p] [MAlgOrdered p q] [MonadLift n p]
  [inst': MAlgLiftT m l n k] [inst: MAlgLift n k p q] :
  MAlgLiftT m l p q where
    cl := by admit /- proof elided -/

abbrev DiscrTreeKey := Array DiscrTree.Key

abbrev DiscrTreeExtension (α : Type) :=
  SimplePersistentEnvExtension (DiscrTreeKey × α) (DiscrTree α)

def mkDiscrTreeExtension [Inhabited α] [BEq α] (name : Name := by admit /- proof elided -/
) :
  IO (DiscrTreeExtension α) :=
  registerSimplePersistentEnvExtension {
    name          := name,
    addImportedFn := fun a => a.foldl (fun s a => a.foldl (fun s (k, v) => s.insertCore k v) s) DiscrTree.empty,
    addEntryFn    := fun s n => s.insertCore n.1 n.2 ,
  }

inductive Loom.SpecType where
  | triple
  | wpgen
deriving Inhabited, BEq, Repr

structure Loom.Spec where
  ty : Loom.SpecType
  name : Name
  prio : ℕ
deriving Inhabited, BEq, Repr

instance : Ord Loom.Spec where
  compare a b := if a.prio < b.prio then .lt else if a.prio > b.prio then .gt else .eq

structure SpecAttr where
  attr : AttributeImpl
  ext  : DiscrTreeExtension Loom.Spec
  deriving Inhabited

def attrIgnoreAuxDef (name : Name) (default : AttrM α) (x : AttrM α) : AttrM α := do
  
  if let .str _ "_mutual" := name then

    default
  else if let .str _ "_unary" := name then

    default
  else
    
    x

def getSpecKey (ty : Expr) : MetaM (Expr × Loom.SpecType) := do
  let (_xs, _bis, body) ← forallMetaTelescope ty
  let x <- match_expr body with
  | triple _m _mInst _α _l _lInst _mPropInst _pre x _post => pure (x, .triple)
  | WPGen _m _mInst _α _l _lInst _mPropInst x => pure (x, .wpgen)
  | _ => throwError s!"not a triple: {body}"
  
  
  
  
  return x

def SpecAttr.find? (s : SpecAttr) (e : Expr) : MetaM (Array Loom.Spec) := do
  (s.ext.getState (← getEnv)).getMatch e

def SpecAttr.getState (s : SpecAttr) : MetaM (DiscrTree Loom.Spec) := do
  return s.ext.getState (← getEnv)

abbrev SolverHints := Array Name

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

def findSpec (prog : Expr) : TacticM (Array (Ident × Loom.SpecType)) := do
  let specs ← specAttr.find? prog
  let grts := specs.qsort (compare · · |>.isGT) |>.map
    fun ⟨specType, specName, _⟩ => (mkIdent specName, specType)
  return grts

def Lean.MVarId.isWPGenGoal : MVarId → TacticM Bool
| mvarId => do
  let goalType <- mvarId.getType
  let_expr WPGen _m _mInst _α _l _lInst _mPropInst _ := goalType | return false
  return true

def isWPGenGoal : TacticM Bool := do
  (<- getMainGoal).isWPGenGoal

def hideNonWPGenGoals : TacticM Unit := do
  let goals <- getGoals
  let goals' <- goals.filterM (·.isWPGenGoal)
  setGoals goals'

def generateWPStep : TacticM (Bool × Expr) := withMainContext do
  let goalType <- getMainTarget
  let_expr WPGen _m _mInst _α _l _lInst _mPropInst x := goalType | throwError "{goalType} is not a WPGen"
  if let some app ← matchMatcherApp? x then
    let name := app.matcherName
    if let some res ← Loom.Matcher.constructWPGen name then
      
       
      withMainContext do
        let goal ← getMainGoal
        let tmp ← Loom.Matcher.partiallyInstantiateWPGen #[_α, _m, _mInst, _l] res app
        let goals ← goal.apply tmp
        replaceMainGoal goals
      return (true, x)
  let cs <- findSpec x
  for elem in cs do
    try
      match elem with
      | (spec, .wpgen) =>
        evalTactic $ <- `(tactic| apply $spec)
      | (spec, .triple) =>
        let info ← getConstInfo spec.getId
        let num_args := info.type.getNumHeadForalls
        let refine_part ←
          Array.foldlM
            (fun x li => `(term|$x $li))
            (←`(term| $spec))
            (Array.replicate num_args (←`(term|?_)))
        let refine_tac ← `(tactic|refine $refine_part)
        try
          evalTactic $ <- `(tactic|
          eapply $(mkIdent ``WPGen.spec_triple);
          apply $spec)
          return (true, x)
        catch _ =>
          evalTactic $ <- `(tactic|
          eapply $(mkIdent ``WPGen.spec_triple);
          $refine_tac)
          return (true, x)
      return (true, x)
    catch _ => continue
  let some ⟨rsx, _⟩ := x.getAppFn.const? | return (false, x)
  let rsxCorrect := (rsx.toString ++ "_correct").toName
  let some mainName ← getDeclName? | throwError s!"no lemma name found for goal:{goalType}"
  if mainName ≠ rsxCorrect then
    return (false, x)
  let mainNameIdent := mkIdent mainName
  try
    evalTactic $ <- `(tactic|
        wpgen_generate_size_conditions;
        eapply $(mkIdent ``WPGen.spec_triple);
        apply $mainNameIdent)
    return (true, x)
  catch _ =>
    return (false, x)

def Lean.Expr.getName (e : Expr) : MetaM Name := do
  match_expr e with
  | Name.mkStr _ n =>
    match n with
    | .lit (.strVal n) => return n.toName
    | _                => throwError "expected a string literal1"
  | _ => throwError "expected a string literal3"

partial def Lean.Expr.getNamesProp (tp : Expr) : MetaM (Option (List Name)) := do
  match_expr tp with
  | WithName _ n₁ => return some [<- n₁.getName]
  | MProdWithNames _ tr n₁ =>
    let n₁ <- n₁.getName
    let some ns <- tr.getNamesProp
      | return none
    return some $ n₁ :: ns
  | _ =>
    let .some typeWithNameExpr := tp.find? (fun e => e.isAppOf ``typeWithName)
      | return none
    let nname := typeWithNameExpr.getAppArgs[2]!
    return some [<- nname.getName]

def renameOld (n : Name) : TacticM Unit := withMainContext do
  (<- getMainGoal).modifyLCtx fun hyps => Id.run do
    let mut hypsNew := hyps
    for hyp in hyps.decls.toArray.reverse do
      if hyp.isSome then
        let n' := hyp.get!.userName
        if n' == n then
          hypsNew := hyps.renameUserName n' (n'.toString ++ "Old" |>.toName)
    return hypsNew

instance angelic_exception: MonadExceptOf String CashmereM where
  throw e := liftM (m := ExceptT String (StateT Bal DivM)) (throw e)
  tryCatch := fun x _ => x

instance MAlgGenInst : MAlgOrdered Gen (ULift Nat -> ULift StdGen -> Prop) :=
  inferInstanceAs
    (MAlgOrdered
      (ReaderT (ULift Nat)
        (StateT (ULift StdGen) Id))
      (ULift Nat ->
        ULift StdGen -> Prop))

abbrev Except.getD {ε α} (default : ε -> α)  : Except ε α -> α
  | Except.ok p => p
  | Except.error e => default e

abbrev Except.bind' {m : Type u -> Type v} {ε α β} [Monad m] : Except ε α -> (α -> ExceptT ε m β) -> ExceptT ε m β :=
  fun x f => bind (m := ExceptT ε m) (pure (f := m) x) f

def MAlgExcept (ε : Type u) (df : ε -> Prop) (l : Type u) (m : Type u -> Type v)
  [CompleteLattice l]
  [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l] : MAlgOrdered (ExceptT ε m) l where
  μ := fun e => inst.μ $ Except.getD (⌜df ·⌝) <$> e
  μ_ord_pure := by admit /- proof elided -/

class IsHandler {ε : Type*} (handler : outParam (ε -> Prop)) where

instance OfHd {hd : ε -> Prop} [hdInst : IsHandler hd]
  [CompleteLattice l] [inst: MAlgOrdered m l] : MAlgOrdered (ExceptT ε m) l := MAlgExcept ε hd l m

instance MAlgExceptHdDet (hd : ε -> Prop)
  [CompleteLattice l] [inst: MAlgOrdered m l] [IsHandler hd]
  [inst': MAlgDet m l] : MAlgDet (ExceptT ε m) l where
  angelic := by admit /- proof elided -/

instance
  [CompleteLattice l] [inst: MAlgOrdered m l] [IsHandler (fun (_ : ε) => True)]
  [inst': NoFailure m] : NoFailure (ExceptT ε m) where
  noFailure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [IsHandler (ε := ε) hd]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (ExceptT ε m) l where
    cl := by admit /- proof elided -/

namespace ExceptionAsSuccess
scoped instance PartialHandler {ε} : IsHandler (ε := ε) fun _ => True where
end ExceptionAsSuccess

namespace ExceptionAsFailure
scoped instance TotalHandler {ε} : IsHandler (ε := ε) fun _ => False where
end ExceptionAsFailure

instance [Monad m] [inst : ∀ α, CCPO (m α)] : CCPO (ExceptT ε m α) := inst _

instance [Monad m] [∀ α, CCPO (m α)] [MonoBind m] : MonoBind (ExceptT ε m) where
  bind_mono_left h₁₂ := by admit /- proof elided -/

instance [Monad m] [CCPOBot m] : CCPOBot (ExceptT ε m) where
  compBot := CCPOBot.compBot (m := m)

instance [Monad m] [inst : ∀ α, Lean.Order.CCPO (m α)] [CCPOBot m] [CCPOBotLawful m] : CCPOBotLawful (ExceptT ε m) where
  prop := CCPOBotLawful.prop (m := m)

instance (hd : ε -> _) [IsHandler hd] [_root_.CompleteLattice l] [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)] [MonoBind m]
  [MAlgPartial m] : MAlgPartial (ExceptT ε m) where
  csup_lift {α} chain := by admit /- proof elided -/

instance (hd : ε -> _) [IsHandler hd] [_root_.CompleteLattice l] [Monad m] [LawfulMonad m] [inst: MAlgOrdered m l]
  [∀ α, CCPO (m α)] [MonoBind m]
  [MAlgTotal m] : MAlgTotal (ExceptT ε m) where
  bot_lift := by admit /- proof elided -/

class PreOrderFunctor where preord : (α : Type u) -> Preorder (w α)

instance [inst: (α : Type u) -> Preorder (w α)] : PreOrderFunctor w := ⟨inst⟩

instance (α : Type u) [inst: PreOrderFunctor w] : Preorder (w α) := inst.preord α

class MonadOrder extends Monad w, PreOrderFunctor w where
  bind_le {α : Type u} {β : Type u} (x y : w α) (f g : α -> w β) :
    x ≤ y → (∀ a, f a ≤ g a) → bind x f ≤ bind y g

instance [Monad m] : LawfulMonadLiftT m m where
  monadLift_pure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] : LawfulMonadLiftT m (StateT σ m) where
  monadLift_pure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] : LawfulMonadLiftT m (ReaderT σ m) where
  monadLift_pure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m] : LawfulMonadLiftT m (ExceptT ε m) where
  monadLift_pure := by admit /- proof elided -/

instance [Monad m] [LawfulMonad m]
  [Monad n] [LawfulMonad n] [MonadLiftT m n] [inst: LawfulMonadLiftT m n]
  [Monad p] [LawfulMonad p] [MonadLift n p] [inst':LawfulMonadLiftT n p]
  : LawfulMonadLiftT m p where
    monadLift_pure := by admit /- proof elided -/

abbrev Bal := Int

abbrev CashmereM := NonDetT (ExceptT String (StateT Bal DivM))

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

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

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

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

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

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

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

abbrev doSeq := TSyntax ``Term.doSeq

abbrev doSeqItem := TSyntax ``Term.doSeqItem

def termBeforeReqEnsDo := withForbidden "require" (withForbidden "ensures" Term.termBeforeDo)

private def toBracketedBinderArrayLeafny (stx : Array (TSyntax `leafny_binder)) : MetaM (TSyntaxArray `Lean.Parser.Term.bracketedBinder) := do
  let mut binders := #[]
  for b in stx do
    match b with
    | `(leafny_binder| ($id:ident : $tp:term)) => do
      let fb ← `(bracketedBinder| ($id : $tp:term))
      binders := binders.push fb
    | `(leafny_binder| (mut $id:ident : $tp:term)) => do
      let fb ← `(bracketedBinder| ($id : $tp:term))
      binders := binders.push fb
    | _ => throwError "unexpected syntax in leafny binder: {b}"
  return binders

def getMutTypes (stx : Array (TSyntax `leafny_binder)) : MetaM (Array (TSyntax `term)) := do
  let mut types := #[]
  for b in stx do
    match b with
    | `(leafny_binder| (mut $_:ident : $tp:term)) => do
      types := types.push tp
    | _ => pure ()
  return types

def getModIds (stx : Array (TSyntax `leafny_binder)) : MetaM (Array (Nat × Ident)) := do
  let mut ids := #[]
  let mut pos := 0
  for b in stx do
    match b with
    | `(leafny_binder| (mut $id:ident : $_:term)) => do
      ids := ids.push (pos, id)
      pos := pos + 1
    | _ => pos := pos + 1
  return ids

def getIds (stx : Array (TSyntax `leafny_binder)) : MetaM (Array Ident) := do
  let mut ids := #[]
  for b in stx do
    match b with
    | `(leafny_binder| (mut $id:ident : $_:term)) => do
      ids := ids.push id
    | `(leafny_binder| ($id:ident : $_:term)) => do
      ids := ids.push id
    | _ => throwError "unexpected syntax in leafny binder: {b}"
  return ids

partial def expandLeafnyDoSeq (modIds : Array Ident) (stx : doSeq) : TermElabM (Array doSeqItem) :=
  match stx with
  | `(doSeq| $doS:doSeqItem*) => return Array.flatten $ ← doS.mapM (expandLeafnyDoSeqItem modIds)
  | _ => throwErrorAt stx s!"unexpected syntax of Velvet `do`-notation sequence {stx}"

partial def expandLeafnyDoSeqItem (modIds : Array Ident) (stx : doSeqItem) : TermElabM (Array doSeqItem) := do
  match stx with
  
  | `(Term.doSeqItem| $stx ;) => expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| $stx:doElem)
  | `(Term.doSeqItem| return) =>
    let mut ret <- `(term| $(modIds[0]!))
    return #[<-`(Term.doSeqItem| set ($ret)), <-`(Term.doSeqItem| return ())]
  | `(Term.doSeqItem| return $t) =>
    let mut ret <- `(term| $(modIds[0]!))
    return #[<-`(Term.doSeqItem| set ($ret)), <-`(Term.doSeqItem| return $t)]
  | `(Term.doSeqItem| pure $t) =>
    let mut ret <- `(term| ())
    for modId in modIds do
      ret <- `(term| ⟨$modId, $ret⟩)
    return #[<-`(Term.doSeqItem| pure ⟨$t, $ret⟩)]
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn:doSeq else $els:doSeq) =>
    let thn <- expandLeafnyDoSeq modIds thn
    let els <- expandLeafnyDoSeq modIds els
    let ret ← `(Term.doSeqItem| if $h:ident : $t then $thn* else $els*)
    return #[ret]
  | `(Term.doSeqItem| if $h:ident : $t:term then $thn) =>
    expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| if $h:ident : $t:term then $thn else pure ())
  | `(Term.doSeqItem| if $t:term then $thn:doSeq) =>
    expandLeafnyDoSeqItem modIds $ <- `(Term.doSeqItem| if $t then $thn:doSeq else pure ())
  | `(Term.doSeqItem| if $t:term then $thn:doSeq else $els:doSeq) =>
    let thn <- expandLeafnyDoSeq modIds thn
    let els <- expandLeafnyDoSeq modIds els
    let ret ← `(Term.doSeqItem| if $t then $thn* else $els*)
    return #[ret]
  | `(Term.doSeqItem| let $id <- $trm:term) | `(Term.doSeqItem| let $id : $_ <- $trm:term) =>
    let `($t:ident $args:term*) := trm | pure #[stx]
    
    let ctx <- globalMutVarsCtx.get
    let .some ids := ctx[t.getId]? | pure #[stx]
    let mut mods := #[]
    let mut modArgs := #[]
    for (pos, a) in ids do
      let .some arg := args[pos]? | throwErrorAt stx s!"{t} is not fully applied"
      
      let argName := arg.raw.getId
      if argName.isAnonymous then throwErrorAt arg s!"mutable argument {arg} is not a name"
      if argName ∈ modArgs then throwErrorAt arg s!"mutable arguments cannot alias"
      modArgs := modArgs.push argName
      mods := mods.push $ <- withRef arg `(Term.doSeqItem| $(mkIdent argName):ident := $a:ident)
    return #[<-`(Term.doSeqItem| let ⟨$id, _⟩ <- $trm:term)] ++ mods
  | `(Term.doSeqItem| $trm:term) =>
    let id := mkIdent <| <- mkFreshUserName `ret
    let `($t:ident $args:term*) := trm | pure #[stx]
    
    let ctx <- globalMutVarsCtx.get
    let .some ids := ctx[t.getId]? | pure #[stx]
    let mut mods := #[]
    let mut modArgs := #[]
    for (pos, a) in ids do
      let .some arg := args[pos]? | throwErrorAt stx s!"{t} is not fully applied"
      
      let argName := arg.raw.getId
      if argName.isAnonymous then throwErrorAt arg s!"mutable argument {arg} is not a name"
      if argName ∈ modArgs then throwErrorAt arg s!"mutable arguments cannot alias"
      modArgs := modArgs.push argName
      mods := mods.push $ <- withRef arg `(Term.doSeqItem| $(mkIdent argName):ident := $a:ident)
    let ret <- withRef trm `(Term.doSeqItem| pure $id)
    return #[<- withRef trm `(Term.doSeqItem| let ⟨$id, _⟩ <- $trm:term)] ++ mods.push ret
  | `(Term.doSeqItem| while_some $id :| $p:term $invs* $done do $doSeq:doSeq) =>
    let doSeq <- expandLeafnyDoSeq modIds doSeq
    return #[<-`(Term.doSeqItem| while_some $id :| $p:term $invs* $done do $doSeq*)]
  | stx => pure #[stx]

private def Array.andListWithName (ts : Array (TSyntax `term)) (name_prefix : TSyntax `name) : TermElabM (TSyntax `term) := do
  if ts.size = 0 then `(term| True) else
    let mut t <- `(term| with_name_prefix $name_prefix:name $(ts[0]!))
    for t' in ts[1:] do
      t <- `(term| (with_name_prefix $name_prefix:name $t') ∧ $t)
    return t

private def Array.andList (ts : Array (TSyntax `term)) : TermElabM (TSyntax `term) := do
  if ts.size = 0 then `(term| True) else
    let mut t := ts[0]!
    for t' in ts[1:] do
      t <- `(term| $t' ∧ $t)
    return t

def atomicAssertion {α : Type u} (n : Name) (a : α) := a

def List.nonEmpty (q : List α) : Prop :=
  ¬q.isEmpty

instance (q : List α) : Decidable q.nonEmpty :=
  inferInstanceAs (Decidable (¬q.isEmpty))

inductive NonDetT (m : Type u -> Type v) : (α : Type u) -> Type _ where
  | pure {α} (ret : α) : NonDetT m α
  | vis {α} {β} (x : m β) (f : β → NonDetT m α) : NonDetT m α
  | pickCont {α} (τ : Type u) (p : τ -> Prop) [Findable p] (f : τ → NonDetT m α) : NonDetT m α
  | repeatCont {α} {β} (init : β) (f : β -> NonDetT m (ForInStep β)) (cont : β -> NonDetT m α) : NonDetT m α

def NonDetT.bind (x : NonDetT m α) (f : α → NonDetT m β) : NonDetT m β :=
  match x with
  | pure ret => f ret
  | vis x f' => vis x fun y => bind (f' y) f
  | pickCont τ p f' => pickCont τ p fun t => bind (f' t) f
  | repeatCont init f' cont => repeatCont init f' fun t => bind (cont t) f

instance : Monad (NonDetT m) where
  pure := NonDetT.pure
  bind := NonDetT.bind

instance [LawfulMonad m] : LawfulMonad (NonDetT m) :=

def NonDetT.pick (τ : Type u) [Inhabited τ] : NonDetT m τ :=
  NonDetT.pickCont _ (fun _ => True) pure

def NonDetT.assume (as : Prop) [Decidable as] : NonDetT m PUnit :=
  NonDetT.pickCont PUnit (fun _ => as) fun _ => pure .unit

def NonDetT.pickSuchThat (τ : Type u) (p : τ → Prop) [Findable p] : NonDetT m τ :=
  NonDetT.pickCont τ p pure

def NonDetT.repeat (init : α) (f : α -> NonDetT m (ForInStep α)) : NonDetT m α :=
  NonDetT.repeatCont init f pure

class MonadNonDet (m : Type u → Type v) where
  pick : (τ : Type u) → [Inhabited τ] → m τ
  
  pickSuchThat : (τ : Type u) → (p : τ → Prop) → [Findable p] → m τ
  assume : (as : Prop) → [Decidable as] → m PUnit.{u+1}
  
  rep {α : Type u} : α → (α → m (ForInStep α)) → m α

instance : MonadNonDet (NonDetT m) where
  pick   := .pick
  assume := .assume
  pickSuchThat := .pickSuchThat
  rep := .repeat

namespace PartialCorrectness.DemonicChoice
def NonDetT.wp {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : {α : Type u} -> NonDetT m α -> Cont l α
  | _, .pure ret => pure ret
  | _, .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | _, @NonDetT.pickCont _ _ τ p _ f =>
  fun post =>
    let p : Set τ := p;
    ⨅ a ∈ (p : Set τ), wp (f a) post
  | _, @NonDetT.repeatCont _ _ β init f cont => fun post => ⨆ (inv : ForInStep β -> l),
      ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
      spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
def NonDetT.μ  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
instance {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
instance [MonadNonDet m] : ForIn m Lean.Loop Unit where
  forIn {β} _ _ init f := @MonadNonDet.rep m _ β init (f ())
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
def WPGen.forWithInvariantLoop {β}
  {init : β} {f : Unit -> β → NonDetT m (ForInStep β)}
  (inv : β → List l) (on_done' : β → l)
  (measure : β → Option ℕ)
  (wpg : ∀ b, WPGen (f () b)) :
    WPGen (forIn Lean.Loop.mk init (fun u b => do
        invariantGadget (inv b)
        onDoneGadget (on_done' b)
        decreasingGadget (measure b)
        f u b)) where
    get := ⌜∀ b, invariantSeq (inv b) <= (wpg b).get fun
      | .yield b' => invariantSeq <| inv b'
      | .done b'  => invariantSeq (inv b') ⊓ on_done' b'⌝
      ⊓ spec
      ((inv init).foldr (·⊓·) ⊤)
      (fun b => (inv b).foldr (·⊓·) ⊤ ⊓ on_done' b)
    prop := by admit /- proof elided -/
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.AngelicChoice
def NonDetT.wp {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : {α : Type u} -> NonDetT m α -> Cont l α
  | _, .pure ret => pure ret
  | _, .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | _, @NonDetT.pickCont _ _ τ p _ f => fun post => ⨆ a, ⌜p a⌝ ⊓ wp (f a) post
  | _, .repeatCont init f cont => fun post => ⨆ (inv : ForInStep _ -> l),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
def NonDetT.μ {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
instance {l : outParam (Type u)} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
instance [MonadNonDet m] : ForIn m Lean.Loop Unit where
  forIn {β} _ _ init f := @MonadNonDet.rep m _ β init (f ())
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
def WPGen.forWithInvariantLoop {β}
  {init : β} {f : Unit -> β → NonDetT m (ForInStep β)}
  (inv : β → List l) (on_done' : β → l)
  (measure : β → Option ℕ)
  (wpg : ∀ b, WPGen (f () b)) :
    WPGen (forIn Lean.Loop.mk init (fun u b => do
        invariantGadget (inv b)
        onDoneGadget (on_done' b)
        decreasingGadget (measure b)
        f u b)) where
    get := ⌜∀ b, invariantSeq (inv b) <= (wpg b).get fun
      | .yield b' => invariantSeq <| inv b'
      | .done b'  => invariantSeq (inv b') ⊓ on_done' b'⌝
      ⊓ spec
      ((inv init).foldr (·⊓·) ⊤)
      (fun b => (inv b).foldr (·⊓·) ⊤ ⊓ on_done' b)
    prop := by admit /- proof elided -/
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end PartialCorrectness.AngelicChoice

namespace TotalCorrectness.DemonicChoice
def NonDetT.wp {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : {α : Type u} -> NonDetT m α -> Cont l α
  | _, .pure ret => pure ret
  | _, .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | _, @NonDetT.pickCont _ _ τ p _ f => fun post => let p : Set τ := p; ⌜∃ h, p h⌝ ⊓  ⨅ a ∈ (p : Set τ), wp (f a) post
  | _, @NonDetT.repeatCont _ _ β init f cont => fun post => ⨆ (inv : ForInStep β -> l) (measure : β -> Nat),
      ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
      spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
def NonDetT.μ {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
instance {l : outParam (Type u)} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
instance [MonadNonDet m] : ForIn m Lean.Loop Unit where
  forIn {β} _ _ init f := @MonadNonDet.rep m _ β init (f ())
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
def WPGen.forWithInvariantLoop {β}
  {init : β} {f : Unit -> β → NonDetT m (ForInStep β)}
  (inv : β → List l) (on_done' : β → l) (measure : β → Nat)
  (wpg : ∀ b, WPGen (f () b)) : WPGen (forIn Lean.Loop.mk init (fun u b => do
        invariantGadget (inv b)
        onDoneGadget (on_done' b)
        decreasingGadget (measure b)
        f u b)) where
    get := ⌜∀ b, invariantSeq (inv b) <= (wpg b).get fun
      | .yield b' => (invariantSeq (inv b')) ⊓ ⌜with_name_prefix `decreasing (measure b' < measure b)⌝
      | .done b'  => invariantSeq (inv b') ⊓ on_done' b'⌝
      ⊓ spec
        ((inv init).foldr (·⊓·) ⊤)
        (fun b => (inv b).foldr (·⊓·) ⊤ ⊓ on_done' b)
    prop := by admit /- proof elided -/
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.AngelicChoice
def   NonDetT.wp {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : {α : Type u} -> NonDetT m α -> Cont l α
  | _, .pure ret => pure ret
  | _, .vis x f => fun post => _root_.wp x fun a => wp (f a) post
  | _, @NonDetT.pickCont _ _ _ p _ f => fun post => ⨆ a, ⌜p a⌝ ⊓ wp (f a) post
  | _, .repeatCont init f cont => fun post => ⨆ (inv : ForInStep _ -> l) (measure : _ -> Nat),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
def NonDetT.μ {l : Type u} [CompleteLattice l] [MAlgOrdered m l] : NonDetT m l -> l := fun x => NonDetT.wp x id
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
instance : MonadLift m (NonDetT m) where
  monadLift x := NonDetT.vis x pure
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
instance {l : outParam (Type u)} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] : MAlgOrdered (NonDetT m) l where
  μ := NonDetT.μ
  μ_ord_pure := by admit /- proof elided -/
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
instance [MonadNonDet m] : ForIn m Lean.Loop Unit where
  forIn {β} _ _ init f := @MonadNonDet.rep m _ β init (f ())
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
def WPGen.forWithInvariantLoop {β}
  {init : β} {f : Unit -> β → NonDetT m (ForInStep β)}
  (inv : β → List l) (on_done' : β → l) (measure: β -> Nat) (wpg : ∀ b, WPGen (f () b)): WPGen (forIn Lean.Loop.mk init (fun u b => do
        invariantGadget (inv b)
        onDoneGadget (on_done' b)
        decreasingGadget (measure b)
        f u b)) where
    get := ⌜∀ b, invariantSeq (inv b) <= (wpg b).get fun
      | .yield b' => (invariantSeq (inv b')) ⊓ ⌜with_name_prefix `decreasing (measure b' < measure b)⌝
      | .done b'  => invariantSeq (inv b') ⊓ on_done' b'⌝
      ⊓ spec
        ((inv init).foldr (·⊓·) ⊤)
        (fun b => (inv b).foldr (·⊓·) ⊤ ⊓ on_done' b)
    prop := by admit /- proof elided -/
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
instance [Monad m] [LawfulMonad m] [_root_.CompleteLattice l]
  [inst: MAlgOrdered m l] :
  MAlgLift m l (NonDetT m) l where
    cl := by admit /- proof elided -/
end TotalCorrectness.AngelicChoice

abbrev Cont (t : Type v) (α : Type u) := (α -> t) -> t

instance (t : Type v) : Monad (Cont t) where
  pure x := fun f => f x
  bind x f := fun g => x (fun a => f a g)

def Cont.inv {t : Type v} {α : Type u} [BooleanAlgebra t] (wp : Cont t α) : Cont t α :=
  fun f => (wp fun x => (f x)ᶜ)ᶜ

@[simp]
def Cont.monotone {t : Type v} {α : Type u} [Preorder t] (wp : Cont t α) :=
  ∀ (f f' : α -> t), (∀ a, f a ≤ f' a) → wp f ≤ wp f'

structure W (t : Type v) [Preorder t] (α : Type u) where
  wp : Cont t α
  wp_montone : wp.monotone

instance (t : Type v) [Preorder t] : Monad (W t) where
  pure x := ⟨fun f => f x, by admit /- proof elided -/
  ⟩
  bind x f := ⟨fun g => x.wp (fun a => (f a).wp g), by admit /- proof elided -/
  ⟩

instance {l σ : Type u} : MonadLift (Cont l) (Cont (σ -> l)) where
  monadLift x := fun f s => x (f · s)

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

Lake.JobM in Lake.Build.Job.Monad

Lake.Package in Lake.Config.Package

IO.FS.removeDirAll in Init.System.IO

IO.FS.removeFile in Init.System.IO

Lake.logError in Lake.Util.Log

Lake.logInfo in Lake.Util.Log

Array in Init.Prelude

Lake.Job.collectArray in Lake.Build.Job.Monad

Lake.buildFileAfterDep in Lake.Build.Common

Lake.inputTextFile in Lake.Build.Common

Lake.Glob in Lake.Config.Glob

Nat in Init.Prelude

Lean.Name in Init.Prelude

Std.HashMap in Std.Data.HashMap.Basic

Inhabited in Init.Prelude

Lean.Parser.Term.bracketedBinder in Lean.Parser.Term.Basic

Lean.TSyntaxArray in Init.Prelude

Lean.TSyntax in Init.Prelude

Lean.MonadEnv in Lean.Environment

Lean.SimpleScopedEnvExtension in Lean.ScopedEnvExtension

Monad in Init.Prelude

Lean.SimplePersistentEnvExtension in Lean.EnvExtension

Lean.Elab.Tactic.TacticM in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.getMainTarget in Lean.Elab.Tactic.Basic

Lean.Elab.Tactic.withMainContext in Lean.Elab.Tactic.Basic

Lean.Meta.ppExpr in Lean.Meta.Basic

Option in Init.Prelude

Lean.throwError in Lean.Exception

id in Init.Prelude

parse in Auto.Parser.TPTP

Array.replicate in Init.Data.Array.Basic

AddCommMonoid in Mathlib.Algebra.Group.Defs

Finset in Mathlib.Data.Finset.Defs

Finset.range in Mathlib.Data.Finset.Range

Bool in Init.Prelude

FinEnum in Mathlib.Data.FinEnum

Repr in Init.Data.Repr

FinEnum.toList in Mathlib.Data.FinEnum

Repr.reprPrec in Init.Data.Repr

List in Init.Prelude

List.range in Init.Data.List.Basic

Decidable in Init.Prelude

Lean.MacroM in Init.Prelude

Lean.Parser.Tactic.tacticSeq in Lean.Parser.Term.Basic

term in Auto.Parser.TPTP

Lean.mkIdent in Init.Meta.Defs

IO.Process.Child in Init.System.IO

IO.FS.Handle in Init.System.IO

Command.toString in Auto.IR.SMT

Lean.Core.Context in Lean.CoreM

Lean.mkStrLit in Lean.Expr

System.FilePath.mk in Init.System.FilePath

readThe in Init.Prelude

Auto.hints in Auto.Tactic

Lean.MVarId in Lean.Expr

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

Lean.trace in Lean.Util.Trace

Lemma.ofConst in Auto.Translation.Assumptions

Lemma.rewriteUPolyRigid in Auto.Translation.Assumptions

Prod in Init.Prelude

Prod.snd in Init.Prelude

String.intercalate in Init.Data.String.Defs

absurd in Init.Prelude

error in Auto.Parser.TPTP

lamEVarTy in Auto.Parser.TPTP

leaf in Test.SmtTranslation.Inductive

Unit in Init.Prelude

IO.Process.spawn in Init.System.IO

System.mkFilePath in Init.System.FilePath

Lean.Meta.Simp.getSimprocExtension? in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.getSimpExtension? in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Expr in Lean.Expr

Lean.Expr.const in Lean.Expr

Lean.Meta.MetaM in Lean.Meta.Basic

Lean.Meta.Simp.isBuiltinSimproc in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.Simp.isSimproc in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.Simp.Context in Lean.Meta.Tactic.Simp.Types

Lean.Expr.fvar in Lean.Expr

Lean.Meta.getPropHyps in Lean.Meta.Tactic.Util

Lean.Meta.ConfigWithKey in Lean.Meta.Basic

Lean.Meta.Origin in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Meta.SimpEntry.thm in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Meta.isProp in Lean.Meta.InferType

Lean.Meta.mkSimpEntryOfDeclToUnfold in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Meta.mkSimpTheoremFromConst in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Meta.mkSimpTheoremFromExpr in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.getConstVal in Lean.MonadEnv

Lean.Syntax in Init.Prelude

Lean.Meta.abstractMVars in Lean.Meta.AbstractMVars

Lean.instantiateMVars in Lean.MetavarContext

Lean.withRef in Init.Prelude

Lean.Parser.Tactic.simpErase in Init.Tactics

observing in Init.Control.Except

Lean.Parser.Tactic.simpLemma in Init.Tactics

Lean.Parser.Tactic.simpPost in Init.Tactics

Lean.Parser.Tactic.simpStar in Init.Tactics

Lean.mkFreshId in Init.Meta.Defs

Lean.Meta.Simp.SimprocsArray in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.withTrackingZetaDeltaSet in Lean.Meta.Basic

Lean.Meta.getZetaDeltaFVarIds in Lean.Meta.Basic

IO.Ref in Init.System.IO

IO.mkRef in Init.System.IO

Lean.Meta.Simp.Discharge in Lean.Meta.Tactic.Simp.Rewrite

getThe in Init.Prelude

Lean.Expr.mvar in Lean.Expr

Lean.Meta.mkFreshExprSyntheticOpaqueMVar in Lean.Meta.Tactic.Util

Lean.Meta.simp in Lean.Meta.Tactic.Simp.Main

liftM in Init.Prelude

Lean.Meta.SimpTheorems in Lean.Meta.Tactic.Simp.SimpTheorems

Lean.Meta.getSimpTheorems in Lean.Meta.Tactic.Simp.Attr

Lean.Meta.Simp.getSimprocs in Lean.Meta.Tactic.Simp.Simproc

Lean.Meta.Simp.mkContext in Lean.Meta.Tactic.Simp.Types

Lean.Meta.getSimpCongrTheorems in Lean.Meta.Tactic.Simp.SimpCongrTheorems

Lean.Meta.Simp.Result in Lean.Meta.Tactic.Simp.Types

Lean.Meta.reduceAll in Lean.Meta.Reduce

Lean.Meta.withTransparency in Lean.Meta.Basic

Lean.Declaration.thmDecl in Lean.Declaration

Lean.addDecl in Lean.AddDecl

Lean.mkTheoremValEx in Lean.Declaration

Lean.binderIdent in Init.Notation

Lean.explicitBinders in Init.NotationExtra

Lean.bracketedExplicitBinders in Init.NotationExtra

Lean.Parser.Term.funBinder in Lean.Parser.Term

CompleteBooleanAlgebra in Mathlib.Order.CompleteBooleanAlgebra

LawfulMonad in Init.Control.Lawful.Basic

Empty in Init.Prelude

BooleanAlgebra in Mathlib.Order.BooleanAlgebra.Defs

f in Test.SmtTranslation.Trigger

Preorder in Mathlib.Order.Defs.PartialOrder

MonadLift in Init.Prelude

LawfulMonadLiftT in Init.Control.Lawful.MonadLift.Basic

MonadLiftT in Init.Prelude

StateT in Init.Control.State

ReaderT in Init.Prelude

ExceptT in Init.Control.Except

LawfulMonadLift in Init.Control.Lawful.MonadLift.Basic

ForInStep in Init.Core

ForInStep.yield in Init.Core

LE in Init.Prelude

And in Init.Prelude

Lean.Order.CCPO in Init.Internal.Order.Basic

Lean.Order.MonoBind in Init.Internal.Order.Basic

Lean.EnvExtension in Lean.Environment

Lean.setEnv in Lean.MonadEnv

Lean.Parser.Term.doSeq in Lean.Parser.Do

Lean.Parser.Term.doSeqItem in Lean.Parser.Do

Lean.Parser.Term.termBeforeDo in Lean.Parser.Do

Lean.Parser.withForbidden in Lean.Parser.Basic

Lean.Parser.ident in Lean.Parser.Extra

Lean.Parser.mkIdent in Lean.Parser.Types

Lean.Parser.Term.matchAlt in Lean.Parser.Term

Array.flatten in Init.Data.Array.Basic

Lean.throwErrorAt in Lean.Exception

sequence in Mathlib.Control.Traversable.Basic

Lean.Parser.skip in Lean.Parser.Basic

instDecidableAnd in Init.Prelude

Array.setIfInBounds in Init.Data.Array.Set

Multiset in Mathlib.Data.Multiset.Defs

Multiset.ofList in Mathlib.Data.Multiset.Defs

Array.count in Init.Data.Array.Basic

MonadExceptOf in Init.Prelude

Int in Init.Data.Int.Basic

Int.toNat in Init.Data.Int.Basic

List.sum in Init.Data.List.Basic

inferInstanceAs in Init.Prelude

List.length in Init.Prelude

List.tail in Init.Data.List.Basic

List.head! in Init.Data.List.BasicAux

Except in Init.Prelude

Except.error in Init.Prelude

ExceptT.run in Init.Control.Except

Functor in Init.Prelude

Functor.map in Init.Prelude

StateT.run in Init.Control.State

Char in Init.Prelude

List.cons in Init.Prelude

List.nil in Init.Prelude

List.take in Init.Data.List.Basic

List.replicate in Init.Data.List.Basic

Array.mk in Init.Prelude

Array.map in Init.Data.Array.Basic

GetElem in Init.GetElem

List.zip in Init.Data.List.Basic

List.find? in Init.Data.List.Basic

LT in Init.Prelude

Array.extract in Init.Prelude

Array.filter in Init.Data.Array.Basic

OrderBot in Mathlib.Order.BoundedOrder.Basic

OrderTop in Mathlib.Order.BoundedOrder.Basic

Lean.PrettyPrinter.Unexpander in Init.Prelude

CompleteLattice in Mathlib.Order.CompleteLattice.Defs

outParam in Init.Prelude

Cont in Mathlib.Control.Monad.Cont

PartialOrder in Mathlib.Order.Defs.PartialOrder

Bind in Init.Prelude

Bind.bind in Init.Prelude

Nonempty in Init.Prelude

Lean.Order.CCPO.csup in Init.Internal.Order.Basic

Lean.Order.chain in Init.Internal.Order.Basic

Set in Mathlib.Data.Set.Defs

Lean.Order.bot in Init.Internal.Order.Basic

instMonadLiftTOfMonadLift in Init.Prelude

MonadLift.monadLift in Init.Prelude

semiOutParam in Init.Prelude

BEq in Init.Prelude

Lean.registerSimplePersistentEnvExtension in Lean.EnvExtension

Ord in Init.Data.Ord.Basic

Lean.AttributeImpl in Lean.Attributes

Lean.AttrM in Lean.Attributes

Lean.BinderInfo in Lean.Expr

List.foldlM in Init.Data.List.Control

Unit.unit in Init.Prelude

Lean.ToExpr in Lean.ToExpr

LE.le in Init.Prelude

Lean.BinderInfo.implicit in Lean.Expr

Lean.ConstantInfo.type in Lean.Declaration

Lean.Expr.bindingDomain! in Lean.Expr

Lean.Expr.getForallBody in Lean.Expr

Lean.collectLevelParams in Lean.Util.CollectLevelParams

Lean.getConstInfo in Lean.MonadEnv

Lean.mkApp in Lean.Expr

Lean.mkAppN in Lean.Expr

Lean.mkArrow in Lean.CoreM

Lean.mkArrowN in Lean.CoreM

Lean.mkConst in Lean.Expr

List.map in Init.Prelude

List.toArray in Init.Prelude

Min in Init.Prelude

Min.min in Init.Prelude

Top in Mathlib.Order.Notation

Top.top in Mathlib.Order.Notation

iInf in Mathlib.Order.SetNotation

le in Test.SmtTranslation.Names

type in Auto.Lib.Rebind

Lean.Expr.getNumHeadForalls in Lean.Expr

Lean.Declaration.defnDecl in Lean.Declaration

Lean.DefinitionSafety.safe in Lean.Declaration

Lean.Parser.Term.attrInstance in Lean.Parser.Term

Lean.ReducibilityHints in Lean.Declaration

Lean.ReducibilityHints.regular in Lean.Declaration

Lean.enableRealizationsForConst in Lean.CoreM

Lean.mkDefinitionValEx in Lean.Declaration

Id in Init.Control.Id

Id.run in Init.Control.Id

Lean.Environment in Lean.Environment

Lean.Parser.termParser in Lean.Parser.Basic

Std.Range in Init.Data.Range.Basic

Lean.Name.anonymous in Init.Prelude

Lean.Name.mkStr in Init.Prelude

ULift in Init.Prelude

inline in Init.Core

Lean.Loop in Init.While

ForIn in Init.Core

Lean.Order.admissible in Init.Internal.Order.Basic

Lean.Order.admissible_pi_apply in Init.Internal.Order.Basic

List.range' in Init.Data.List.Basic

ExceptT.lift in Init.Control.Except

ExceptT.mk in Init.Control.Except

StateT.lift in Init.Control.State

MonadExceptOf.throw in Init.Prelude

throwThe in Init.Prelude

StateT.get in Init.Control.State

MonadStateOf in Init.Prelude

MonadStateOf.get in Init.Prelude

PUnit.unit in Init.Prelude

StateT.modifyGet in Init.Control.State

MonadStateOf.modifyGet in Init.Prelude

ReaderT.read in Init.Prelude

MonadReaderOf in Init.Prelude

MonadReaderOf.read in Init.Prelude

Lean.Parser.Term.doSeqBracketed in Lean.Parser.Do

Lean.Parser.Term.doSeqIndent in Lean.Parser.Do

Lean.SyntaxNodeKind in Init.Prelude

Lean.Parser.Term.termFor in Lean.Parser.Do

Lean.Parser.Term.termReturn in Lean.Parser.Do

Lean.Parser.Term.termTry in Lean.Parser.Do

Lean.Parser.Term.termUnless in Lean.Parser.Do

Lean.Parser.Term.letEqnsDecl in Lean.Parser.Term

Lean.Parser.Term.letIdDecl in Lean.Parser.Term

Lean.Parser.Term.letPatDecl in Lean.Parser.Term

Lean.Parser.Term.doLet in Lean.Parser.Do

Lean.Parser.Term.doLetArrow in Lean.Parser.Do

Lean.Parser.Term.doLetRec in Lean.Parser.Do

Lean.Parser.Term.letrec in Lean.Parser.Term

Lean.Parser.Term.matchAlts in Lean.Parser.Term

Lean.Parser.Term.liftMethod in Lean.Parser.Do

termDepIfThenElse in Init.Notation

termIfThenElse in Init.Notation

Lean.Meta.mkFreshExprMVar in Lean.Meta.Basic

Lean.Meta.mkFreshLevelMVar in Lean.Meta.Basic

Lean.mkLevelSucc in Lean.Level

Lean.mkSort in Lean.Expr

Lean.Elab.Term.TermElabM in Lean.Elab.Term.TermElabM

Lean.Meta.mkAppM in Lean.Meta.AppBuilder

Lean.Meta.synthInstance in Lean.Meta.SynthInstance

Lean.Meta.unfoldDefinition? in Lean.Meta.WHNF

Lean.Meta.whnfCore in Lean.Meta.WHNF

Lean.Parser.Term.app in Lean.Parser.Term

Lean.indentExpr in Lean.Message

Lean.Parser.Term.matchExpr in Lean.Parser.Term

Lean.Parser.Term.optIdent in Lean.Parser.Term.Basic

cond in Init.Prelude

ite in Init.Prelude

Lean.Name.cmp in Lean.Data.Name

Std.TreeMap in Std.Data.TreeMap.Basic

Lean.MessageData in Lean.Message

Lean.MessageData.joinSep in Lean.Message

Lean.MessageData.ofName in Lean.Message

Lean.MessageData.ofList in Lean.Message

Lean.MessageData.ofSyntax in Lean.Message

Lean.indentD in Lean.Message

Prod.fst in Init.Prelude

Lean.MonadQuotation in Init.Prelude

modify in Init.Prelude

Lean.Elab.liftMacroM in Lean.Elab.Util

Pure in Init.Prelude

Lean.mkNullNode in Init.Prelude

Lean.Parser.Term.unreachable in Lean.Parser.Term

Lean.HygieneInfo.mkIdent in Init.Meta.Defs

Lean.Parser.Term.letId in Lean.Parser.Term

Lean.hygieneInfoKind in Init.Prelude

Lean.Elab.Term.Quotation.getPatternVars in Lean.Elab.Quotation.Util

Lean.Elab.Term.getPatternVars in Lean.Elab.PatternVar

Lean.Elab.Term.Quotation.getPatternsVars in Lean.Elab.Quotation.Util

Lean.Elab.Term.getPatternsVars in Lean.Elab.PatternVar

kind in Auto.Parser.TPTP

Lean.Parser.Term.letDecl in Lean.Parser.Term

Lean.Parser.Term.doIdDecl in Lean.Parser.Do

Lean.Parser.Term.doPatDecl in Lean.Parser.Do

Lean.mkNode in Init.Prelude

Array.zip in Init.Data.Array.Basic

Lean.Parser.Term.doIfCond in Lean.Parser.Do

Lean.Parser.Term.doIfProp in Lean.Parser.Do

Lean.Syntax.missing in Init.Prelude

Lean.Parser.Term.matchExprPat in Lean.Parser.Term

Lean.quoteNameMk in Init.Meta.Defs

Lean.Parser.Term.doExpr in Lean.Parser.Do

Lean.Parser.Term.ident in Lean.Parser.Term

Lean.MonadRef in Init.Prelude

DoResultPR in Init.Core

DoResultPRBC in Init.Core

DoResultSBC in Init.Core

DoResultBC in Init.Core

Lean.Parser.Term.debugAssert in Lean.Parser.Term

Lean.Parser.Term.doAssert in Lean.Parser.Do

Lean.Parser.Term.doDbgTrace in Lean.Parser.Do

Lean.Parser.Term.doDebugAssert in Lean.Parser.Do

Lean.Elab.Term.expandOptType in Lean.Elab.BindersUtil

Lean.Parser.Term.letRecDecls in Lean.Parser.Term

Lean.Macro.throwErrorAt in Init.Prelude

Lean.Parser.Term.doHave in Lean.Parser.Do

Lean.Parser.Term.let_delayed in Lean.Parser.Term

Lean.mkIdentFromRef in Init.Meta.Defs

Lean.Syntax.mkApp in Init.Meta.Defs

Lean.mkIdentFrom in Init.Meta.Defs

Lean.Meta.instantiateMVarsIfMVarApp in Lean.Meta.Basic

Lean.Parser.Term.matchExprAlt in Lean.Parser.Term

Lean.Parser.Term.matchExprAlts in Lean.Parser.Term

Lean.Parser.Term.matchExprElseAlt in Lean.Parser.Term

Lean.Parser.Term.doLetElse in Lean.Parser.Do

Lean.Parser.Term.num in Lean.Parser.Term

Lean.Syntax.node in Init.Prelude

Lean.choiceKind in Init.Prelude

node in Test.SmtTranslation.Inductive

Lean.MonadQuotation.addMacroScope in Init.Prelude

Lean.Parser.Term.doReassign in Lean.Parser.Do

Lean.Parser.Term.doReassignArrow in Lean.Parser.Do

Lean.Parser.Term.optType in Lean.Parser.Term.Basic

Stream in Init.Data.Stream

Stream.next? in Init.Data.Stream

Lean.Elab.Term.expandMatchAlt in Lean.Elab.BindersUtil

Lean.Parser.Term.doCatch in Lean.Parser.Do

Lean.Parser.Term.doCatchMatch in Lean.Parser.Do

MonadExcept in Init.Prelude

MonadExcept.tryCatch in Init.Prelude

tryCatchThe in Init.Prelude

tryFinally in Init.Control.Except

Lean.Parser.Term.doBreak in Lean.Parser.Do

Lean.Parser.Term.doContinue in Lean.Parser.Do

Lean.Parser.Term.doFor in Lean.Parser.Do

Lean.Parser.Term.doIf in Lean.Parser.Do

Lean.Parser.Term.doMatch in Lean.Parser.Do

Lean.Parser.Term.doMatchExpr in Lean.Parser.Do

Lean.Parser.Term.doNested in Lean.Parser.Do

Lean.Parser.Term.doReturn in Lean.Parser.Do

Lean.Parser.Term.doTry in Lean.Parser.Do

Lean.Parser.Term.doUnless in Lean.Parser.Do

Lean.withIncRecDepth in Lean.Exception

Lean.Elab.Term.TermElab in Lean.Elab.Term.TermElabM

Lean.Elab.Term.elabTermEnsuringType in Lean.Elab.Term.TermElabM

Lean.Elab.Term.exprToSyntax in Lean.Elab.Term.TermElabM

Lean.Elab.Term.tryPostponeIfNoneOrMVar in Lean.Elab.Term.TermElabM

Lean.Elab.Term.withMacroExpansion in Lean.Elab.Term.TermElabM

Array.foldlM in Init.Data.Array.Basic

Lean.Expr.lit in Lean.Expr

Hashable in Init.Prelude

Lean.KVMap in Lean.Data.KVMap

Lean.KVMap.Value in Lean.Data.KVMap

control in Init.Control.Basic

Lean.Elab.elabSetOption in Lean.Elab.SetOption

Lean.maxRecDepth in Lean.Util.RecDepth

DecidablePred in Init.Prelude

Nat.decreasingInduction in Mathlib.Data.Nat.Init

Encodable in Mathlib.Logic.Encodable.Basic

Encodable.decode in Mathlib.Logic.Encodable.Basic

Encodable.encode in Mathlib.Logic.Encodable.Basic

Option.bind in Init.Data.Option.Basic

ForIn.forIn in Init.Core

instForInOfForIn' in Init.Control.Basic

Membership in Init.Prelude

Membership.mem in Init.Prelude

Set.Mem in Mathlib.Data.Set.Defs

iSup in Mathlib.Order.SetNotation

Lean.Loop.mk in Init.While

measure in Init.WF

Plausible.Gen in Plausible.Gen

StdGen in Init.Data.Random

Lean.Order.FlatOrder in Init.Internal.Order.Basic

Lean.Order.flat_csup in Init.Internal.Order.Basic

Function.comp in Init.Prelude

Pi.hasLe in Mathlib.Order.Basic

StateT.map in Init.Control.State

StateT.bind in Init.Control.State

Lean.Order.fun_csup in Init.Internal.Order.Basic

Except.bind in Init.Control.Except

ExceptT.bind in Init.Control.Except

ExceptT.bindCont in Init.Control.Except

ExceptT.instMonad in Init.Control.Except

ExceptT.map in Init.Control.Except

Except.ok in Init.Prelude

ReaderT.bind in Init.Prelude
</all_available_defs>

<all_available_lemmas>
@[grind, solverHint]
lemma sumUpToSucc
  (spv : SpV Int)
  (v : Array Int) (bound : ℕ) :
  sumUpTo spv v (bound + 1) = (sumUpTo spv v bound) +
    ((spv.val)[bound]! * v[(spv.ind)[bound]!]!)

@[grind, solverHint]
lemma sumUpTo0
  (spv : SpV Int) (v : Array Int) :
  sumUpTo spv v 0 = 0

@[solverHint]
lemma spv_dot_eq
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int):
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
    spv1.ind[pnt1]! = spv2.ind[pnt2]! →
    pnt1 < spv1.size →
    pnt2 < spv2.size →
    prev + spv1.val[pnt1]! * spv2.val[pnt2]! + spv_dot spv1 spv2 (pnt1 + 1) (pnt2 + 1) = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_lt
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int):
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
  spv1.ind[pnt1]! < spv2.ind[pnt2]! →
  pnt1 < spv1.size → pnt2 < spv2.size →
    prev + spv_dot spv1 spv2 (pnt1 + 1) pnt2 = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_gt
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int) :
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
  spv2.ind[pnt2]! ≤ spv1.ind[pnt1]! →
  spv1.ind[pnt1]! ≠ spv2.ind[pnt2]! →
  pnt1 < spv1.size → pnt2 < spv2.size →
    prev + spv_dot spv1 spv2 pnt1 (pnt2 + 1) = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_exh
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ):
  pnt1 = spv1.size ∨ pnt2 = spv2.size → spv_dot spv1 spv2 pnt1 pnt2 = 0

theorem getValSpV_eq (spv: SpV Int) (j: ℕ) (h_ind: j < spv.size): spv[spv.ind[j]!] = (spv.val)[j]!

theorem getValSpV_empty (spv: SpV Int) (j: ℕ) (h_empty: ∀ i < spv.size, spv.ind[i]! ≠ j): spv[j] = 0

theorem VSpV_correct_pure (out: Array Int) (arr: Array Int)
  (spv: SpV Int)
  (h_b: ∀ i < spv.size, spv.ind[i]! < arr.size):
  out.size = 1 → out[0]! = sumUpTo spv arr spv.size →
    out[0]! = ∑ i ∈ Finset.range (arr.size), spv[i] * arr[i]!

theorem VSpV_correct_triple (out: Array Int) (arr: Array Int) (spv: SpV Int):
  triple
    (∀ i < spv.size, spv.ind[i]! < arr.size)
    (VSpV out arr spv)
    fun ⟨_, outNew⟩ =>
      outNew[0]! = ∑ i ∈ Finset.range (arr.size), spv[i] * arr[i]!

theorem spmv_correct_triple (out: Array Int) (arr: Array Int) (spm: Array (SpV Int)):
  triple
    (∀ i < spm.size, ∀ j < spm[i]!.size, spm[i]!.ind[j]! < arr.size)
    (spmv out arr spv spm)
    fun ⟨_, outNew⟩ =>
      (∀ j < outNew.size, outNew[j]! = ∑ i ∈ Finset.range (arr.size), spm[j]![i] * arr[i]!)

theorem spv_dot_pure_gen (spv1: SpV Int) (spv2: SpV Int) (n pnt1 pnt2: ℕ)
  (sz1: ∀ i < spv1.size, spv1.ind[i]! < n)
  (sz2: ∀ i < spv2.size, spv2.ind[i]! < n):
  spv_dot spv1 spv2 pnt1 pnt2 =
    ∑ i ∈ Finset.range n,
      if max
        (if spv1.size ≤ pnt1 then n else spv1.ind[pnt1]!)
        (if spv2.size ≤ pnt2 then n else spv2.ind[pnt2]!) ≤ i then
        spv1[i] * spv2[i]
      else
        0

theorem spv_dot_pure (spv1 spv2: SpV Int) (n: ℕ)
  (sz1: ∀ i < spv1.size, spv1.ind[i]! < n) (sz2: ∀ i < spv2.size, spv2.ind[i]! < n):
    spv_dot spv1 spv2 0 0 = ∑ i ∈ Finset.range n, spv1[i] * spv2[i]

theorem SpVSpV_correct_triple (out: Array Int) (spv1 spv2: SpV Int) (n: ℕ):
  triple
    ((∀ i < spv1.size, spv1.ind[i]! < n) ∧ (∀ i < spv2.size, spv2.ind[i]! < n))
    (SpVSpV out spv1 spv2)
    fun ⟨_, outNew⟩ =>
      outNew[0]! = ∑ i ∈ Finset.range n, spv1[i]! * spv2[i]!

theorem SpMSpV_correct_triple
  (out: Array Int)
  (spm: Array (SpV Int))
  (spv: SpV Int)
  (n: ℕ):
  triple
    (∀ i < spm.size, (∀ j < spm[i]!.size, spm[i]!.ind[j]! < n) ∧ (∀ j < spv.size, spv.ind[j]! < n))
    (SpMSpV out spm spv)
    fun ⟨_, outNew⟩ =>
      outNew.size = spm.size ∧ ∀ i < spm.size, outNew[i]! = ∑ idx ∈ Finset.range n, spm[i]![idx]! * spv[idx]!

theorem finalCorrectnessTheorem (s : Array Char) (p : Char → Bool) :
  let res := SubstringSearch s p |>.extract
  (res.flag = false → ∀ i < s.size, p s[i]! = false) ∧
  (res.flag = true →
    (∀ l₁ r₁, CorrectSubstring s p l₁ r₁ →
  r₁ - l₁ + 1 = res.r - res.l + 1 ∧ res.r ≤ r₁ ∨
  r₁ - l₁ + 1 < res.r - res.l + 1)) ∧
  (res.flag = true → CorrectSubstring s p res.l res.r) ∧
  (0 < s.size → res.r < s.size) ∧
  (res.l ≤ res.r)

lemma MAlg.lift_StateT [Monad m] [LawfulMonad m] [CompleteLattice l] [inst: MAlgOrdered m l] (x : StateT σ m α) :
  MAlg.lift x post = fun s => MAlg.lift (x s) (fun xs => post xs.1 xs.2)

@[simp]
lemma Array.replicate_get (n : ℕ) [Inhabited α] (a : α) (i : ℕ) (_ : i < n := by omega) :
  (Array.replicate n a)[i]! = a

@[simp]
lemma Array.modify_get (a : Array α) [Inhabited α] (i j : ℕ) (f : α -> α) :
  (a.modify i f)[j]! = if j < a.size then if j = i then f a[j]! else a[j]! else default

@[simp]
lemma Array.sumUpToSucc [Inhabited α] [AddCommMonoid α] (a : Array α) (f : ℕ -> α -> α) (bound : ℕ) :
  a.sumUpTo f (bound + 1) = a.sumUpTo f bound + f bound a[bound]!

@[grind]
lemma get_cnt_sum_hd e l : get_cnt_sum (e::l) = e.cnt + get_cnt_sum l

lemma get_cnt_sum_append l1 l2:  get_cnt_sum (l1 ++ l2) = get_cnt_sum l1 + get_cnt_sum l2

lemma decodeStrLean_append : forall arr1 arr2,
  decodeStrLean (arr1 ++ arr2) = ( decodeStrLean arr1 ) ++ ( decodeStrLean arr2 )

lemma array_extract_split (arr : Array α) (i j : Nat) :
    i < j → j ≤ arr.size →
    arr.extract 0 j = (arr.extract 0 i) ++ (arr.extract i j)

lemma array_extract_split_i_j_k (arr : Array α) (i j k: Nat) :
    i < j -> j < k -> k ≤ arr.size →
    arr.extract i k = (arr.extract i j) ++ (arr.extract j k)

@[grind, solverHint]
lemma sumUpToSucc
  (spv : SpV Int)
  (v : Array Int) (bound : ℕ) :
  sumUpTo spv v (bound + 1) = (sumUpTo spv v bound) +
    ((spv.val)[bound]! * v[(spv.ind)[bound]!]!)

@[grind, solverHint]
lemma sumUpTo0
  (spv : SpV Int) (v : Array Int) :
  sumUpTo spv v 0 = 0

@[solverHint]
lemma spv_dot_eq
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int):
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
    spv1.ind[pnt1]! = spv2.ind[pnt2]! →
    pnt1 < spv1.size →
    pnt2 < spv2.size →
    prev + spv1.val[pnt1]! * spv2.val[pnt2]! + spv_dot spv1 spv2 (pnt1 + 1) (pnt2 + 1) = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_lt
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int):
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
  spv1.ind[pnt1]! < spv2.ind[pnt2]! →
  pnt1 < spv1.size → pnt2 < spv2.size →
    prev + spv_dot spv1 spv2 (pnt1 + 1) pnt2 = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_gt
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ) (prev: Int) :
  prev + spv_dot spv1 spv2 pnt1 pnt2 = spv_dot spv1 spv2 0 0 →
  spv2.ind[pnt2]! ≤ spv1.ind[pnt1]! →
  spv1.ind[pnt1]! ≠ spv2.ind[pnt2]! →
  pnt1 < spv1.size → pnt2 < spv2.size →
    prev + spv_dot spv1 spv2 pnt1 (pnt2 + 1) = spv_dot spv1 spv2 0 0

@[solverHint]
theorem spv_dot_exh
  (spv1 spv2: SpV Int) (pnt1 pnt2: ℕ):
  pnt1 = spv1.size ∨ pnt2 = spv2.size → spv_dot spv1 spv2 pnt1 pnt2 = 0

theorem getValSpV_eq (spv: SpV Int) (j: ℕ) (h_ind: j < spv.size): spv[spv.ind[j]!] = (spv.val)[j]!

theorem getValSpV_empty (spv: SpV Int) (j: ℕ) (h_empty: ∀ i < spv.size, spv.ind[i]! ≠ j): spv[j] = 0

theorem VSpV_correct_pure (out: Array Int) (arr: Array Int)
  (spv: SpV Int)
  (h_b: ∀ i < spv.size, spv.ind[i]! < arr.size):
  out.size = 1 → out[0]! = sumUpTo spv arr spv.size →
    out[0]! = ∑ i ∈ Finset.range (arr.size), spv[i] * arr[i]!

theorem VSpV_correct_triple (out: Array Int) (arr: Array Int) (spv: SpV Int):
  triple
    (∀ i < spv.size, spv.ind[i]! < arr.size)
    (VSpV out arr spv)
    fun ⟨_, outNew⟩ =>
      outNew[0]! = ∑ i ∈ Finset.range (arr.size), spv[i] * arr[i]!

theorem spmv_correct_triple (out: Array Int) (arr: Array Int) (spm: Array (SpV Int)):
  triple
    (∀ i < spm.size, ∀ j < spm[i]!.size, spm[i]!.ind[j]! < arr.size)
    (spmv out arr spv spm)
    fun ⟨_, outNew⟩ =>
      (∀ j < outNew.size, outNew[j]! = ∑ i ∈ Finset.range (arr.size), spm[j]![i] * arr[i]!)

theorem spv_dot_pure_gen (spv1: SpV Int) (spv2: SpV Int) (n pnt1 pnt2: ℕ)
  (sz1: ∀ i < spv1.size, spv1.ind[i]! < n)
  (sz2: ∀ i < spv2.size, spv2.ind[i]! < n):
  spv_dot spv1 spv2 pnt1 pnt2 =
    ∑ i ∈ Finset.range n,
      if max
        (if spv1.size ≤ pnt1 then n else spv1.ind[pnt1]!)
        (if spv2.size ≤ pnt2 then n else spv2.ind[pnt2]!) ≤ i then
        spv1[i] * spv2[i]
      else
        0

theorem spv_dot_pure (spv1 spv2: SpV Int) (n: ℕ)
  (sz1: ∀ i < spv1.size, spv1.ind[i]! < n) (sz2: ∀ i < spv2.size, spv2.ind[i]! < n):
    spv_dot spv1 spv2 0 0 = ∑ i ∈ Finset.range n, spv1[i] * spv2[i]

theorem SpVSpV_correct_triple (out: Array Int) (spv1 spv2: SpV Int) (n: ℕ):
  triple
    ((∀ i < spv1.size, spv1.ind[i]! < n) ∧ (∀ i < spv2.size, spv2.ind[i]! < n))
    (SpVSpV out spv1 spv2)
    fun ⟨_, outNew⟩ =>
      outNew[0]! = ∑ i ∈ Finset.range n, spv1[i]! * spv2[i]!

theorem SpMSpV_correct_triple
  (out: Array Int)
  (spm: Array (SpV Int))
  (spv: SpV Int)
  (n: ℕ):
  triple
    (∀ i < spm.size, (∀ j < spm[i]!.size, spm[i]!.ind[j]! < n) ∧ (∀ j < spv.size, spv.ind[j]! < n))
    (SpMSpV out spm spv)
    fun ⟨_, outNew⟩ =>
      outNew.size = spm.size ∧ ∀ i < spm.size, outNew[i]! = ∑ idx ∈ Finset.range n, spm[i]![idx]! * spv[idx]!

lemma adjacent_to_global_sorted (a : Array Int) :
    (∀ k, 0 ≤ k ∧ k < a.size - 1 → a[k]! ≤ a[k+1]!) →
    (∀ i j, 0 ≤ i ∧ i < j ∧ j < a.size → a[i]! ≤ a[j]!)

lemma wp_pure (x : α) (post : α -> l) : wp (m := m) (pure x) post = post x

lemma triple_pure (pre : l) (x : α) (post : α -> l) :
  triple pre (pure (f := m) x) post <-> pre ≤ (post x)

lemma wp_bind {β} (x : m α) (f : α -> m β) (post : β -> l) :
    wp (x >>= f) post = wp x (fun x => wp (f x) post)

lemma wp_map {β} (x : m α) (f : α -> β) (post : β -> l) :
  wp (f <$> x) post = wp x (fun x => post (f x))

lemma wp_cons (x : m α) (post post' : α -> l) :
  (∀ y, post y ≤ post' y) ->
  wp x post ≤ wp x post'

lemma triple_cons (x : m α) {pre pre' : l} {post post' : α -> l} :
  pre' ≤ pre ->
  (∀ y, post y ≤ post' y) ->
  triple pre x post ->
  triple pre' x post'

lemma triple_bind {β} (pre : l) (x : m α) (cut : α -> l)
  (f : α -> m β) (post : β -> l) :
  triple pre x cut ->
  (∀ y, triple (cut y) (f y) post) ->
  triple pre (x >>= f) post

omit [LawfulMonad m] in
@[simp]
lemma wp_top (c : m α) [NoFailure m] :
  wp c (fun _ => ⊤) = ⊤

lemma triple_spec (pre : l) (c : m α) (post : α -> l) :
  spec pre post <= wp c <->
  triple pre c post

lemma wp_iInf {ι : Type u} [Nonempty ι] [MAlgDet m l] (c : m α) (post : ι -> α -> l) :
  wp c (fun x => ⨅ i, post i x) = ⨅ i, wp c (post i)

lemma wp_and [MAlgDet m l] (c : m α) (post₁ post₂ : α -> l) :
  wp c (fun x => post₁ x ⊓ post₂ x) = wp c post₁ ⊓ wp c post₂

lemma wp_iSup {ι : Type u} [Nonempty ι] [MAlgDet m l] (c : m α) (post : ι -> α -> l) :
  wp c (fun x => ⨆ i, post i x) = ⨆ i, wp c (post i)

lemma wp_or [MAlgDet m l] (c : m α) (post₁ post₂ : α -> l) :
  wp c (fun x => post₁ x ⊔ post₂ x) = wp c post₁ ⊔ wp c post₂

namespace PartialCorrectness
omit [MonoBind m] [LawfulMonad m] in
lemma wp_csup (xc : Set (m α)) (post : α -> l) :
  Lean.Order.chain xc ->
  ⨅ c ∈ xc, wp c post ≤ wp (Lean.Order.CCPO.csup xc) post
end PartialCorrectness

namespace PartialCorrectness
omit [MonoBind m] [LawfulMonad m] in
lemma wp_bot :
  wp (bot : m α) = fun _ => (⊤ : l)
end PartialCorrectness

namespace PartialCorrectness
lemma repeat_inv (f : Unit -> β -> m (ForInStep β))
  (inv : ForInStep β -> l)
  init :
   (∀ b, triple (inv (.yield b)) (f () b) (inv)) ->
   triple (inv (.yield init)) (Loop.forIn.loop f init) (fun b => inv (.done b))
end PartialCorrectness

namespace PartialCorrectness
lemma repeat_inv_split (f : Unit -> β -> m (ForInStep β))
  (inv : β -> l) (doneWith : β -> l)
  init :
   (∀ b, triple (inv b) (f () b) (fun | .yield b' => inv b' | .done b' => inv b' ⊓ doneWith b')) ->
   triple (inv init) (Loop.forIn.loop f init) (fun b => inv b ⊓ doneWith b)
end PartialCorrectness

namespace TotalCorrectness
lemma repeat_inv (f : Unit -> β -> m (ForInStep β))
  (inv : ForInStep β -> l) (measure : β -> Nat)
  init :
   (∀ b, triple (inv (.yield b)) (f () b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))) ->
   triple (inv (.yield init)) (Loop.forIn.loop f init) (fun b => inv (.done b))
end TotalCorrectness

namespace TotalCorrectness
lemma repeat_inv_split (f : Unit -> β -> m (ForInStep β))
  (inv : β -> l) (doneWith : β -> l)
  init  (measure: β -> Nat):
    (∀ b, triple (inv b) (f () b) (fun | .yield b' => inv b' ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv b' ⊓ doneWith b')) ->
    triple (inv init) (Loop.forIn.loop f init) (fun b => inv b ⊓ doneWith b)
end TotalCorrectness

namespace TotalCorrectness
@[simp]
lemma wp_bot :
  wp (bot : m α) = fun _ => (⊥ : l)
end TotalCorrectness

theorem triple_forIn_list {α β}
  {xs : List α} {init : β} {f : α → β → m (ForInStep β)}
  (inv : List α → β → l)
  (hstep : ∀ hd tl b,
    triple
      (inv (hd :: tl) b)
      (f hd b)
      (fun | .yield b' => inv tl b' | .done b' => inv [] b')) :
  triple (inv xs init) (forIn xs init f) (inv [])

theorem triple_forIn_range'_aux {β}
  {xstart : ℕ} {step : ℕ} (n : ℕ) (init : β) {f : ℕ → β → m (ForInStep β)}
  (inv : ℕ → β → l)
  (hstep : ∀ i b,
    triple
      (inv i b)
      (f i b)
      (fun | .yield b' => inv (i + step) b' | .done b' => inv (xstart + n * step) b')) :
  i <= n ->
  triple (inv (xstart + (n - i) * step) init) (forIn (List.range' (xstart + (n - i) * step) i step) init f) (inv (xstart + n * step))

theorem triple_forIn_range' {β}
  {xstart : ℕ} {step : ℕ} (n : ℕ) {init : β} {f : ℕ → β → m (ForInStep β)}
  (inv : ℕ → β → l)
  (hstep : ∀ i b,
    triple
      (inv i b)
      (f i b)
      (fun | .yield b' => inv (i + step) b' | .done b' => inv (xstart + n * step) b')) :
  triple (inv xstart init) (forIn (List.range' xstart n step) init f) (inv (xstart + n * step))

theorem triple_forIn_range {β}
  (xs : Std.Range) (init : β) (f : ℕ → β → m (ForInStep β))
  (inv : ℕ → β → l)
  (hstep : ∀ i b,
    triple
      (inv i b)
      (f i b)
      (fun | .yield b' => inv (i + xs.step) b' | .done b' => inv (xs.start + ((xs.stop - xs.start + xs.step - 1) / xs.step) * xs.step) b')) :
  triple (inv xs.start init) (forIn xs init f) (inv (xs.start + ((xs.stop - xs.start + xs.step - 1) / xs.step) * xs.step))

theorem triple_forIn_range_step1 {β}
  {xs : Std.Range} {init : β} {f : ℕ → β → m (ForInStep β)}
  (inv : ℕ → β → l)
  (hstep : ∀ i b,
    triple
      (inv i b)
      (f i b)
      (fun | .yield b' => inv (i + xs.step) b' | .done b' => inv xs.stop b')) :
  xs.step = 1 ->
  xs.start <= xs.stop ->
  triple (inv xs.start init) (forIn xs init f) (inv xs.stop)

lemma wp_except_handler_eq ε (hd : ε -> Prop) [IsHandler hd] (c : ExceptT ε m α) post :
  wp c post = wp (m := m) c (fun | .ok x => post x | .error e => ⌜hd e⌝)

lemma wp_part_eq ε (c : ExceptT ε m α) post :
  wp c post = wp (m := m) c (fun | .ok x => post x | .error _ => ⊤)

lemma wp_tot_eq ε (c : ExceptT ε m α) post :
  wp c post = wp (m := m) c (fun | .ok x => post x | .error _ => ⊥)

lemma ExceptT.wp_lift_hd {hd : ε -> Prop} (c : m α) (post : α -> l) [IsHandler hd] :
  wp (liftM (n := ExceptT ε m) c) post = wp (m := m) c post

lemma ExceptionAsSuccess.ExceptT.wp_lift (c : m α) (post : α -> l) :
  wp (liftM (n := ExceptT ε m) c) post = wp (m := m) c post

lemma ExceptionAsFailure.ExceptT.wp_lift (c : m α) (post : α -> l) :
  wp (liftM (n := ExceptT ε m) c) post = wp (m := m) c post

lemma TotalCorrectness.DivM.wp_eq (α : Type) (x : DivM α) (post : α -> Prop) :
  wp x post =
    match x with

lemma PartialCorrectness.DivM.wp_eq (α : Type) (x : DivM α) (post : α -> Prop) :
  wp x post =
    match x with

lemma StateT.wp_eq (c : StateT σ m α) (post : α -> σ -> l) :
  wp c post = fun s => wp (m := m) (c s) (fun xs => post xs.1 xs.2)

lemma StateT.wp_lift (c : m α) (post : α -> σ -> l) :
  wp (liftM (n := StateT σ m) c) post = fun s => wp (m := m) c (post · s)

lemma ReaderT.wp_eq (c : ReaderT σ m α) (post : α -> σ -> l) :
  wp c post = fun s => wp (m := m) (c s) (post · s)

lemma ReaderT.wp_lift (c : m α) (post : α -> σ -> l) :
  wp (liftM (n := ReaderT σ m) c) post = fun s => wp (m := m) c (post · s)

omit [LawfulMonad m] in
lemma MAlgLift.wp_lift [Monad n] [CompleteLattice k] [MAlgOrdered n k] [MonadLiftT m n]
  -- [MonadLiftT (Cont l) (Cont k)]
  [mAlgLift : MAlgLiftT m l n k] (c : m α):
  wp (liftM (n := n) c) = fun (post : α -> k) => mAlgLift.cl.lift.monadLift (wp c) post

lemma ExceptT.wp_throw (e : ε) :
  wp (α := α) (throw (m := ExceptT ε m) e) = fun _ => ⌜hd e⌝

lemma MAlgLift.wp_throw
  [Monad n] [CompleteLattice k] [MAlgOrdered n k] [MonadLiftT m n]
  [MonadLiftT (ExceptT ε m) n]
  [inst: MAlgLiftT (ExceptT ε m) l n k] :
    wp (liftM (n := n) (throw (m := ExceptT ε m) e)) post = ⌜hd e⌝

lemma StateT.wp_get (post : σ -> σ -> l) :
  wp (get (m := StateT σ m)) post = fun s => post s s

lemma StateT.wp_set {res: σ} (post : PUnit -> σ -> l) :
  wp (set (m := StateT σ m) res) post = fun _ => post PUnit.unit res

lemma StateT.wp_modifyGet (post : α -> σ -> l) :
  wp (modifyGet (m := StateT σ m) f) post = fun s => post (f s).1 (f s).2

lemma ReaderT.wp_read (post : σ -> σ -> l) :
  wp (read (m := ReaderT σ m)) post = fun s => post s s

lemma Gen.wp_rand {α : Type} (c : Gen α) :
  triple ⊤ c (fun _ => ⊤)

theorem false_imp_except (pre: Bal → Prop) (code: ExceptT String (StateT Bal DivM) Bal) :
  triple pre code ⊥ → ∀ s, pre s -> ∃ (d: String), code.run.run' s = DivM.res (Except.error d)

lemma SumDigits_unfold (n : Nat) (h : n > 0) :
  SumDigits n = (n % 10) + SumDigits (n / 10)

lemma SumDigits_zero : SumDigits 0 = 0

@[local simp]
lemma DivM.total_decompose (α : Type) (x : DivM α) (post₁ post₂ : α -> Prop) :
  ([totl| wp x post₁] ∧ [part| wp x post₂]) = [totl| wp x (post₁ ⊓ post₂)]

@[local simp]
lemma wp_mono_part (x : NonDetT DivM α) (post₁ post₂ : α -> Prop) :
  (post₁ ≤ post₂) → ([totl|wp x post₁]) ≤ ([part| wp x post₂])

lemma VelvetM.total_decompose {α : Type} (x : VelvetM α) (post₁ post₂ : α -> Prop):
  [totl| wp x post₁] ⊓ [part| wp x post₂] = [totl| wp x (post₁ ⊓ post₂)]

lemma VelvetM.total_decompose_triple {α : Type} {pre : Prop} {post : α -> Prop}
  (x y z: VelvetM α) (termination: [totl| triple pre x fun _ => True]) (postcondition: [part| triple pre y post]) {eqx: x = z} {eqy: y = z}:
  [totl| triple pre z post]

namespace TotalCorrectness.DemonicChoice
lemma VelvetM.extract_spec {α : Type} (x : VelvetM α) [Inhabited α] (post : α -> Prop) :
  triple pre x post ->
  (pre -> post x.extract)
end TotalCorrectness.DemonicChoice

lemma meet_himp (x x' y z : l) :
  x = x' ->
  (x ⇨ y) ⊓ (x' ⇨ z) = x ⇨ (y ⊓ z)

namespace DemonicChoice
omit [MAlgOrdered m l] in
lemma spec_mono {α : Type u}  {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end DemonicChoice

namespace DemonicChoice
lemma NonDetT.wp_mono  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] {α : Type u} (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end DemonicChoice

namespace DemonicChoice
lemma NonDetT.wp_bind  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] {α β : Type u} (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end DemonicChoice

namespace DemonicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end DemonicChoice

namespace DemonicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end DemonicChoice

namespace DemonicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end DemonicChoice

namespace DemonicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) post :
  _root_.wp (NonDetT.pickCont τ p f) post = ⨅ a, ⌜p a⌝ ⇨ _root_.wp (f a) post
end DemonicChoice

namespace DemonicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end DemonicChoice

namespace DemonicChoice
lemma MonadNonDet.wp_pick {τ : Type u} post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iInf post
end DemonicChoice

namespace DemonicChoice
lemma MonadNonDet.wp_assume {as : Prop} post : _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⇨ post .unit
end DemonicChoice

namespace DemonicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⨅ a, ⌜p a⌝ ⇨ post a
end DemonicChoice

namespace DemonicChoice
lemma NonDetT.wp_iInf {ι : Type u} {α : Type u} {l : Type u} [CompleteBooleanAlgebra l] [MAlgOrdered m l] [MAlgDet m l] [Nonempty ι]
  (x : NonDetT m α) (post : ι -> α -> l) :
  _root_.wp x (fun a => iInf post a) = ⨅ i, _root_.wp x (post i)
end DemonicChoice

namespace AngelicChoice
lemma spec_mono {α : Type u} {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end AngelicChoice

namespace AngelicChoice
lemma NonDetT.wp_mono [LawfulMonad m] {α : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end AngelicChoice

namespace AngelicChoice
lemma NonDetT.wp_bind [LawfulMonad m] {α β : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end AngelicChoice

namespace AngelicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end AngelicChoice

namespace AngelicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end AngelicChoice

namespace AngelicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end AngelicChoice

namespace AngelicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) post :
  _root_.wp (NonDetT.pickCont τ p f) post = ⨆ a, ⌜p a⌝ ⊓ _root_.wp (f a) post
end AngelicChoice

namespace AngelicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end AngelicChoice

namespace AngelicChoice
lemma MonadNonDet.wp_pick {τ : Type u} post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iSup post
end AngelicChoice

namespace AngelicChoice
lemma MonadNonDet.wp_assume {as : Prop} post : _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⊓ post .unit
end AngelicChoice

namespace AngelicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⨆ a, ⌜p a⌝ ⊓ post a
end AngelicChoice

namespace Loom.Matcher
theorem simp1 {l : Type u} [CompleteBooleanAlgebra l] {p : Prop} (proof : p) {a b : l} (h : a ≤ b) :
  ⌜p⌝ ⇨ a ≤ b
end Loom.Matcher

theorem Array.get_set_c [Inhabited α] (i j: Nat) (val: α) (arr: Array α):
  i < arr.size → (arr.set! j val)[i]! = if i = j then val else arr[i]!

lemma add_mod_elim (m n: Nat) {a b : Nat} (hm: m > 0) (h: (a + n) % m = (b + n) % m): a % m = b % m

theorem Array.multiset_swap [Inhabited α]
(arr: Array α) (idx₁ idx₂: Nat) (h_idx₁: idx₁ < arr.size) (h_idx₂: idx₂ < arr.size) :
  ((arr.set! idx₂ arr[idx₁]!).set! idx₁ arr[idx₂]!).toMultiset = arr.toMultiset

@[local simp]
private lemma compl_fun {α} (x y : α -> l) :
  (fun a => x a ⊔ y a)ᶜ = (fun a => (x a)ᶜ ⊓ (y a)ᶜ)

@[local simp]
private lemma compl_fun' {α} (x y : α -> l) :
  (fun a => x a ⊓ y a)ᶜ = (fun a => (x a)ᶜ ⊔ (y a)ᶜ)

@[local simp]
private lemma compl_fun'' {α} (x : α -> l) :
  (fun a => (x a)ᶜ) = xᶜ

@[local simp]
private lemma compl_fun_true {α} :
  (fun (_ : α) => ⊤)ᶜ = fun _ => (⊥ : l)

omit [LawfulMonad m] in
@[simp]
lemma iwp_eq (c : m α) (post : α -> l) :
  iwp c post = (wp c postᶜ)ᶜ

@[simp]
lemma wlp_true (c : m α) : wlp c (fun _ => ⊤) = ⊤

@[simp]
lemma wlp_pure (x : α) (post : α -> l) :
  wlp (pure (f := m) x) post = post x

omit [LawfulMonad m] in
lemma wp_wlp (c : m α) (post : α -> l) :
  wp c post <= wlp c post

lemma wlp_and (c : m α) (post₁ post₂ : α -> l) :
  wlp c (fun x => post₁ x ⊓ post₂ x) = wlp c post₁ ⊓ wlp c post₂

lemma wlp_bind {β} (x : m α) (f : α -> m β) (post : β -> l) :
  wlp (x >>= f) post = wlp x (fun x => wlp (f x) post)

lemma wlp_himp (c : m α) (post post' : α -> l) :
  wp c (fun x => post' x ⇨ post x) = wlp c post' ⇨ wp c post

lemma wlp_join_wp (c : m α) (post post' : α -> l) :
  wlp c post ⊓ wp c post' = wp c (fun x => post x ⊓ post' x)

lemma wp_top_wlp (c : m α) (post : α -> l) :
  wp c ⊤ ⊓ wlp c post = wp c post

omit [MAlgDet m l] in
lemma wlp_cons (c : m α) (post post' : α -> l) :
  post <= post' ->
  wlp c post <= wlp c post'

lemma wp_top_iwp (c : m α) (post : α -> l) :
  wp c ⊥ = ⊥ ->
  wp c ⊤ ⊓ iwp c post = wp c post

lemma wp_tot_part ε (c : ExceptT ε m α) post :
  [totl| wp c ⊤] ⊓ [part| wp c post] = [totl| wp c post]

lemma wp_compl (c : m α) post (wp_bot : ∀ α (c : m α), wp c ⊤ = ⊤) :
  (wp c postᶜ)ᶜ <= wp c post

lemma wp_compl'  (c : m α) post (wp_bot : ∀ α (c : m α), wp c ⊥ = ⊥) :
  wp c post <= (wp c postᶜ)ᶜ

private lemma le_coml_sup (x y z : l) :
  y <= x ⊔ z -> xᶜ <= yᶜ ⊔ z

lemma wlp_part_wlp_handler ε (α : Type u) (c : ExceptT ε m α) (post : α → l) (hd : ε -> Prop) :
  [part| wlp c post] =
  [handler hd| wlp c post]

lemma TotalCorrectness.DivM.wlp_eq (α : Type) (x : DivM α) (post : α -> Prop) :
  (open TotalCorrectness in wlp x post) = (open PartialCorrectness in wp x post)

lemma PartialCorrectness.DivM.wlp_eq (α : Type) (x : DivM α) (post : α -> Prop) :
  wlp x post = wp x post

omit [MAlgDet m l] in
lemma StateT.wlp_eq (c : StateT σ m α) (post : α -> σ -> l) :
  wlp c post = fun s => wlp (m := m) (c s) (fun xs => post xs.1 xs.2)

omit [MAlgDet m l] in
lemma ReaderT.wlp_eq (c : ReaderT σ m α) (post : α -> σ -> l) :
  wlp c post = fun s => wlp (m := m) (c s) (post · s)

lemma ExceptT.wlp_eq (c : ExceptT ε m α) (post : α -> l) :
  [totl| wlp c post] = [part| wlp c post]

namespace PartialCorrectness.DemonicChoice
lemma ExtractNonDet.extract_refines_wp (s : NonDetT m α) :
  wp s post <= wp s.run post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma ExtractNonDet.extract_refines (pre : l) (s : NonDetT m α) :
  triple pre s post ->
  triple pre s.run post
end PartialCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma ExtractNonDet.extract_refines_wp (s : NonDetT m α) :
  wp s post <= wp s.run post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma ExtractNonDet.extract_refines (pre : l) (s : NonDetT m α) :
  triple pre s post ->
  triple pre s.run post
end TotalCorrectness.DemonicChoice

lemma MAlg.lift_ReaderT [Monad m] [LawfulMonad m] [CompleteLattice l] [inst: MAlgOrdered m l] (x : ReaderT σ m α) :
  MAlg.lift x post = fun s => MAlg.lift (x s) (fun xs => post xs s)

lemma filter_sum_snoc (arr: Array Nat) (p: Nat → Bool) :
  forall i, i < arr.size →
      (Array.filter p (Array.extract arr 0 i)).sum + (if (p arr[i]!) then arr[i]! else 0)=
      (Array.filter p (Array.extract arr 0 (i + 1))).sum

@[aesop safe]
lemma emp_sum (x: Bal) (h: 0 ≤ x) : ∃ h: List Nat, h.sum ≤ x

omit [LawfulMonad m] in
lemma WPGen.intro (x : m α) (wpg : WPGen x) :
  pre <= wpg.get post ->
  -- pre <= wpg.sideCond ->
  triple pre x post

theorem triple_forIn_deacreasing {β} {measure : β -> ℕ}
  {init : β} {f : β → m (ForInStep β)}
  (inv : β → l)
  (hstep : ∀ b,
    measure b <= measure init ->
    triple
      (inv b)
      (f b)
      (fun | .yield b' => inv b' ⊓ ⌜measure b' < measure b⌝ | .done b' => ⌜ measure b' = 0 ⌝ ⊓ inv b')) :
  triple (inv init) (forIn [0:measure init] init (fun _ => f)) (fun b => inv b ⊓ ⌜measure b = 0⌝)

@[simp]
lemma trueE (l : Type v) [inst: LE l] [OrderTop l] [OrderBot l] : ⌜True⌝ = (⊤ : l)

@[simp]
lemma falseE (l : Type v) [inst: LE l] [OrderTop l] [OrderBot l] : ⌜False⌝ = (⊥ : l)

lemma LE.pure_imp {l : Type u} [inst: LE l] [OrderTop l] [OrderBot l]
  (p₁ p₂ : Prop) : (p₁ -> p₂) -> ⌜p₁⌝ <= (⌜p₂⌝ : l)

@[simp]
lemma LE.pure_intro {l : Type u} [inst: LE l] [OrderTop l] [OrderBot l]
  (p : Prop) (h : l) : (⌜p⌝ <= h) = (p -> ⊤ <= h)

@[simp]
lemma pure_intro_l {l : Type u} [CompleteLattice l] (x y : l) :
  (x ⊓ ⌜ p ⌝ <= y) = (p -> x <= y)

@[simp]
lemma pure_intro_r {l : Type u} [CompleteLattice l] (x y : l) :
  (⌜ p ⌝ ⊓ x <= y) = (p -> x <= y)

lemma MAlgOrdered.bind {α : Type u} {m} {l : Type u} [Monad m] [CompleteLattice l] [MAlgOrdered m l] :
    ∀ (x : m α) (f g : α -> m l), μ ∘ f = μ ∘ g ->
     μ (x >>= f) = μ (x >>= g)

lemma Cont.monotone_lift {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteLattice l] [MAlgOrdered m l] :
  ∀ {α : Type u} (x : m α), MAlg.lift x |>.monotone

@[simp]
lemma MAlg.μ_eq {m l} [Monad m] [CompleteLattice l] [MAlgOrdered m l] : MAlg.μ (m := m) = MAlgOrdered.μ (m := m)

lemma MAlg.monadLift_bind {α β} {l : Type u} {m : Type u -> Type v} [Monad m] [LawfulMonad m] [CompleteLattice l] [MAlgOrdered m l]
  (x : m α) (f g : α -> Cont l β) :
    f <= g ->
    (lift x >>= f) ≤ (lift x >>= g)

@[simp]
lemma lift_cont_eq {l σ : Type u} [CompleteLattice l] [CompleteLattice σ] (c : Cont l α) :
  liftM (m := Cont l) (n := Cont (σ -> l)) c = fun post s => c (post · s)

@[loomLogicSimp]
lemma leE (l : Type u) [PartialOrder l] (a b : α -> l) : a ≤ b ↔ ∀ x, a x ≤ b x

@[loomLogicSimp]
lemma lePropE (a b : Prop) : (a ≤ b) = (a → b)

@[loomLogicSimp]
lemma pureE (l : Type u) [CompleteLattice l] (a : Prop) : (⌜a⌝ : α -> l) = fun _ => ⌜a⌝

@[loomLogicSimp]
lemma purePropE  : (⌜a⌝ : Prop) = a

@[loomLogicSimp]
lemma infPropE (a b : Prop) : (a ⊓ b) = (a ∧ b)

@[loomLogicSimp]
lemma infE (l : Type u) [CompleteLattice l] (a b : α -> l) : (a ⊓ b) = fun x => a x ⊓ b x

@[loomLogicSimp]
lemma supE (l : Type u) [CompleteLattice l] (a b : α -> l) : (a ⊔ b) = fun x => a x ⊔ b x

@[loomLogicSimp]
lemma supPropE (a b : Prop) : (a ⊔ b) = (a ∨ b)

@[loomLogicSimp]
lemma iInfE (l : Type u) [CompleteLattice l] (a : ι -> α -> Prop) : (⨅ i, a i) = fun x => ⨅ i, a i x

@[loomLogicSimp]
lemma iSupE (l : Type u) [CompleteLattice l] (a : ι -> α -> Prop) : (⨆ i, a i) = fun x => ⨆ i, a i x

@[loomLogicSimp]
lemma himpE  (l : Type u) [CompleteBooleanAlgebra l] (a b : α -> l) :
  (a ⇨ b) = fun x => a x ⇨ b x

@[loomLogicSimp]
lemma himpPureE (a b : Prop) :
  (a ⇨ b) = (a -> b)

@[loomLogicSimp]
lemma topE (l : Type u) [CompleteLattice l] : (⊤ : α -> l) = fun _ => ⊤

@[loomLogicSimp]
lemma topPureE : (⊤ : Prop) = True

@[aesop safe]
theorem List.sum_lt (x: Bal) : x < y -> x < ([Int.toNat y]).sum

@[aesop safe]
theorem balance_lt (x: Bal) : x < x + 1

lemma Except.bind'_bind {m : Type u -> Type v} {ε α β} [Monad m] [LawfulMonad m] (i : m (Except ε α)) (f : α -> ExceptT ε m β) :
  (i >>= fun a => Except.bind' a f) = bind (m := ExceptT ε m) i f

lemma MAlg.lift_ExceptT ε (hd : ε -> Prop) [IsHandler hd] [CompleteLattice l] [inst: MAlgOrdered m l]
   (c : ExceptT ε m α) post :
  MAlg.lift c post = MAlg.lift (m := m) c (fun | .ok x => post x | .error e => ⌜hd e⌝)

lemma lift_map {α : Type u} {β : Type u} (f : α -> β) (x : m α)
  [Monad m] [Monad n] [LawfulMonad m] [LawfulMonad n] [MonadLiftT m n] [LawfulMonadLiftT m n] :
  liftM (f <$> x) = f <$> liftM (n := n) x

@[aesop unsafe]
theorem tail_length : ∀ q : List Nat, q.nonEmpty → q.tail.length < q.length

@[aesop norm]
theorem tail_sum (q: List Nat) (hnemp: q.nonEmpty): q.sum = q.tail.sum + q.head!

@[aesop unsafe]
theorem non_zero_length (q: List Nat) (hnemp: q.nonEmpty): 0 < q.length

@[aesop norm]
theorem sum_zero : ∀ q : List Nat, ¬q.nonEmpty → q.sum = 0

lemma meet_himp (x x' y z : l) :
  x = x' ->
  (x ⇨ y) ⊓ (x' ⇨ z) = x ⇨ (y ⊓ z)

namespace PartialCorrectness.DemonicChoice
omit [MAlgOrdered m l] in
lemma spec_mono {α : Type u}  {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma NonDetT.wp_mono  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] {α : Type u} (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma NonDetT.wp_bind  {l : Type u} [CompleteLattice l] [MAlgOrdered m l] [LawfulMonad m] {α β : Type u} (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) [Findable p] post :
  _root_.wp (NonDetT.pickCont τ p f) post =  ⨅ a, ⌜p a⌝ ⇨ _root_.wp (f a) post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_repeatCont {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) (cont : α -> NonDetT m β) post :
  _root_.wp (NonDetT.repeatCont init f cont) post = ⨆ (inv : ForInStep _ -> l),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma MonadNonDet.wp_pick {τ : Type u} [Inhabited τ] post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iInf post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma MonadNonDet.wp_assume {as : Prop} [Decidable as] post :
  _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⇨ post .unit
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) [Findable p] post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⨅ a, ⌜p a⌝ ⇨ post a
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma MonadNonDet.wp_repeat {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) post :
  _root_.wp (MonadNonDet.rep (m := NonDetT m) init f) post = ⨆ (inv : ForInStep _ -> l),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) post
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.DemonicChoice
lemma MonadNonDet.wp_forIn {β : Type u} (init : β) (f : Unit -> β -> NonDetT m (ForInStep β))
  (inv : β -> l) (on_done' : β -> l) :
  (∀ b, inv b <= wp (f () b) (fun | .yield b' => inv b' | .done b' => inv b' ⊓ on_done' b')) ->
  triple (inv init) (forIn (m := NonDetT m) Lean.Loop.mk init f) (fun b => inv b ⊓ on_done' b)
end PartialCorrectness.DemonicChoice

namespace PartialCorrectness.AngelicChoice
lemma spec_mono {α : Type u} {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma NonDetT.wp_mono [LawfulMonad m] {α : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma NonDetT.wp_bind [LawfulMonad m] {α β : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) [Findable p] post :
  _root_.wp (NonDetT.pickCont τ p f) post = ⨆ a, ⌜p a⌝ ⊓ _root_.wp (f a) post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_repeatCont {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) (cont : α -> NonDetT m β) post :
  _root_.wp (NonDetT.repeatCont init f cont) post = ⨆ (inv : ForInStep _ -> l),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma MonadNonDet.wp_pick {τ : Type u} [Inhabited τ] post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iSup post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma MonadNonDet.wp_assume {as : Prop} [Decidable as] post : _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⊓ post .unit
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) [Findable p] post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⨆ a, ⌜p a⌝ ⊓ post a
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma MonadNonDet.wp_repeat {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) post :
  _root_.wp (MonadNonDet.rep (m := NonDetT m) init f) post = ⨆ (inv : ForInStep _ -> l),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) inv⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) post
end PartialCorrectness.AngelicChoice

namespace PartialCorrectness.AngelicChoice
lemma MonadNonDet.wp_forIn {β : Type u} (init : β) (f : Unit -> β -> NonDetT m (ForInStep β))
  (inv : β -> l) (on_done' : β -> l) :
  (∀ b, inv b <= wp (f () b) (fun | .yield b' => inv b' | .done b' => inv b' ⊓ on_done' b')) ->
  triple (inv init) (forIn (m := NonDetT m) Lean.Loop.mk init f) (fun b => inv b ⊓ on_done' b)
end PartialCorrectness.AngelicChoice

namespace TotalCorrectness.DemonicChoice
omit [MAlgOrdered m l] in
lemma spec_mono {α : Type u}  {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma NonDetT.wp_mono [LawfulMonad m] {α : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma NonDetT.wp_bind [LawfulMonad m] {α β : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) [Findable p] post :
  _root_.wp (NonDetT.pickCont τ p f) post = ⌜∃ h, p h⌝ ⊓ ⨅ a, ⌜p a⌝ ⇨ _root_.wp (f a) post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_repeatCont {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) (cont : α -> NonDetT m β) post :
  _root_.wp (NonDetT.repeatCont init f cont) post = ⨆ (inv : ForInStep _ -> l) (measure : _ → Nat),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma MonadNonDet.wp_pick {τ : Type u} [Inhabited τ] post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iInf post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma MonadNonDet.wp_assume {as : Prop} [Decidable as] post : _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⊓ post .unit
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) [Findable p] post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⌜∃ h, p h⌝ ⊓ ⨅ a, ⌜p a⌝ ⇨ post a
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma MonadNonDet.wp_repeat {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) post :
  _root_.wp (MonadNonDet.rep (m := NonDetT m) init f) post = ⨆ (inv : ForInStep _ -> l) (measure : _ → Nat),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) post
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.DemonicChoice
lemma MonadNonDet.wp_forIn {β : Type u} (init : β) (f : Unit -> β -> NonDetT m (ForInStep β))
  (inv : β -> l) (on_done' : β -> l) (measure: β → Nat):
  (∀ b, inv b <= wp (f () b) (fun | .yield b' => inv b' ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv b' ⊓ on_done' b')) ->
  triple (inv init) (forIn (m := NonDetT m) Lean.Loop.mk init f) (fun b => inv b ⊓ on_done' b)
end TotalCorrectness.DemonicChoice

namespace TotalCorrectness.AngelicChoice
lemma spec_mono {α : Type u} {l : Type u} [CompleteLattice l] (pre : l) (post : α -> l) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  spec pre post f <= spec pre post g
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma NonDetT.wp_mono [LawfulMonad m] {α : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f g : α -> l) :
  (∀ a, f a <= g a) ->
  NonDetT.wp x f <= NonDetT.wp x g
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma NonDetT.wp_bind [LawfulMonad m] {α β : Type u} {l : Type u} [CompleteLattice l] [MAlgOrdered m l] (x : NonDetT m α) (f : α -> NonDetT m β)
  (post : β -> l):
  NonDetT.wp (x.bind f) post = NonDetT.wp x (fun x => NonDetT.wp (f x) post)
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_vis {β : Type u} (x : m β) (f : β → NonDetT m α) post :
  _root_.wp (NonDetT.vis x f) post = _root_.wp x fun a => _root_.wp (f a) post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma NonDetT.wp_lift (c : m α) post :
  _root_.wp (liftM (n := NonDetT m) c) post = _root_.wp c post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_pickCont {τ : Type u} p (f : τ → NonDetT m α) [Findable p] post :
  _root_.wp (NonDetT.pickCont τ p f) post = ⨆ a, ⌜p a⌝ ⊓ _root_.wp (f a) post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_repeatCont {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) (cont : α -> NonDetT m β) post :
  _root_.wp (NonDetT.repeatCont init f cont) post = ⨆ (inv : ForInStep _ -> l) (measure : _ -> Nat),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) (fun b => wp (cont b) post)
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
@[simp]
lemma NonDetT.wp_pure (x : α) post :
  _root_.wp (NonDetT.pure (m := m) x) post = post x
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma MonadNonDet.wp_pick {τ : Type u} [Inhabited τ] post :
  _root_.wp (MonadNonDet.pick (m := NonDetT m) τ) post = iSup post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma MonadNonDet.wp_assume {as : Prop} [Decidable as] post : _root_.wp (MonadNonDet.assume (m := NonDetT m) as) post = ⌜as⌝ ⊓ post .unit
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma MonadNonDet.wp_pickSuchThat {τ : Type u} (p : τ → Prop) [Findable p] post :
  _root_.wp (MonadNonDet.pickSuchThat (m := NonDetT m) τ p) post = ⨆ a, ⌜p a⌝ ⊓ post a
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma MonadNonDet.wp_repeat {α : Type u} (init : α) (f : α -> NonDetT m (ForInStep α)) post :
  _root_.wp (MonadNonDet.rep (m := NonDetT m) init f) post = ⨆ (inv : ForInStep _ -> l) (measure : _ -> Nat),
    ⌜ ∀ b, (inv (ForInStep.yield b)) <= wp (f b) (fun | .yield b' => inv (.yield b') ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv (.done b'))⌝ ⊓
    spec (inv (.yield init)) (fun b => inv (.done b)) post
end TotalCorrectness.AngelicChoice

namespace TotalCorrectness.AngelicChoice
lemma MonadNonDet.wp_forIn {β : Type u} (init : β) (f : Unit -> β -> NonDetT m (ForInStep β))
  (inv : β -> l) (on_done' : β -> l) (measure : β -> Nat) :
  (∀ b, inv b <= wp (f () b) (fun | .yield b' => inv b' ⊓ ⌜ measure b' < measure b ⌝ | .done b' => inv b' ⊓ on_done' b')) ->
  triple (inv init) (forIn (m := NonDetT m) Lean.Loop.mk init f) (fun b => inv b ⊓ on_done' b)
end TotalCorrectness.AngelicChoice

@[ext]
lemma W_ext (t : Type v) (α : Type u) [Preorder t] (w w' : W t α) :
  w.wp = w'.wp → w = w'
</all_available_lemmas>

<local_ctx>
import Mathlib.Logic.Function.Basic

import Mathlib.Order.CompleteBooleanAlgebra

import Mathlib.Order.Lattice

import Mathlib.Order.Basic

import Mathlib.Data.W.Basic

import Mathlib.Data.FinEnum

import Loom.MonadAlgebras.WP.Gen

import Loom.MonadAlgebras.WP.Liberal

import Loom.MonadAlgebras.NonDetT'.Basic

open Lean.Order

inductive AccFrom (p : Nat -> Prop) : Nat -> Prop
    | now : p i -> AccFrom p i
    | later : ¬ p i -> AccFrom p (i + 1) -> AccFrom p i

def findNat (p : Nat -> Prop) [DecidablePred p] : Option Nat :=
  let rec aux i :=
    if p i then
      some i
    else
      aux (i + 1)
  partial_fixpoint
  aux 0

lemma AccFrom_findNat (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  AccFrom p i -> (findNat.aux p i).isSome

lemma AccFrom_of_p (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  p i -> ∀ j ≤ i, AccFrom p j

lemma exists_findNat (p : Nat -> Prop) [DecidablePred p] :
  (∃ x, p x) ↔ (findNat p).isSome

lemma findNat_none (p : Nat -> Prop) [DecidablePred p] :
  (findNat p).isNone -> ∀ i, ¬ p i

lemma findNat_aux_some_le (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  findNat.aux p i = some j -> ∀ k, i <= k -> k < j -> ¬ p k

lemma findNat_some_p (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  findNat p = some i -> p i
</local_ctx>

<target_theorem>
lemma p_findNat_some (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  p i -> ∃ j, p j ∧ j <= i ∧ findNat p = some j :=
</target_theorem>

