-- Veil/DSL/Action/Theory.lean

import Veil.DSL.Base

namespace Veil

section Veil

open Classical

section Types

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

variable (m : Mode) (σ ρ : Type)

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

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

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

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

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

end Types

section Theory

variable {σ ρ : Type}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

section TwoStateSoundness

end TwoStateSoundness

section BigStepSoundness

end BigStepSoundness

section LawfulActionInstances

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end LawfulActionInstances

section GenBigStepInstances

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

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

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

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

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

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

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

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

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

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

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

-- Repository definitions used:
content: syntax (name:= assumption) "assumptionDef" : attr

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

-- Local definitions used:
content: inductive Mode where
  | internal : Mode
  | external : Mode
deriving BEq

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- Local lemmas used:
content: theorem big_step_sound' [LawfulAction act] (req : SProp σ) (ens : RProp σ ρ) :
  act.triple req ens → act.toBigStep.triple req ens

-- Target theorem and proof:
theorem bind_terminates m (act : Wp m σ ρ) (act' : ρ -> Wp m σ ρ') s [LawfulAction act] :
  pre s ->
  act.alwaysSuccessfullyTerminates pre →
  (act.bind act').alwaysSuccessfullyTerminates pre ->
  act.toBigStep s r' s' ->
  (act' r').alwaysSuccessfullyTerminates (· = s')
:= by
    unfold Wp.alwaysSuccessfullyTerminates Wp.toBigStep Wp.toWlp Wp.bind
    intros hpre actT act'T
    have actT := actT s hpre
    have act'T := act'T s hpre
    have act''T := big_step_sound' (act := act) (req := (· = s))
    unfold Wp.triple BigStep.triple Wp.toBigStep Wp.toWlp at act''T
    simp at act''T; specialize act''T _ act'T s r' s' rfl
    simp_all