syntax "method" ident leafny_binder* "return" "(" ident ":" term ")"
  (require_caluse )*
  (ensures_caluse)* "do" doSeq
  Termination.suffix : command

syntax "ensures" termBeforeReqEnsDo : ensures_caluse

syntax "while_some" term ":|" termBeforeDo "do" doSeq : doElem

syntax "while_some" term ":|" term
  (invariantClause)+
  (doneWith)?
  "do" doSeq : doElem

syntax "let" term ":|" term : doElem

syntax "done_with" termBeforeDo : doneWith

syntax "invariant" termBeforeDo linebreak : invariantClause

syntax "while" term
  (invariantClause)*
  (doneWith)?
  (decreasingTerm)?
  "do" doSeq : doElem

syntax "(mut" ident ":" term ")" : leafny_binder

macro_rules
  | `(doElem| let $x:term :| $t) => `(doElem| let $x:term <- pickSuchThat _ (fun $x => type_with_name_prefix `choice $t))

macro_rules
  | `(doElem| while $t do $seq:doSeq) => do
    let decr <- withRef (<- getRef) `(decreasing none)
    let invs <- withRef (<- getRef) `(invariants [])
    `(doElem|
      for _ in Lean.Loop.mk do
        $invs:term
        onDoneGadget (with_name_prefix `done ¬$t:term)
        $decr:term
        if $t then
          $seq:doSeq
        else break)
  | `(doElem| while $t
              $[invariant $inv:term
              ]*
              $[done_with $inv_done]?
              $[decreasing $measure]?
              do $seq:doSeq) => do
      let invs <- `(invariants [ $[(with_name_prefix `invariant $inv:term)],* ])
      let invd_some ← match inv_done with
      | some invd_some => withRef invd_some ``($invd_some)
      | none => ``(¬$t:term)
      match measure with
      | some measure_some =>
        let decr <- withRef measure_some `(decreasing type_with_name_prefix `decreasing $measure_some)
        `(doElem|
          for _ in Lean.Loop.mk do
            $invs:term
            onDoneGadget (with_name_prefix `done $invd_some:term)
            $decr:term
            if $t then
              $seq:doSeq
            else break)
      | none => do
        let decr <- withRef (<- getRef) `(decreasing none)
        let invs <- `(invariants [ $[(with_name_prefix `invariant $inv:term)],* ])
        `(doElem|
          for _ in Lean.Loop.mk do
            $invs:term
            onDoneGadget (with_name_prefix `done $invd_some:term)
            $decr:term
            if $t then
              $seq:doSeq
            else break)
  | `(doElem| while_some $x:ident :| $t do $seq:doSeq) =>
    match seq with
    | `(doSeq| $[$seq:doElem]*)
    | `(doSeq| $[$seq:doElem;]*)
    | `(doSeq| { $[$seq:doElem]* }) =>
      `(doElem|
        while ∃ $x:ident, $t do
          let $x :| $t
          $[$seq:doElem]*)
    | _ => Lean.Macro.throwError "while_some expects a sequence of do-elements"
  | `(doElem| while_some $x:ident :| $t
              $[invariant $inv:term
              ]*
              $[done_with $inv_done]? do
                $seq:doSeq) => do
    let invs <- `(invariants [ $[(with_name_prefix `invariant $inv:term)],* ])
    let invd_some ← match inv_done with
    | some invd_some => withRef invd_some ``($invd_some)
    | none => ``(¬$t:term)
    match seq with
    | `(doSeq| $[$seq:doElem]*)
    | `(doSeq| $[$seq:doElem;]*)
    | `(doSeq| { $[$seq:doElem]* }) =>
      let decr <- withRef (<- getRef) `(decreasing none)
      `(doElem|
        for _ in Lean.Loop.mk do
          $invs:term
          onDoneGadget (with_name_prefix `done $invd_some:term)
          $decr:term
          if ∃ $x:ident, $t then
            let $x :| $t
            $[$seq:doElem]*
          else break)
    | _ => Lean.Macro.throwError "while_some expects a sequence of do-elements"
  | `(doElem| for $x:ident in $t
            $[invariant $inv:term
            ]*
            do $seq:doSeq) => do
      let invs <- `(invariants [ $[(with_name_prefix `invariant $inv:term)],* ])
      match seq with
      | `(doSeq| $[$seq:doElem]*)
      | `(doSeq| $[$seq:doElem;]*)
      | `(doSeq| { $[$seq:doElem]* }) =>
        `(doElem|
          for $x:ident in $t do
            $invs:term
            $[$seq:doElem]*)
      | _ => Lean.Macro.throwError "for expects a sequence of do-elements"

macro_rules
  | `(tactic|loom_solver) =>
    `(tactic|(
      try simp at *
      try aesop))

macro_rules
  | `(doElem| while $t
              $[invariant $inv:term
              ]*
              $[done_with $inv_done]?
              $[decreasing $measure]?
              do $seq:doSeq) => do
      let balance := mkIdent `balance_name
      let balanceType <- `(term| Bal)
      let inv : Array Term <- inv.mapM fun (inv : Term) => withRef inv ``(fun ($(balance):ident : $balanceType)=> with_name_prefix `inv $inv)
      let invd_some <- match inv_done with
      | some invd_some => withRef invd_some ``(fun ($(balance):ident : $balanceType) => with_name_prefix `done $invd_some)
      | none => ``(fun ($(balance):ident : $balanceType) => with_name_prefix `done ¬$t:term)
      match measure with
      | some measure_some =>
        let measure_some ← withRef measure_some ``(type_with_name_prefix `decreasing ($measure_some:term))
        do
        `(doElem|
          for _ in Lean.Loop.mk do
            invariantGadget [ $[$inv:term],* ]
            onDoneGadget ($invd_some:term)
            decreasingGadget ($measure_some:term)
            if $t then
              $seq:doSeq
            else break)
      | none => do
        `(doElem|
          for _ in Lean.Loop.mk do
            invariantGadget [ $[$inv:term],* ]
            onDoneGadget ($invd_some:term)
            decreasingGadget none
            if $t then
              $seq:doSeq
            else break)

macro_rules
| `(doElem|balance_set $t) => do
  let balId := mkIdent `balance
  `(doElem|do
    $balId:ident := $t
    set $balId:ident
    $balId:ident ← get)

macro_rules
  | `(doElem|$id:ident[$idx:term] := $val:term) =>
    `(doElem| $id:term := ($id:term).modify $idx (fun _ => $val))
  | `(doElem|$id:ident[$idx:term] += $val:term) =>
    `(doElem| $id:term := ($id:term).modify $idx (· + $val))

WithName

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

LogicLift

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) => ⊥) = ⊥

triple

notation "{" P "}" c "{" v "," Q "}" => triple P c (fun v => Q)

SpV

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

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 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]! :=

:= by
      simp [triple]
      intro b1 b2
      apply wp_cons (SpVSpV out spv1 spv2)
        fun ⟨_, outNew⟩ =>
          outNew[0]! = spv_dot spv1 spv2 0 0 ∧ outNew.size = 1
      { rintro outNew; simp
        intro sum_eq sz_eq
        simp [sum_eq]
        exact spv_dot_pure spv1 spv2 n b1 b2 }
      simp
      have triple_true := SpVSpV_correct out spv1 spv2
      simp [triple] at triple_true
      simp [WithName] at triple_true
      exact triple_true


triple

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

wp

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

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

sumUpTo

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]!

import Auto

import Lean

import Mathlib.Algebra.BigOperators.Intervals

import Mathlib.Algebra.Ring.Int.Defs

import Loom.MonadAlgebras.NonDetT.Extract

import Loom.MonadAlgebras.WP.Tactic

import Loom.MonadAlgebras.WP.DoNames'

import CaseStudies.Velvet.Std

section SpMV

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]!]!)

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]!) :=

:= by
      simp [triple]
      intro h_b
      apply wp_cons
        (spmv out arr spv spm)
        fun ⟨_, outNew⟩ =>
          ((∀ i < spm.size, outNew[i]! = sumUpTo spm[i]! arr spm[i]!.size) ∧ spm.size = outNew.size)
      { simp; rintro outNew;
        intro sum_eq sz_eq j h_j
        have single_elem : (Array.replicate 1 outNew[j]!)[0]! = outNew[j]! := by
          simp
          -- simp [getElem!] at replicate_get
          -- simp [getElem, replicate_get]
        have single_th := VSpV_correct_pure
          (Array.replicate 1 outNew[j]!)
          arr
          spm[j]!
          (h_b j (by rw [←sz_eq] at h_j; exact h_j))
          (by simp)
          (by simp; exact sum_eq j (by rw [←sz_eq] at h_j; exact h_j))
        simp at single_th
        simp [←single_th] }
      simp
      have triple_true := spmv_correct out arr spv spm
      simp [triple] at triple_true
      exact triple_true


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]! :=

:= by
      simp [triple]
      intro h_b
      apply wp_cons (VSpV out arr spv)
        fun ⟨u, outNew⟩ =>
          (outNew[0]! = sumUpTo spv arr spv.size ∧ outNew.size = 1)
      { rintro ⟨u, outNew⟩; simp
        intro sum_eq sz
        exact VSpV_correct_pure outNew arr spv h_b sz sum_eq }
      simp
      have triple_true := VSpV_correct out arr spv
      simp [triple] at triple_true
      apply triple_true


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

MonadNonDet

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 α

wlp

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

iwp

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

Cont.inv

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

Cont

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

NonDetT

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 α

CCPOBot

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

WPGen

structure WPGen (x : m α) where
  get : Cont l α

  prop : ∀ post, get post <= wp x post

CCPOBotLawful

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

NonDetT.wp

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

MAlgOrdered

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)

NonDetT.μ

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

MAlg.lift

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

MAlg

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)

NonDetT.bind

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

WPGen.bind

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 -/

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

Context

structure Context where
  ref         : Syntax

  m           : Syntax

  returnType  : Syntax
  mutableVars : VarSet := {}
  insideFor   : Bool := false

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

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

LogicLift

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) => ⊥) = ⊥

NonDetT.pickSuchThat

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

{l

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

triple

notation "{" P "}" c "{" v "," Q "}" => triple P c (fun v => Q)

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

lemma wp_bind {β} (x : m α) (f : α -> m β) (post : β -> l) :
    wp (x >>= f) post = wp x (fun x => wp (f x) 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 wlp_himp (c : m α) (post post' : α -> l) :
  wp c (fun x => post' x ⇨ post x) = wlp c post' ⇨ wp c post

omit [LawfulMonad m] in
lemma wp_wlp (c : m α) (post : α -> l) :
  wp c post <= wlp c post

@[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

lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post

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)

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

@[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

@[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

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

ExtractNonDet.prop

lemma ExtractNonDet.extract_refines_wp (s : NonDetT m α) (inst : ExtractNonDet Findable s) :
  wp s post ⊓ s.prop ⊤ <= wp s.extract post

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

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)

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) :=

variable [Monad m] [CCPOBot m] [CompleteBooleanAlgebra l] [MAlgOrdered m l] [MAlgDet m l] [LawfulMonad m]

@[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

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 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 ⊤

namespace DemonicChoice

lemma ExtractNonDet.extract_refines (pre : l) (s : NonDetT m α) (inst : ExtractNonDet Findable s) :
  triple pre s post ->
  pre <= s.prop ⊤ ->
  triple pre s.extract post :=

:= by
  intro tr imp; apply le_trans'; apply ExtractNonDet.extract_refines_wp
  simp; aesop


MAlg.lift

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

MAlg

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)

LogicLift

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) => ⊥) = ⊥

MAlgOrdered

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)

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)

wp

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

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

import Loom.MonadAlgebras.Defs

import Loom.MonadAlgebras.Instances.Basic

import Loom.MonadAlgebras.Instances.ExceptT

import Loom.MonadAlgebras.Instances.StateT

import Loom.MonadAlgebras.Instances.ReaderT

import Loom.MonadAlgebras.Instances.Gen

variable {m : Type u -> Type v} [Monad m] [LawfulMonad m] {α : Type u} {l : Type u}

section

variable [CompleteLattice l]

section

variable [mprop : MAlgOrdered m l]

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

end

variable [MAlgOrdered m l]

end

section

variable [CompleteLattice l] [MAlgOrdered m l]

noncomputable

end

section Determinism

variable [inst: CompleteLattice l] [MAlgOrdered m l]

end Determinism

section Loops

open Lean.Order

variable [inst: _root_.CompleteLattice l] [MAlgOrdered m l]

namespace PartialCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m] [MAlgPartial m]

end PartialCorrectness

namespace TotalCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m]

variable [MAlgTotal m]

end TotalCorrectness

end Loops

section Lift

variable [inst: CompleteLattice l] [MAlgOrdered m l]

open ExceptionAsSuccess in

open ExceptionAsFailure in

open TotalCorrectness in

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

:= by
  simp [wp, liftM, monadLift, MAlg.lift_StateT, MonadLift.monadLift, StateT.lift];
  have liftE : ∀ α, MAlg.lift (m := m) (α := α) = wp := by intros; ext; simp [wp, liftM, monadLift]
  ext s; rw [map_eq_pure_bind, liftE, liftE, wp_bind]; simp [wp_pure]


MAlgGenInst

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

triple

notation "{" P "}" c "{" v "," Q "}" => triple P c (fun v => Q)

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 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 ReaderT.wp_eq (c : ReaderT σ m α) (post : α -> σ -> l) :
  wp c post = fun s => wp (m := m) (c s) (post · s)

import Loom.MonadAlgebras.Defs

import Loom.MonadAlgebras.Instances.Basic

import Loom.MonadAlgebras.Instances.ExceptT

import Loom.MonadAlgebras.Instances.StateT

import Loom.MonadAlgebras.Instances.ReaderT

import Loom.MonadAlgebras.Instances.Gen

variable {m : Type u -> Type v} [Monad m] [LawfulMonad m] {α : Type u} {l : Type u}

section

variable [CompleteLattice l]

section

variable [mprop : MAlgOrdered m l]

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

end

variable [MAlgOrdered m l]

end

section

variable [CompleteLattice l] [MAlgOrdered m l]

noncomputable

end

section Determinism

variable [inst: CompleteLattice l] [MAlgOrdered m l]

end Determinism

section Loops

open Lean.Order

variable [inst: _root_.CompleteLattice l] [MAlgOrdered m l]

namespace PartialCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m] [MAlgPartial m]

end PartialCorrectness

namespace TotalCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m]

variable [MAlgTotal m]

end TotalCorrectness

end Loops

section Lift

variable [inst: CompleteLattice l] [MAlgOrdered m l]

open ExceptionAsSuccess in

open ExceptionAsFailure in

open TotalCorrectness in

end Lift

section ExceptT

variable [inst: CompleteLattice l] [MAlgOrdered m l] [IsHandler (ε := ε) hd]

end ExceptT

section StateT

variable [inst: CompleteLattice l] [MAlgOrdered m l]

end StateT

section ReaderT

variable [inst: CompleteLattice l] [MAlgOrdered m l]

end ReaderT

section Gen

open Plausible

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

:= by
    simp [triple, MAlgGenInst, ReaderT.wp_eq, StateT.wp_eq]
    simp [wp, liftM, monadLift, MAlg.lift, MAlgOrdered.μ]; rfl


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

MAlgLiftT

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

LogicLiftT

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) => ⊥) = ⊥

LE.pure

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

IsHandler

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

Except.getD

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

MAlgExcept

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 -/

Except.bind'

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

OfHd

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

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⌝)

wp

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

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⌝)

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⌝

import Loom.MonadAlgebras.Defs

import Loom.MonadAlgebras.Instances.Basic

import Loom.MonadAlgebras.Instances.ExceptT

import Loom.MonadAlgebras.Instances.StateT

import Loom.MonadAlgebras.Instances.ReaderT

import Loom.MonadAlgebras.Instances.Gen

variable {m : Type u -> Type v} [Monad m] [LawfulMonad m] {α : Type u} {l : Type u}

section

variable [CompleteLattice l]

section

variable [mprop : MAlgOrdered m l]

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

end

variable [MAlgOrdered m l]

end

section

variable [CompleteLattice l] [MAlgOrdered m l]

noncomputable

end

section Determinism

variable [inst: CompleteLattice l] [MAlgOrdered m l]

end Determinism

section Loops

open Lean.Order

variable [inst: _root_.CompleteLattice l] [MAlgOrdered m l]

namespace PartialCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m] [MAlgPartial m]

end PartialCorrectness

namespace TotalCorrectness

variable [∀ α, CCPO (m α)] [MonoBind m]

variable [MAlgTotal m]

end TotalCorrectness

end Loops

section Lift

variable [inst: CompleteLattice l] [MAlgOrdered m l]

open ExceptionAsSuccess in

open ExceptionAsFailure in

open TotalCorrectness in

end Lift

section ExceptT

variable [inst: CompleteLattice l] [MAlgOrdered m l] [IsHandler (ε := ε) hd]

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⌝ :=

:= by
    rw [MAlgLift.wp_lift, ExceptT.wp_throw]
    simp only [LE.pure]; split <;> simp [inst.cl.lift_top, inst.cl.lift_bot]


theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

findNat

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

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

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 p_findNat_some (p : Nat -> Prop) [DecidablePred p] (i : Nat) :
  p i -> ∃ j, p j ∧ j <= i ∧ findNat p = some j :=

:= by
  intro pi;
  have : (findNat p).isSome := by
    false_or_by_contra; rename_i h
    simp at h
    rw [←Option.isNone_iff_eq_none] at h
    have h := findNat_none _ h
    aesop
  revert this; simp [Option.isSome_iff_exists]
  intro x h
  have := findNat_aux_some_le p 0 h
  exists x; repeat' constructor
  { solve_by_elim [findNat_some_p] }
  { have h := fun h₁ h₂ => this _ h₁ h₂ pi
    simp at h; exact h }
  solve_by_elim


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

:= by
  intro pi;
  have : (findNat p).isSome := by
    false_or_by_contra; rename_i h
    simp only [Bool.not_eq_true, Option.isSome_eq_false_iff] at h
    have h := findNat_none _ h
    aesop
  revert this; simp [Option.isSome_iff_exists]
  intro x h
  have := findNat_aux_some_le p 0 h
  exists x; repeat' constructor
  { solve_by_elim [findNat_some_p] }
  { have h := fun h₁ h₂ => this _ h₁ h₂ pi
    simp at h; exact h }
  solve_by_elim


WPGen.assert

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 -/

WPGen.if

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 -/

WPGen.let

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 -/
macro "⌜" p:term "⌝" : term => `(LE.pure $p)

LE.pure

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

spec

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

MAlgOrdered

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)

Findable

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

find

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

MAlg.lift

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

MAlg

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)

wp

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

triple

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

Loop.forIn.loop

@[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

WPGen.bind

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 -/

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

Context

structure Context where
  ref         : Syntax

  m           : Syntax

  returnType  : Syntax
  mutableVars : VarSet := {}
  insideFor   : Bool := false

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

WPGen

structure WPGen (x : m α) where
  get : Cont l α

  prop : ∀ post, get post <= wp x post

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

CCPOBotLawful

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

@[aesop safe]
lemma emp_sum (x: Bal) (h: 0 ≤ x) : ∃ h: List Nat, h.sum ≤ x

WPGen.intro

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⌝)

trueE

@[simp]
lemma trueE (l : Type v) [inst: LE l] [OrderTop l] [OrderBot l] : ⌜True⌝ = (⊤ : l)

falseE

@[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)

MAlgOrdered.bind

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)

leE

@[loomLogicSimp]
lemma leE (l : Type u) [PartialOrder l] (a b : α -> l) : a ≤ b ↔ ∀ x, a x ≤ b x

lePropE

@[loomLogicSimp]
lemma lePropE (a b : Prop) : (a ≤ b) = (a → b)

pureE

@[loomLogicSimp]
lemma pureE (l : Type u) [CompleteLattice l] (a : Prop) : (⌜a⌝ : α -> l) = fun _ => ⌜a⌝

purePropE

@[loomLogicSimp]
lemma purePropE  : (⌜a⌝ : Prop) = a

infPropE

@[loomLogicSimp]
lemma infPropE (a b : Prop) : (a ⊓ b) = (a ∧ b)

infE

@[loomLogicSimp]
lemma infE (l : Type u) [CompleteLattice l] (a b : α -> l) : (a ⊓ b) = fun x => a x ⊓ b x

supE

@[loomLogicSimp]
lemma supE (l : Type u) [CompleteLattice l] (a b : α -> l) : (a ⊔ b) = fun x => a x ⊔ b x

supPropE

@[loomLogicSimp]
lemma supPropE (a b : Prop) : (a ⊔ b) = (a ∨ b)

iInfE

@[loomLogicSimp]
lemma iInfE (l : Type u) [CompleteLattice l] (a : ι -> α -> Prop) : (⨅ i, a i) = fun x => ⨅ i, a i x

iSupE

@[loomLogicSimp]
lemma iSupE (l : Type u) [CompleteLattice l] (a : ι -> α -> Prop) : (⨆ i, a i) = fun x => ⨆ i, a i x

himpE

@[loomLogicSimp]
lemma himpE  (l : Type u) [CompleteBooleanAlgebra l] (a b : α -> l) :
  (a ⇨ b) = fun x => a x ⇨ b x

himpPureE

@[loomLogicSimp]
lemma himpPureE (a b : Prop) :
  (a ⇨ b) = (a -> b)

topE

@[loomLogicSimp]
lemma topE (l : Type u) [CompleteLattice l] : (⊤ : α -> l) = fun _ => ⊤

topPureE

@[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)

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

@[ext]
lemma W_ext (t : Type v) (α : Type u) [Preorder t] (w w' : W t α) :
  w.wp = w'.wp → w = w'

NonDetT.bind

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)

lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post

import Mathlib.Logic.Function.Basic

import Mathlib.Order.CompleteBooleanAlgebra

import Mathlib.Order.Lattice

import Mathlib.Order.Basic

import Loom.MonadAlgebras.WP.Basic

import Loom.MonadAlgebras.WP.Tactic

import Loom.MonadAlgebras.WP.Gen

import Loom.MonadAlgebras.NonDetT.Findable

section NonDeterministicTransformer

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 α

variable {m : Type u -> Type v} {α β : Type u} [Monad 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

variable [CompleteBooleanAlgebra l] [MAlgOrdered m l]

namespace PartialCorrectness

namespace DemonicChoice

/- WP for NonDetT -/
noncomputable

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)

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

variable [LawfulMonad m]

/- Ordered Monad Algebra instance for NonDetT -/
noncomputable
scoped

@[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 :=

:= by
  simp [NonDetT.wp_eq_wp, NonDetT.wp]; congr; ext x
  simp [Membership.mem, Set.Mem]
  by_cases h: p x <;> simp [h]


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

spec

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

MAlgOrdered

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)

Findable

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

find

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

findNat

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

MAlg.lift

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

MAlg

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)

WPGen.bind

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 -/

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

Context

structure Context where
  ref         : Syntax

  m           : Syntax

  returnType  : Syntax
  mutableVars : VarSet := {}
  insideFor   : Bool := false

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

WPGen

structure WPGen (x : m α) where
  get : Cont l α

  prop : ∀ post, get post <= wp x post

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

CCPOBotLawful

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

MAlgOrdered.bind

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)

NonDetT.bind

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)

lemma NonDetT.wp_eq_wp {α : Type u} (x : NonDetT m α) (post : α -> l) :
  _root_.wp x post = NonDetT.wp x post

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)

import Mathlib.Logic.Function.Basic

import Mathlib.Order.CompleteBooleanAlgebra

import Mathlib.Order.Lattice

import Mathlib.Order.Basic

import Loom.MonadAlgebras.WP.Basic

import Loom.MonadAlgebras.WP.Tactic

import Loom.MonadAlgebras.WP.Gen

import Loom.MonadAlgebras.NonDetT.Findable

section NonDeterministicTransformer

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 α

variable {m : Type u -> Type v} {α β : Type u} [Monad 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

variable [CompleteBooleanAlgebra l] [MAlgOrdered m l]

namespace PartialCorrectness

namespace DemonicChoice

/- WP for NonDetT -/
noncomputable

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)

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

variable [LawfulMonad m]

/- Ordered Monad Algebra instance for NonDetT -/
noncomputable
scoped

end DemonicChoice

namespace AngelicChoice

/- WP for NonDetT -/
noncomputable

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)

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

variable [LawfulMonad m]

/- Ordered Monad Algebra instance for NonDetT -/
noncomputable
scoped

end AngelicChoice

end PartialCorrectness

namespace TotalCorrectness

namespace DemonicChoice

/- WP for NonDetT -/
noncomputable

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)

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

variable [LawfulMonad m]

/- Ordered Monad Algebra instance for NonDetT -/
noncomputable
scoped

@[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 :=


import PCF.Utility
import «PCF».Flat
import PCF.Domain
import «PCF».Context

notation:max "⟦" τ " ty⟧" => Ty.den τ

notation:max "⟦" Γ " cx⟧" => Ev Γ

notation:100 "⟦" t "⟧" => Tm.den t

notation:100 "⟦" r "⟧" => Ren.den r

notation:100 "⟦" σ "⟧" => Sb.den σ

notation:100 "⟦" C " con⟧" => Con.den C

notation:101 f " • " x:100 => Mono.act' (Cont.fn f) x

notation:101 f " • " x:100 => Mono.act' (Cont.fn f) x

notation:max "⨆" => Domain.sup

notation:max "⋆" => Order.refl

notation:max "⊥" => Domain.bot

Mono

structure Mono (α) (β) [Order α] [Order β] where
  act : α → β
  act' : is_monotone act

Tm

inductive Tm : Cx → Ty → Type
  | var : ∀ τ, Γ ∋ τ → Tm Γ τ
  | true : Tm Γ .bool
  | false : Tm Γ .bool
  | zero : Tm Γ .nat
  | succ : Tm Γ .nat → Tm Γ .nat
  | pred : Tm Γ .nat → Tm Γ .nat
  | zero? : Tm Γ .nat → Tm Γ .bool
  | cond : Tm Γ .bool → Tm Γ τ → Tm Γ τ → Tm Γ τ
  | fn : Tm (Γ ∷ τ) υ → Tm Γ (τ ⇒ υ)
  | app : Tm Γ (τ ⇒ υ) → Tm Γ τ → Tm Γ υ
  | fix : Tm Γ (τ ⇒ τ) → Tm Γ τ

Cont.eval

def Cont.eval {α : Type i} {β : Type j} [Order α] [Order β] [Domain α] [Domain β]
  : Cont (Cont α β × α) β := ⟨
    Mono.eval_cont,
    by admit /- proof elided -/
  ⟩

Cont.fst

def Cont.fst [Order α] [Order β] [Domain α] [Domain β] : Cont (α × β) α :=
  ⟨⟨Prod.fst, And.left⟩, Domain.sup_is_mono (fun _ ↦ ⋆)⟩

Cont

structure Cont (α) (β) [Order α] [Order β] [Domain α] [Domain β] where
  fn : Mono α β
  sub : ∀ {c : Chain α}, fn.act (⨆ c) ⊑ ⨆ (fn ∘ c)

Domain

class Domain (α) [Order α] where
  bot : α
  sup : (c : Chain α) → α
  is_bot {x} : bot ⊑ x
  is_bound (c) (n): c.act n ⊑ sup c
  is_least (c) {d} : ({n : _} → c.act n ⊑ d) → sup c ⊑ d

Order

class Order (α) where
  R : α → α → Prop
  refl {x} : R x x
  trans {x y z} : R x y → R y z → R x z
  anti {x y} : R x y → R y x → x = y

Chain

def Chain (α : Type i) [Order α] := Mono Nat α

def is_monotone [Order α] [Order β] (f : α → β) := ∀ {x y : α}, x ⊑ y → f x ⊑ f y

Cont.snd

def Cont.snd [Order α] [Order β] [Domain α] [Domain β] : Cont (α × β) β :=
  ⟨⟨Prod.snd, And.right⟩, Domain.sup_is_mono (fun _ ↦ ⋆)⟩

Chain.apply

def Chain.apply [Order α] [Order β] [Domain α] [Domain β] (c : Chain (Cont α β)) (a : α) : Chain β
  := Mono.apply c a

Mono.apply

def Mono.apply [Order α] [Order β] [Domain α] [Domain β] (c : Mono Nat (Cont α β)) (a : α) : Chain β where
  act := fun n ↦ (c n) a
  act' := fun a_b ↦ (c • a_b) _

def Mono.eval_cont {α : Type i} {β : Type j} [Order α] [Order β] [Domain α] [Domain β]
  : Mono (Cont α β × α) β :=
  ⟨fun x ↦ x.fst x.snd, fun {x y} p ↦ (x.fst • p.right) ⬝ (p.left y.snd)⟩

def Mono.from_cont [Order α] [Order β] [Domain α] [Domain β] : Mono (Cont α β) (Mono α β) :=
  ⟨Cont.fn, fun p a ↦ p a⟩

Mono.sup

def Mono.sup [Order α] [Domain α] : Mono (Chain α) α :=
  ⟨⨆, Domain.sup_is_mono⟩

Cont.comp'

def Cont.comp' [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ] (f : Cont β γ) (g : Cont α β)
  : Cont α γ
  := ⟨
    ⟨fun x ↦ f (g x), fun x_y ↦ f • g • x_y⟩,
    by admit /- proof elided -/
  ⟩

Mono.eval

def Mono.eval {α : Type i} {β : Type j} [Order α] [Order β] : Mono (Mono α β × α) β :=
  ⟨fun x ↦ x.fst x.snd, fun {x y} p ↦ (x.fst • p.right) ⬝ (p.left y.snd)⟩

Chain.fst

def Chain.fst [Order α] [Order β] (c : Chain (α × β)) : Chain α :=
  ⟨fun n ↦ (c n).fst, fun p ↦ by admit /- proof elided -/
  ⟩

Chain.snd

def Chain.snd [Order α] [Order β] (c : Chain (α × β)) : Chain β :=
  ⟨fun n ↦ (c n).snd, fun p ↦ by admit /- proof elided -/
  ⟩

Mono.const

def Mono.const [Order α] [Order β] (b : β) : Mono α β := ⟨fun _ ↦ b, fun _ ↦ ⋆⟩

Mono.comp

def Mono.comp {α : Type i} {β : Type j} {γ : Type k} [Order α] [Order β] [Order γ]
  : Mono (Mono β γ × Mono α β) (Mono α γ) := ⟨
    fun h ↦ ⟨fun x ↦ h.fst (h.snd x), fun x_y ↦ h.fst • (h.snd • x_y)⟩,
    fun {h₀ h₁} h a ↦ (h₀.fst • h.right a) ⬝ (h.left (h₁.snd a))
  ⟩

Mono.pair

def Mono.pair [Order α] [Order β] [Order γ]
  (f : Mono γ α) (g : Mono γ β) : Mono γ (α × β) :=
    ⟨fun c ↦ ⟨f c, g c⟩, fun p ↦ ⟨f • p, g • p⟩⟩

Cont.const

def Cont.const [Order α] [Order β] [Domain α] [Domain β] (b : β) : Cont α β := ⟨Mono.const b, fun {c} ↦ by admit /- proof elided -/
  ⟩

def Domain.sup_of_const [Order α] [Domain α] (a : α) : ⨆ (Mono.const a) = a :=
  (by admit /- proof elided -/
  ) ⇄! (Domain.is_bound (Mono.const a) 0)

Cont.flat

def Cont.flat (f : α → β) : (Cont (Flat α) (Flat β)) := (Mono.flat f).promote_trivial

Flat

inductive Flat (α : Type) : Type where
  | none : Flat α
  | some : α → Flat α

Mono.flat

def Mono.flat (f : α → β) : (Mono (Flat α) (Flat β)) := ⟨
    lift_flat f,
    by admit /- proof elided -/
  ⟩

def lift_flat (f : α → β) : Flat α → Flat β
| .none => .none
| .some x => .some (f x)

Cont.cond

def Cont.cond [Order α] [Domain α] : Cont (Flat Bool) (Cont (α × α) α) := ⟨
  cond',
  by admit /- proof elided -/
⟩

cond'

def cond' [Order α] [Domain α] : Mono (Flat Bool) (Cont (α × α) α) := ⟨
  fun b ↦ (
    match b with
    | .none => Cont.const ⊥
    | .some true => Cont.fst
    | .some false => Cont.snd
  ),
  by admit /- proof elided -/
⟩

Cont.pred

def Cont.pred : Cont (Flat Nat) (Flat Nat) := Mono.pred.promote_trivial

Mono.pred

def Mono.pred : Mono (Flat Nat) (Flat Nat) := ⟨
    Nat.partial_pred,
    by admit /- proof elided -/
  ⟩

def Nat.partial_pred : Flat Nat → Flat Nat :=
  fun n ↦ match n with
  | .some (.succ n) => .some n
  | _ => .none

Cont.curry

def Cont.curry {α : Type i} {β : Type j}
  [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ]
  (f : Cont (α × β) γ) : Cont α (Cont β γ) := ⟨
    ⟨
      fun a ↦ ⟨
        ⟨
          fun b ↦ f (a, b),
          fun b' ↦ f • ⟨⋆, b'⟩
        ⟩,
        by admit /- proof elided -/
      ⟩,
      fun a' b ↦ f • ⟨a', ⋆⟩
    ⟩,
    by admit /- proof elided -/
  ⟩

Cont.pair

def Cont.pair [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ]
  (f : Cont γ α) (g : Cont γ β) : Cont γ (α × β) := ⟨
    ⟨fun c ↦ ⟨f c, g c⟩, fun p ↦ ⟨f • p, g • p⟩⟩,
    ⟨f.sub ⬝ Domain.sup_is_mono (fun _ ↦ ⋆), g.sub ⬝ Domain.sup_is_mono (fun _ ↦ ⋆)⟩
  ⟩

Cont.uncurry

def Cont.uncurry {α : Type i} {β : Type j}
  [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ]
  (f : Cont α (Cont β γ)) : Cont (α × β) γ  := ⟨
    Mono.uncurry_cont f,
    by admit /- proof elided -/
  ⟩

def Mono.uncurry_cont {α : Type i} {β : Type j}
  [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ]
  (f : Cont α (Cont β γ)) : Mono (α × β) γ := ⟨
    fun ⟨a, b⟩ ↦ (f a) b,
    by admit /- proof elided -/
  ⟩

Cont.fix'

def Cont.fix' [Order α] [Domain α] : Cont (Cont α α) α := ⟨
    fix_mono,
    by
      intro f
      apply fix_is_least_prefixed
      calc ⨆ f (⨆ (fix_mono ∘ f))
        _ = ⨆ (f.apply (⨆ (fix_mono ∘ f))) := rfl
        _ ⊑ ⨆ (Mono.sup ∘ Mono.comp ∘ Mono.pair (Mono.from_cont ∘ f) (Mono.const (fix_mono ∘ f))) :=

def fix_is_prefixed [Order α] [Domain α] (f : Cont α α) : is_prefixed f (⨆ f.iterations) :=

def sup_succ [Order α] [Domain α] {c : Chain α} : ⨆ (c ∘ Mono.succ) ⊑ ⨆ c :=

Mono.succ

def Mono.succ : Mono Nat Nat := ⟨Nat.succ, Nat.succ_le_succ⟩

Cont.iterations

def Cont.iterations [Order α] [Domain α] (f : Cont α α) : Chain α := ⟨
    fun n ↦ Cont.iter n f ⊥,
    increasing_implies_monotone (fun n ↦ iter n f ⊥) (by admit /- proof elided -/
    )
  ⟩

Cont.iter

def Cont.iter [Order α] [Domain α] : Nat → Cont α α → Cont α α
| 0 => fun _ ↦ Cont.id
| .succ n => fun f ↦ f ∘ iter n f

Cont.id

def Cont.id [Order α] [Domain α] : Cont α α := ⟨Mono.id, ⋆⟩

Mono.id

def Mono.id [Order α] : Mono α α
  := ⟨Function.id, Function.id⟩

Function.id

@[inline] def Function.id {α : Sort u} (a : α) : α := a

def increasing_implies_monotone [Order α] (f : Nat → α) : (∀ n, f n ⊑ f n.succ) → is_monotone f :=

def is_prefixed [Order α] [Domain α] (f : Cont α α) (a : α) := f a ⊑ a

Cont.fix

def Cont.fix [Order α] [Domain α] (f : Cont α α) := ⨆ f.iterations

def fix_is_least_prefixed [Order α] [Domain α] (f : Cont α α) (a : α) (h : is_prefixed f a)
  : f.fix ⊑ a :=

def Cont.fix_mono [Order α] [Domain α] : Mono (Cont α α) α := ⟨
    Cont.fix,
    by admit /- proof elided -/
  ⟩

Nat.zero?

def Nat.zero? : Nat → Bool
| .zero => true
| _ => false

Cont.swap

def Cont.swap [Order α] [Domain α] [Order β] [Domain β] : Cont (α × β) (β × α) := ⟨
  Mono.swap,
    by admit /- proof elided -/
  ⟩

Mono.swap

def Mono.swap [Order α] [Order β] : Mono (α × β) (β × α) := ⟨
    fun p ↦ ⟨p.snd, p.fst⟩,
    fun ⟨a', b'⟩ ↦ ⟨b', a'⟩
  ⟩

def Cont.assoc_swap_assoc {α : Type i} {β : Type j}
  [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ] : Cont ((α × β) × γ) ((α × γ) × β) := ⟨
    Mono.assoc_swap_assoc,
    by admit /- proof elided -/
  ⟩

def Mono.assoc_swap_assoc {α : Type i} {β : Type j}
  [Order α] [Order β] [Order γ] : Mono ((α × β) × γ) ((α × γ) × β) := ⟨
    fun p ↦ ⟨⟨p.fst.fst, p.snd⟩, p.fst.snd⟩,
    fun ⟨⟨a', b'⟩, c'⟩ ↦ ⟨⟨a', c'⟩, b'⟩
  ⟩

Ty

inductive Ty
  | bool
  | nat
  | pow : Ty → Ty → Ty

DomainType

structure DomainType : Type (i + 1) :=
  carrier : Type i
  order : Order carrier
  domain : Domain carrier

Cx

inductive Cx
  | nil
  | cons : Cx -> Ty -> Cx

Ren.weak

def Ren.weak {τ  : Ty} : Ren Γ (Γ ∷ τ) := Var.s

Var

inductive Var : Cx → Ty → Type
  | z : ∀ {Γ : Cx}, Var (Γ ∷ τ) τ
  | s : ∀ {Γ : Cx} {υ : Ty} τ, Var Γ τ → Var (Γ ∷ υ) τ

Sb

def Sb Γ Δ := ∀ τ, Γ ∋ τ → Δ ⊢ τ

infixr:100 " ⇒ " => Ty.pow

infixl:70 " ∷ "  => Cx.cons

infix:70 " ∋ " => Var

infix:70 " ⊢ " => Tm

infix:100 " ⊑ " => Order.R

notation:max "⋆" => Order.refl

infix:100 " ⇄! " => Order.anti

infixl:100 " • " => Mono.act'

notation:max "⊥" => Domain.bot

notation:max "⨆" => Domain.sup

notation:101 f " • " x:100 => Mono.act' (Cont.fn f) x

infix:100 " ∘ " => Cont.comp'

infixr:100 " ∘' " => Cont.comp'

Cont.ext

@[ext] theorem Cont.ext [Order α] [Order β] [Domain α] [Domain β]
  {f g : Cont α β} (p : f.fn.act = g.fn.act) : f = g

theorem congrArg2
  {α₀ : Sort u₀} {α₁ : Sort u₁} {β : Sort v} {a₀ a₀' : α₀} {a₁ a₁' : α₁}
  (f : α₀ → α₁ → β) (h₀ : Eq a₀ a₀') (h₁ : Eq a₁ a₁') : Eq (f a₀ a₁) (f a₀' a₁')

theorem Cont.pair_after [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ] [Order δ] [Domain δ]
  (f : Cont γ α) (g : Cont γ β) (h : Cont δ γ) : (f ∘' h).pair (g ∘' h) = (f.pair g) ∘' h

Ev

def Ev (Γ : Cx) : Type := ∀ τ, Var Γ τ → ↑⟦τ ty⟧

Con.den

theorem Ren.weak_den_eq : (⟦Ren.weak⟧) (Ev.from (ρ, d)) = ρ

import «PCF».Flat

import «PCF».Context

noncomputable def Ty.den : Ty → DomainType
  | .bool => ⟨Flat Bool, _, inferInstance⟩
  | .nat => ⟨Flat Nat, _, inferInstance⟩
  | .pow T₀ T₁ => by admit /- proof elided -/

notation:max "⟦" τ " ty⟧" => Ty.den τ

def Ev (Γ : Cx) : Type := ∀ τ, Var Γ τ → ↑⟦τ ty⟧

notation:max "⟦" Γ " cx⟧" => Ev Γ

def Ev.push {Γ : Cx} (ρ : ⟦Γ cx⟧) {τ : Ty} (d : ↑⟦τ ty⟧) : ⟦Γ ∷ τ cx⟧ :=
  fun {τ} x ↦ match x with
  | .z => d
  | .s τ x => ρ τ x

def Ev.from {Γ : Cx} {τ : Ty} : Cont (⟦Γ cx⟧ × ⟦τ ty⟧) (⟦Γ ∷ τ cx⟧) := ⟨
  ⟨
    fun ⟨ρ, d⟩ υ x ↦ ρ.push d υ x,
    by admit /- proof elided -/
  ⟩,
  by admit /- proof elided -/
⟩

noncomputable def Tm.den : (Γ ⊢ τ) → Cont (⟦Γ cx⟧) (⟦τ ty⟧)
  | .var τ x => ⟨⟨fun ρ ↦ ρ τ x, fun ρ₀_ρ₁ ↦ ρ₀_ρ₁ τ x⟩, ⋆⟩
  | .true => Cont.const (.some .true)
  | .false => Cont.const (.some .false)
  | .zero => Cont.const (.some 0)
  | .succ e => Cont.flat (Nat.succ) ∘ e.den
  | .pred e => Cont.pred ∘ e.den
  | .zero? e => Cont.flat (Nat.zero?) ∘ e.den
  | .cond s t f  => Cont.uncurry (Cont.cond) ∘ Cont.pair s.den (Cont.pair t.den f.den)
  | .fn e  => Cont.curry (e.den ∘ Ev.from)
  | .app f e => Cont.eval ∘ (Cont.pair f.den e.den)
  | .fix f => Cont.fix' ∘ f.den

notation:100 "⟦" t "⟧" => Tm.den t

noncomputable def Ren.den (r : Ren Γ Δ) : Cont (⟦Δ cx⟧) (⟦Γ cx⟧) :=
  ⟨⟨fun ρ _ x ↦ (⟦(x.ren r).tm⟧) ρ, fun ρ' _ x ↦ (⟦(x.ren r).tm⟧) • ρ'⟩, fun _ x ↦ (⟦(x.ren r).tm⟧).sub⟩

notation:100 "⟦" r "⟧" => Ren.den r

noncomputable def Sb.den (σ : Sb Γ Δ) : Cont (⟦Δ cx⟧) (⟦Γ cx⟧) :=
  ⟨⟨fun ρ _ x ↦ (⟦x.sub σ⟧) ρ, fun ρ' _ x ↦ (⟦x.sub σ⟧) • ρ'⟩, fun _ x ↦ (⟦x.sub σ⟧).sub⟩

notation:100 "⟦" σ "⟧" => Sb.den σ

noncomputable def Con.den : Con Δ υ Γ τ → Cont (⟦Γ cx⟧ × Cont (⟦Δ cx⟧) (⟦υ ty⟧)) ⟦τ ty⟧
  | id         => Cont.uncurry Cont.id ∘' Cont.swap
  | comp C₀ C₁ => Cont.uncurry (Cont.curry (C₁.den ∘' Cont.swap)
                             ∘' Cont.curry (C₀.den ∘' Cont.swap)) ∘' Cont.swap
  | sub C σ => Cont.uncurry ((Cont.curry C.den) ∘' (⟦σ⟧))
  | succ C => Cont.flat (Nat.succ) ∘' C.den
  | pred C => Cont.pred ∘' C.den
  | zero? C => Cont.flat (Nat.zero?) ∘' C.den
  | fn C   => Cont.curry ((Cont.uncurry (Cont.curry C.den ∘' Ev.from)) ∘' Cont.assoc_swap_assoc)
  | cond_s C t f => Cont.uncurry (Cont.cond)
    ∘' Cont.pair C.den (Cont.pair ((⟦t⟧) ∘' Cont.fst) ((⟦f⟧) ∘' Cont.fst))
  | cond_t s C f => Cont.uncurry (Cont.cond)
    ∘' Cont.pair ((⟦s⟧) ∘' Cont.fst) (Cont.pair C.den ((⟦f⟧) ∘' Cont.fst))
  | cond_f s t C => Cont.uncurry (Cont.cond)
    ∘' Cont.pair ((⟦s⟧) ∘' Cont.fst) (Cont.pair ((⟦t⟧) ∘' Cont.fst) C.den)
  | app_f C a => Cont.eval ∘' (Cont.pair C.den ((⟦a⟧) ∘' Cont.fst))
  | app_a f C => Cont.eval ∘' (Cont.pair ((⟦f⟧) ∘' Cont.fst) C.den)
  | fix C => Cont.fix' ∘' C.den

notation:100 "⟦" C " con⟧" => Con.den C

theorem Tm.sub_den_eq (e : Γ ⊢ τ) : ∀ {Δ}, (σ : Sb Γ Δ) → ⟦e.sub σ⟧ = (⟦e⟧) ∘' (⟦σ⟧) :=

:= by
  induction e with
  | fn e Φ =>
    intro _ σ
    calc ⟦e.fn.sub σ⟧
      _ = Cont.curry ((⟦e.sub (σ.keep _)⟧) ∘ Ev.from) := rfl
      _ = Cont.curry (((⟦e⟧) ∘' ⟦σ.keep _⟧) ∘ Ev.from) := by rw [Φ (σ.keep _)]
      _ = (⟦e.fn⟧) ∘' ⟦σ⟧ := by {
        apply Cont.ext ∘ funext
        intro ρ
        apply Cont.ext ∘ funext
        intro d
        have p : (⟦σ.keep _⟧) (Ev.from (ρ, d)) = Ev.from ((⟦σ⟧) ρ, d) := by {
          funext τ x
          cases x with
          | z => rfl
          | s τ x =>
            calc (⟦σ.keep _⟧) (Ev.from (ρ, d)) τ x.succ
              _ = (⟦(x.sub σ).ren Ren.weak⟧) (Ev.from (ρ, d)) := rfl
              _ = ((⟦x.sub σ⟧) ∘' ⟦Ren.weak⟧) (Ev.from (ρ, d)) := by rw [(x.sub σ).ren_den_eq]
              _ = (⟦x.sub σ⟧) ((⟦Ren.weak⟧) (Ev.from (ρ, d))) := rfl
              _ = (⟦x.sub σ⟧) (ρ) := by rw [Ren.weak_den_eq]
              _ = Ev.from ((⟦σ⟧) ρ, d) τ x.s := rfl
        }
        calc ((((⟦e⟧) ∘' ⟦σ.keep _⟧) ∘' Ev.from).curry ρ) d
          _ = (⟦e⟧) ((⟦σ.keep _⟧) (Ev.from (ρ, d))) := rfl
          _ = (⟦e⟧) (Ev.from ((⟦σ⟧) ρ, d)) := by rw [p]
          _ = ((⟦e.fn⟧) ((⟦σ⟧) ρ)) d := rfl
      }
  | var | true | false | zero => intros; rfl
  | succ _ Φ | pred _ Φ | zero? _ Φ | fix _ Φ => intro _ σ; exact congrArg _ (Φ σ)
  | app _ _ Φf Φa =>
    intro _ σ; exact congrArg2 (fun f a ↦ Cont.eval ∘' Cont.pair f a) (Φf σ) (Φa σ)
  | cond s t f Φs Φt Φf =>
    intro _ σ
    calc ⟦(s.cond t f).sub σ⟧
      _ = _ ∘' Cont.pair (⟦s.sub σ⟧) (Cont.pair (⟦t.sub σ⟧) (⟦f.sub σ⟧))          := rfl
      _ = _ ∘' Cont.pair ((⟦s⟧) ∘' ⟦σ⟧) (Cont.pair ((⟦t⟧) ∘' ⟦σ⟧) ((⟦f⟧) ∘' ⟦σ⟧)) := by rw [Φs, Φt, Φf]
      _ = _ ∘' Cont.pair (⟦s⟧) ((Cont.pair (⟦t⟧) (⟦f⟧))) ∘' ⟦σ⟧
        := by rw [Cont.pair_after (⟦t⟧) (⟦f⟧) (⟦σ⟧), Cont.pair_after (⟦s⟧) _ (⟦σ⟧)]
      _ = (⟦s.cond t f⟧) ∘' ⟦σ⟧ := rfl


Chain

def Chain (α : Type i) [Order α] := Mono Nat α

Order

class Order (α) where
  R : α → α → Prop
  refl {x} : R x x
  trans {x y z} : R x y → R y z → R x z
  anti {x y} : R x y → R y x → x = y

Mono

structure Mono (α) (β) [Order α] [Order β] where
  act : α → β
  act' : is_monotone act

def is_monotone [Order α] [Order β] (f : α → β) := ∀ {x y : α}, x ⊑ y → f x ⊑ f y

infix:100 " ⊑ " => Order.R

infix:100 " ⇄! " => Order.anti

infixl:100 " • " => Mono.act'

notation:101 f " • " x:100 => Mono.act' (Cont.fn f) x

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Flat

theorem Flat.chain_some {c : Chain (Flat _)} {a b : α}
  (p : ∃ k, c.act k = .some a) (q : ∃ k, c.act k = .some b) : a = b

import «PCF».Domain

inductive Flat (α : Type) : Type where
  | none : Flat α
  | some : α → Flat α

open Classical

noncomputable def flat_sup (c : Chain (Flat α)) : Flat α :=
  if p : ∃ a n, c.act n = .some a then .some p.choose else .none

theorem Flat.sup_some {c : Chain _} {a : α} : (∃ k, c.act k = .some a) ↔ (flat_sup c = .some a) :=

:= by
  constructor
  case mp =>
    intro h;
    have p : ∃ a n, c.act n = .some a := ⟨a, h⟩
    rw [Flat.chain_some h p.choose_spec]
    exact dif_pos p
  case mpr =>
    intro h;
    if p : ∃ a n, c.act n = .some a
    then
      have q : flat_sup c = .some _ := dif_pos p
      rw [← h, q]
      exact p.choose_spec
    else
      have q : flat_sup c = .none := dif_neg p
      rw [q] at h
      exact Flat.noConfusion h


Var

inductive Var : Cx → Ty → Type
  | z : ∀ {Γ : Cx}, Var (Γ ∷ τ) τ
  | s : ∀ {Γ : Cx} {υ : Ty} τ, Var Γ τ → Var (Γ ∷ υ) τ

Cx

inductive Cx
  | nil
  | cons : Cx -> Ty -> Cx

Ty

inductive Ty
  | bool
  | nat
  | pow : Ty → Ty → Ty

Tm

inductive Tm : Cx → Ty → Type
  | var : ∀ τ, Γ ∋ τ → Tm Γ τ
  | true : Tm Γ .bool
  | false : Tm Γ .bool
  | zero : Tm Γ .nat
  | succ : Tm Γ .nat → Tm Γ .nat
  | pred : Tm Γ .nat → Tm Γ .nat
  | zero? : Tm Γ .nat → Tm Γ .bool
  | cond : Tm Γ .bool → Tm Γ τ → Tm Γ τ → Tm Γ τ
  | fn : Tm (Γ ∷ τ) υ → Tm Γ (τ ⇒ υ)
  | app : Tm Γ (τ ⇒ υ) → Tm Γ τ → Tm Γ υ
  | fix : Tm Γ (τ ⇒ τ) → Tm Γ τ

infixl:70 " ∷ "  => Cx.cons

infix:70 " ∋ " => Var

infix:70 " ⊢ " => Tm

theorem congrArg3
  {α₀ : Sort u₀} {α₁ : Sort u₁} {α₂ : Sort u₂} {β : Sort v} {a₀ a₀' : α₀} {a₁ a₁' : α₁} {a₂ a₂' : α₂}
  (f : α₀ → α₁ → α₂ → β) (h₀ : Eq a₀ a₀') (h₁ : Eq a₁ a₁') (h₂ : Eq a₂ a₂') : Eq (f a₀ a₁ a₂) (f a₀' a₁' a₂')

theorem congrArg2
  {α₀ : Sort u₀} {α₁ : Sort u₁} {β : Sort v} {a₀ a₀' : α₀} {a₁ a₁' : α₁}
  (f : α₀ → α₁ → β) (h₀ : Eq a₀ a₀') (h₁ : Eq a₁ a₁') : Eq (f a₀ a₁) (f a₀' a₁')

Ren

def Ren Γ Δ := ∀ τ, Γ ∋ τ → Δ ∋ τ

Tm.ren

theorem Ren.keep_comp {r₀₁ : Ren Γ₀ Γ₁} {r₁₂ : Ren Γ₁ Γ₂}
  : (r₀₁ ⬝ r₁₂) ∷ᵣ τ = (r₀₁ ∷ᵣ τ) ⬝ (r₁₂ ∷ᵣ τ)

import «PCF».Syntax

def Ren Γ Δ := ∀ τ, Γ ∋ τ → Δ ∋ τ

def Var.ren (v : Γ ∋ τ) (r : Ren Γ Δ) := r τ v

def Ren.keep (r : Ren Γ Δ) (τ  : Ty) : Ren (Γ ∷ τ) (Δ ∷ τ) :=
  fun υ v => match v with
  | .z     => .z
  | .s _ x => (x.ren r).succ

infixl:70 " ∷ᵣ "  => Ren.keep

infixl:70 " ++ᵣ "  => Ren.keeps

def Tm.ren (t : Γ ⊢ τ) (r : Ren Γ Δ) : Δ ⊢ τ :=
  match t with
  | .var τ x    => (x.ren r).tm
  | .true       => .true
  | .false      => .false
  | .zero       => .zero
  | .succ e     => (e.ren r).succ
  | .pred e     => (e.ren r).pred
  | .zero? e    => (e.ren r).zero?
  | .cond s t f => (s.ren r).cond (t.ren r) (f.ren r)
  | .fn e       => (e.ren (r ∷ᵣ _)).fn
  | .app f a    => (f.ren r).app (a.ren r)
  | .fix f      => (f.ren r).fix

theorem Ren.ren_comp_eq {t : Γ₀ ⊢ τ}
  : ∀ {Γ₁ Γ₂} {σ₀₁ : Ren Γ₀ Γ₁} {σ₁₂ : Ren Γ₁ Γ₂}, t.ren (σ₀₁ ⬝ σ₁₂) = (t.ren σ₀₁).ren σ₁₂ :=

:= by
  induction t with
  | @fn _ τ υ e Φ =>
    intro _ _ r₀₁ r₁₂
    calc (e.ren ((r₀₁ ⬝ r₁₂) ∷ᵣ τ)).fn
      _ = (e.ren ((r₀₁ ∷ᵣ τ) ⬝ (r₁₂ ∷ᵣ τ))).fn   := by rw [Ren.keep_comp]
      _ = ((e.ren (r₀₁ ∷ᵣ τ)).ren (r₁₂ ∷ᵣ τ)).fn := by rw [Φ]
  | var | true | false | zero => intros; rfl
  | succ _ Φ | pred _ Φ | zero? _ Φ | fix _ Φ => exact congrArg _ Φ
  | app _ _ Φf Φa       => exact congrArg2 _ Φf Φa
  | cond _ _ _ Φs Φt Φf => exact congrArg3 _ Φs Φt Φf


Order

class Order (α) where
  R : α → α → Prop
  refl {x} : R x x
  trans {x y z} : R x y → R y z → R x z
  anti {x y} : R x y → R y x → x = y

infix:100 " ⊑ " => Order.R

import «PCF».Domain

open Classical

inductive Flat (α : Type) : Type where
  | none : Flat α
  | some : α → Flat α

instance (a : Flat α) : Decidable (∃ k, a = .some k) :=
  match a with
  | .none => isFalse (fun p ↦ p.elim (fun _ y ↦ by injection y))
  | .some a => isTrue (.intro a rfl)

instance [DecidableEq α] : DecidableEq (Flat α) := fun a b ↦
  match a with
  | .none => match b with
    | .none => isTrue rfl
    | .some _ => isFalse Flat.noConfusion
  | .some a => match b with
    | .none => isFalse Flat.noConfusion
    | .some b => if p : a = b then isTrue (by rw [p]) else isFalse (fun q ↦ p (by injection q))

instance [DecidableEq α] : Order (Flat α) where
  R := fun x y ↦ (x ≠ .none) → x = y
  refl := fun _ ↦ rfl
  trans {x y z} p q :=
    if h : x = .none
    then fun a ↦ (a h).elim
    else fun a ↦ by rw [p h]; rw [p h] at h; rw [q h]
  anti {x y} p q :=
    if i : x = .none
    then if j : y = .none then by rw [i, j] else by rw [q j]
    else by rw [p i]

noncomputable def flat_sup (c : Chain (Flat α)) : Flat α :=
  if p : ∃ a n, c.act n = .some a then .some p.choose else .none

noncomputable instance : Domain (Flat α) where
  bot := .none
  sup := flat_sup
  is_bot := by admit /- proof elided -/
  is_bound := by admit /- proof elided -/
  is_least := by admit /- proof elided -/

theorem Flat.under_eq {x : Flat α} : x ⊑ .some a → x ⊑ .some b → a ≠ b → x = .none :=

:= by
  intro under_a under_b a_neq_b
  by_cases x = none
  case pos => assumption
  case neg h => exfalso; exact a_neq_b (by injection (under_a h).symm ⬝ (under_b h))


import PCF/Denotation.lean
import «PCF».Order
import PCF/Flat.lean
import PCF.Order

notation:max "⨆" => Domain.sup

Chain

def Chain (α : Type i) [Order α] := Mono Nat α

Mono

structure Mono (α) (β) [Order α] [Order β] where
  act : α → β
  act' : is_monotone act

def is_monotone [Order α] [Order β] (f : α → β) := ∀ {x y : α}, x ⊑ y → f x ⊑ f y

(Γ

noncomputable instance (Γ : Cx) : Domain (⟦Γ cx⟧) where
  bot := fun _ _ ↦ ⊥
  sup := fun c _ x ↦ ⨆ ⟨fun n ↦ c.act n _ x, fun i_j ↦ c.act' i_j _ x⟩
  is_bot := fun _ _ ↦ Domain.is_bot
  is_bound := fun c {n} {_} x ↦ Domain.is_bound ⟨fun n ↦ c.act n _ x, fun i_j ↦ c.act' i_j _ x⟩ n
  is_least := fun c _ p {_} x ↦ Domain.is_least ⟨fun n ↦ c.act n _ x, fun i_j ↦ c.act' i_j _ x⟩
    (fun {_} ↦ p _ x)

[Order

instance [Order α] [Order β] [Domain α] [Domain β] : Domain (Cont α β) where
  bot := ⟨⟨fun _ ↦ ⊥, fun _ ↦ Domain.is_bot⟩, Domain.is_bot⟩
  sup := fun c ↦ ⟨Mono.sup_cont c, by admit /- proof elided -/
  ⟩
  is_bot := fun _ ↦ Domain.is_bot
  is_bound := by admit /- proof elided -/

noncomputable def flat_sup (c : Chain (Flat α)) : Flat α :=
  if p : ∃ a n, c.act n = .some a then .some p.choose else .none

Flat

inductive Flat (α : Type) : Type where
  | none : Flat α
  | some : α → Flat α

infix:100 " ⊑ " => Order.R

notation:max "⋆" => Order.refl

infix:100 " ⇄! " => Order.anti

infixl:100 " • " => Mono.act'

Mono.ext

@[ext] theorem Mono.ext [Order α] [Order β] {f g : Mono α β} (p : f.act = g.act) : f = g

Cont.ext

@[ext] theorem Cont.ext [Order α] [Order β] [Domain α] [Domain β]
  {f g : Cont α β} (p : f.fn.act = g.fn.act) : f = g

import «PCF».Order

class Domain (α) [Order α] where
  bot : α
  sup : (c : Chain α) → α
  is_bot {x} : bot ⊑ x
  is_bound (c) (n): c.act n ⊑ sup c
  is_least (c) {d} : ({n : _} → c.act n ⊑ d) → sup c ⊑ d

notation:max "⊥" => Domain.bot

notation:max "⨆" => Domain.sup

structure DomainType : Type (i + 1) :=
  carrier : Type i
  order : Order carrier
  domain : Domain carrier

instance (τ : DomainType) : Order (τ) := τ.order

instance (τ : DomainType) : Domain (τ) := τ.domain

structure Cont (α) (β) [Order α] [Order β] [Domain α] [Domain β] where
  fn : Mono α β
  sub : ∀ {c : Chain α}, fn.act (⨆ c) ⊑ ⨆ (fn ∘ c)

notation:101 f " • " x:100 => Mono.act' (Cont.fn f) x

def Cont.comp' [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ] (f : Cont β γ) (g : Cont α β)
  : Cont α γ
  := ⟨
    ⟨fun x ↦ f (g x), fun x_y ↦ f • g • x_y⟩,
    by admit /- proof elided -/
  ⟩

infix:100 " ∘ " => Cont.comp'

infixr:100 " ∘' " => Cont.comp'

def Cont.pair [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ]
  (f : Cont γ α) (g : Cont γ β) : Cont γ (α × β) := ⟨
    ⟨fun c ↦ ⟨f c, g c⟩, fun p ↦ ⟨f • p, g • p⟩⟩,
    ⟨f.sub ⬝ Domain.sup_is_mono (fun _ ↦ ⋆), g.sub ⬝ Domain.sup_is_mono (fun _ ↦ ⋆)⟩
  ⟩

theorem Cont.pair_after [Order α] [Domain α] [Order β] [Domain β] [Order γ] [Domain γ] [Order δ] [Domain δ]
  (f : Cont γ α) (g : Cont γ β) (h : Cont δ γ) : (f ∘' h).pair (g ∘' h) = (f.pair g) ∘' h :=

:= by
  apply Cont.ext ∘ funext
  intro x
  rfl


Order

class Order (α) where
  R : α → α → Prop
  refl {x} : R x x
  trans {x y z} : R x y → R y z → R x z
  anti {x y} : R x y → R y x → x = y

infix:100 " ⊑ " => Order.R

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Flat.invert

theorem Flat.invert {x : Flat α} (p : x ≠ .none) : ∃ k, x = .some k

theorem Flat.leq_none {a : Flat α} : a ⊑ .none → a = .none :=

:= by
  intro a_bf_n
  by_cases a = none
  case pos => assumption
  case neg h =>
    have ⟨n, a_eq_sn⟩ := Flat.invert h
    exact a_bf_n (by intro a_eq_n; injection a_eq_n.symm ⬝ a_eq_sn)