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

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

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

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

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

end Types

section Theory

variable {σ ρ : Type}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

section TwoStateSoundness

end TwoStateSoundness

section BigStepSoundness

end BigStepSoundness

section LawfulActionInstances

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end LawfulActionInstances

section GenBigStepInstances

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

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

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

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

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

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

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

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

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

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

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

-- 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: @[inline] abbrev TwoState := σ -> σ -> Prop

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.lift [IsSubStateOf σ σ'] (act : BigStep σ ρ) : BigStep σ' ρ :=
  fun st r' st' => act (getFrom st) r' (getFrom st') ∧ st' = (setIn (@getFrom σ σ' _ st') st)

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

content: @[actSimp]
def _root_.Function.toWp (m : Mode) (r : TwoState σ) : Wp m σ Unit :=
  fun s post => ∀ s', r s s' -> post () 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: 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 lift_transition_big_step {σ σ'} [IsSubStateOf σ σ'] (m : Mode) (tr : BigStep σ ρ) :
  (@Wp.lift _  m σ σ' _ tr.toWp).toBigStep =
  fun st r' st' =>
    tr (getFrom st) r' (getFrom st') ∧
    st' = (setIn (@getFrom σ σ' _ st') st)

content: theorem big_step_sound [LawfulAction act] (req : SProp σ) (ens : RProp σ ρ) :
  (¬ ∀ r s, ens r s) ->
  act.toBigStep.triple req ens -> act.triple req ens

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

content: theorem big_step_always_terminating_sound [LawfulAction act] (req : SProp σ) (ens : RProp σ ρ) :
  act.alwaysSuccessfullyTerminates req ->
  act.toBigStep.triple req ens -> act.triple req ens

content: theorem big_step_to_wp (act : Wp m σ ρ) [LawfulAction act] (req : SProp σ) :
  act.alwaysSuccessfullyTerminates req ->
  req s ->
  act s = act.toBigStep.toWp s

-- Target theorem and proof:
theorem lift_transition_big_step' {σ σ'} [IsSubStateOf σ σ'] (m : Mode) (r : Wp m σ ρ) [LawfulAction r] (st : σ') :
  r.alwaysSuccessfullyTerminates (· = getFrom st) →
  (@Wp.lift _  m σ σ' _ r).toBigStep st =
  fun r' st' =>
    r.toBigStep (getFrom st) r' (getFrom st') ∧
    st' = (setIn (@getFrom σ σ' _ st') st)
:= by
  intro term
  have rEq : r.lift.toBigStep st = (r.toBigStep.toWp.lift.toBigStep st) := by {
    unfold Wp.lift Wp.toBigStep Wp.toWlp; ext; simp
    rw [big_step_to_wp (act := r) (req := (fun x => x = getFrom st))] <;> try simp [*]
    unfold Wp.toBigStep Wp.toWlp; simp }
  rw [rEq, lift_transition_big_step]