uniformFin

notation "$[0.." n "]" => uniformFin n

notation:50 "$[" n "⋯" m "]" => uniformFin' n m

example : OracleComp probSpec ℕ := do
  let x ← $[314⋯31415]; let y ← $[0⋯x]
  return x + 2 * y

@[reducible, inline] def uniformFin (n : ℕ) : ProbComp (Fin (n + 1)) :=
  unifSpec.query n ()

ProbComp

abbrev ProbComp : Type z → Type (max z 1) := OracleComp unifSpec

OracleComp

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

OracleQuery

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

unifSpec

@[inline, reducible] def unifSpec : OracleSpec.{0,0} ℕ :=
  λ n ↦ (Unit, Fin (n + 1))

uniformFin'

@[reducible, inline] def uniformFin' (n m : ℕ) : OracleComp probSpec (Fin (m + 1)) :=
  probSpec.query m n

probSpec

def probSpec : OracleSpec.{0,0} ℕ :=
  fun n => (ℕ, Fin (n + 1))

HasEvalDist

class HasEvalDist (m : Type u → Type v) [Monad m] where
  evalDist {α : Type u} (mx : m α) : SPMF α
  evalDist_pure {α : Type u} (x : α) : evalDist (pure x : m α) = pure x
  evalDist_bind {α β : Type u} (mx : m α) (my : α → m β) :
    evalDist (mx >>= my) = evalDist mx >>= fun x => evalDist (my x)

DecidableEq

protected class DecidableEq (spec : OracleSpec ι) where
  domain_decidableEq' (i : ι) : DecidableEq (spec.domain i)
  range_decidableEq' (i : ι) : DecidableEq (spec.range i)

cases

def cases {α} {motive : {n : ℕ} → Vector α n → Sort*} (v_empty : motive #v[])
  (v_insert : {n : ℕ} → (hd : α) → (tl : Vector α n) → motive (tl.insertIdx 0 hd)) {m : ℕ} :
    (v : Vector α m) → motive v := match hm : m with
  | 0 => fun v => match v with | ⟨⟨[]⟩, rfl⟩ => v_empty
  | n + 1 => fun v => match hv : v with
    | ⟨⟨hd :: tl⟩, hSize⟩ => by admit /- proof elided -/

support

def support (oa : OracleComp spec α) : Set α :=
  oa.supportWhen fun _ => Set.univ

supportWhen

def supportWhen (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Set α) : Set α :=

induction

@[elab_as_elim]
protected def induction {C : OracleComp spec α → Prop}
    (oa : OracleComp spec α) (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

inductionOn

@[elab_as_elim]
protected def inductionOn {C : FreeMonad f α → Prop}
    (pure : ∀ x, C (pure x))
    (roll : ∀ {β} (x : f β), (r : β → FreeMonad f α) →
      (∀ y, C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | FreeMonad.pure x => pure x
  | FreeMonad.roll x r => roll x _ (λ u ↦
      FreeMonad.inductionOn pure roll (r u))

construct

@[elab_as_elim]
protected def construct {C : OracleComp spec α → Type*}
    (pure : (a : α) → C (pure a))
    (query_bind : {β : Type v} → (q : OracleQuery spec β) →
      (oa : β → OracleComp spec α) → ((u : β) → C (oa u)) → C (q >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.construct (Option.rec failure pure) query_bind oa

@[elab_as_elim]
protected def construct {C : FreeMonad f α → Type*}
    (pure : (x : α) → C (pure x))
    (roll : {β : Type u} → (x : f β) → (r : β → FreeMonad f α) →
      ((y : β) → C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | .pure x => pure x
  | .roll x r => roll x _ (λ u ↦ FreeMonad.construct pure roll (r u))

finSupport

def finSupport [∀ i, Fintype (spec.range i)] [DecidableEq α] (oa : OracleComp spec α) : Finset α :=
  oa.finSupportWhen fun | query _ _ => Finset.univ

finSupportWhen

def finSupportWhen [DecidableEq α] (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Finset α) : Finset α :=

coin

@[reducible, inline] def coin : OracleComp coinSpec Bool :=
  coinSpec.query () ()

coinSpec

@[inline, reducible] def coinSpec : OracleSpec.{0,0} Unit := Unit →ₒ Bool

FiniteRange

class FiniteRange (spec : OracleSpec ι) where
    range_inhabited' (i : ι) : Inhabited (spec.range i)
    range_fintype' (i : ι) : Fintype (spec.range i)

uniformFin

notation "$[0.." n "]" => uniformFin n

lemma tsum_option {α β : Type*} [AddCommMonoid α] [TopologicalSpace α]
    [ContinuousAdd α] [T2Space α]
    (f : Option β → α) (hf : Summable (Function.update f none 0)) :
    ∑' x : Option β, f x = f none + ∑' x : β, f (some x)

@[simp] lemma finSupport_uniformFin (n : ℕ) : ($[0..n]).finSupport = Finset.univ

lemma finSupport_query [spec.FiniteRange] [DecidableEq α] (q : OracleQuery spec α) :
    (q : OracleComp spec _).finSupport = match q with

@[simp] lemma finSupportWhen_query [DecidableEq α] (q : OracleQuery spec α) :
    (q : OracleComp spec α).finSupportWhen fin_poss = fin_poss q

lemma finSupport_def [∀ i, Fintype (spec.range i)] [DecidableEq α] (oa : OracleComp spec α) :
    oa.finSupport = oa.finSupportWhen fun

OracleComp.probFailure

lemma probOutput_def (oa : OracleComp spec α) (x : α) :
    [= x | oa] = (evalDist oa).run (some x)

lemma probEvent_def (oa : OracleComp spec α) (p : α → Prop) :
    [p | oa] = (evalDist oa).run.toOuterMeasure (Option.some '' {x | p x})

lemma probEvent_eq_tsum_ite (oa : OracleComp spec α) (p : α → Prop) [DecidablePred p] :
    [p | oa] = ∑' x : α, if p x then [= x | oa] else 0

lemma probEvent_eq_sum_filter_finSupport [spec.DecidableEq] [DecidablePred p] [DecidableEq α] :
    [p | oa] = ∑ x ∈ oa.finSupport.filter p, [= x | oa]

@[simp]
lemma probOutput_liftM [Fintype α] (q : OracleQuery spec α) (u : α) :
    [= u | (q : OracleComp spec α)] = (Fintype.card α : ℝ≥0∞)⁻¹

lemma probOutput_query (u : spec.range i) :
    [= u | (query i t : OracleComp spec _)] = (Fintype.card (spec.range i) : ℝ≥0∞)⁻¹

@[simp]
lemma probOutput_uniformFin (x : Fin (n + 1)) : [= x | $[0..n]] = ((n : ℝ≥0∞) + 1)⁻¹

import VCVio.OracleComp.Traversal

import VCVio.OracleComp.SimSemantics.SimulateQ

import Mathlib.Probability.Distributions.Uniform

import ToMathlib.General

open OracleSpec Option ENNReal BigOperators

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {ι' : Type v} {spec' : OracleSpec ι'}
  {α β γ : Type w} [spec.FiniteRange] [spec'.FiniteRange]

section evalDist

end evalDist

noncomputable def probOutput (oa : OracleComp spec α) (x : α) : ℝ≥0∞ :=
  (evalDist oa).run (some x)

notation "[=" x "|" oa "]" => probOutput oa x

noncomputable def probFailure (oa : OracleComp spec α) : ℝ≥0∞ :=
  (evalDist oa).run none

notation "[⊥" "|" oa "]" => probFailure oa

notation "[" p "|" oa "]" => probEvent oa p

section bounds

variable {oa : OracleComp spec α} {x : α} {p : α → Prop}

end bounds

section support

variable (oa : OracleComp spec α) (x : α) (p q : α → Prop)

variable {oa x p q}

end support

section sums

variable (oa : OracleComp spec α) (p : α → Prop)

end sums

section pure

variable (x : α)

end pure

section bind

variable (oa : OracleComp spec α) (ob : α → OracleComp spec β)

end bind

section mul_le_probEvent_bind

end mul_le_probEvent_bind

section bind_const

variable (oa : OracleComp spec α) (ob : OracleComp spec β)

end bind_const

section query

variable (i : ι) (t : spec.domain i)

end query

section failure

end failure

section map

variable (oa : OracleComp spec α) (f : α → β)

end map

section neverFails

end neverFails

section unit

end unit

section bool

end bool

section eqRec

variable (oa : OracleComp spec α) (h : α = β)

end eqRec

section ite

variable (p : Prop) [Decidable p] (oa oa' : OracleComp spec α)

end ite

section coin

end coin

section uniformFin

variable (n : ℕ)

@[simp]
lemma probEvent_uniformFin (p : Fin (n + 1) → Prop) [DecidablePred p] :
    [p | $[0..n]] = (Finset.univ.filter p).card * (n + 1 : ℝ≥0∞)⁻¹ :=

:= by
  simp only [probEvent_eq_sum_filter_finSupport, finSupport_uniformFin, probOutput_uniformFin,
    Finset.sum_const, nsmul_eq_mul]


HasEvalDist

class HasEvalDist (m : Type u → Type v) [Monad m] where
  evalDist {α : Type u} (mx : m α) : SPMF α
  evalDist_pure {α : Type u} (x : α) : evalDist (pure x : m α) = pure x
  evalDist_bind {α β : Type u} (mx : m α) (my : α → m β) :
    evalDist (mx >>= my) = evalDist mx >>= fun x => evalDist (my x)

OracleComp

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

OracleQuery

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

cases

def cases {α} {motive : {n : ℕ} → Vector α n → Sort*} (v_empty : motive #v[])
  (v_insert : {n : ℕ} → (hd : α) → (tl : Vector α n) → motive (tl.insertIdx 0 hd)) {m : ℕ} :
    (v : Vector α m) → motive v := match hm : m with
  | 0 => fun v => match v with | ⟨⟨[]⟩, rfl⟩ => v_empty
  | n + 1 => fun v => match hv : v with
    | ⟨⟨hd :: tl⟩, hSize⟩ => by admit /- proof elided -/

lemma tsum_option {α β : Type*} [AddCommMonoid α] [TopologicalSpace α]
    [ContinuousAdd α] [T2Space α]
    (f : Option β → α) (hf : Summable (Function.update f none 0)) :
    ∑' x : Option β, f x = f none + ∑' x : β, f (some x)

OracleComp.probFailure

lemma probOutput_def (oa : OracleComp spec α) (x : α) :
    [= x | oa] = (evalDist oa).run (some x)

@[simp]
lemma probFailure_add_tsum_probOutput (oa : OracleComp spec α) :
    [⊥ | oa] + ∑' x, [= x | oa] = 1

@[simp]
lemma tsum_probOutput_add_probFailure (oa : OracleComp spec α) :
    ∑' x, [= x | oa] + [⊥ | oa] = 1

@[simp] lemma probFailure_le_one : [⊥ | oa] ≤ 1

@[simp] lemma probFailure_ne_top : [⊥ | oa] ≠ ∞

lemma tsum_probOutput_eq_sub (oa : OracleComp spec α) :
    ∑' x : α, [= x | oa] = 1 - [⊥ | oa]

lemma probFailure_bind_eq_tsum :
    [⊥ | oa >>= ob] = [⊥ | oa] + ∑' x : α, [= x | oa] * [⊥ | ob x]

import VCVio.OracleComp.Traversal

import VCVio.OracleComp.SimSemantics.SimulateQ

import Mathlib.Probability.Distributions.Uniform

import ToMathlib.General

open OracleSpec Option ENNReal BigOperators

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {ι' : Type v} {spec' : OracleSpec ι'}
  {α β γ : Type w} [spec.FiniteRange] [spec'.FiniteRange]

section evalDist

end evalDist

noncomputable def probOutput (oa : OracleComp spec α) (x : α) : ℝ≥0∞ :=
  (evalDist oa).run (some x)

notation "[=" x "|" oa "]" => probOutput oa x

noncomputable def probFailure (oa : OracleComp spec α) : ℝ≥0∞ :=
  (evalDist oa).run none

notation "[⊥" "|" oa "]" => probFailure oa

notation "[" p "|" oa "]" => probEvent oa p

section bounds

variable {oa : OracleComp spec α} {x : α} {p : α → Prop}

end bounds

section support

variable (oa : OracleComp spec α) (x : α) (p q : α → Prop)

variable {oa x p q}

end support

section sums

variable (oa : OracleComp spec α) (p : α → Prop)

end sums

section pure

variable (x : α)

end pure

section bind

variable (oa : OracleComp spec α) (ob : α → OracleComp spec β)

lemma probFailure_bind_of_const [Nonempty α] (r : ℝ≥0∞) (h : ∀ x, [⊥ | ob x] = r) :
    [⊥ | oa >>= ob] = [⊥ | oa] + r - [⊥ | oa] * r :=

:= by
  have : r ≠ ⊤ := λ hr ↦ probFailure_ne_top ((h (Classical.arbitrary α)).trans hr)
  simp [probFailure_bind_eq_tsum, h, ENNReal.tsum_mul_right, tsum_probOutput_eq_sub]
  rw [ENNReal.sub_mul λ _ _ ↦ this, one_mul]
  refine symm (AddLECancellable.add_tsub_assoc_of_le ?_ ?_ _)
  · refine ENNReal.addLECancellable_iff_ne.2 (ENNReal.mul_ne_top probFailure_ne_top this)
  · by_cases hr : r = 0
    · simp only [hr, mul_zero, le_refl]
    refine mul_le_of_le_div (le_of_le_of_eq probFailure_le_one ?_)
    refine symm (ENNReal.div_self hr this)


probOutput

notation "[=" x "|" oa "]" => probOutput oa x

HasEvalDist

class HasEvalDist (m : Type u → Type v) [Monad m] where
  evalDist {α : Type u} (mx : m α) : SPMF α
  evalDist_pure {α : Type u} (x : α) : evalDist (pure x : m α) = pure x
  evalDist_bind {α β : Type u} (mx : m α) (my : α → m β) :
    evalDist (mx >>= my) = evalDist mx >>= fun x => evalDist (my x)

FiniteRange

class FiniteRange (spec : OracleSpec ι) where
    range_inhabited' (i : ι) : Inhabited (spec.range i)
    range_fintype' (i : ι) : Fintype (spec.range i)

OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

support

def support (oa : OracleComp spec α) : Set α :=
  oa.supportWhen fun _ => Set.univ

supportWhen

def supportWhen (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Set α) : Set α :=

induction

@[elab_as_elim]
protected def induction {C : OracleComp spec α → Prop}
    (oa : OracleComp spec α) (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

OracleQuery

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

OracleComp

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

inductionOn

@[elab_as_elim]
protected def inductionOn {C : FreeMonad f α → Prop}
    (pure : ∀ x, C (pure x))
    (roll : ∀ {β} (x : f β), (r : β → FreeMonad f α) →
      (∀ y, C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | FreeMonad.pure x => pure x
  | FreeMonad.roll x r => roll x _ (λ u ↦
      FreeMonad.inductionOn pure roll (r u))

construct

@[elab_as_elim]
protected def construct {C : OracleComp spec α → Type*}
    (pure : (a : α) → C (pure a))
    (query_bind : {β : Type v} → (q : OracleQuery spec β) →
      (oa : β → OracleComp spec α) → ((u : β) → C (oa u)) → C (q >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.construct (Option.rec failure pure) query_bind oa

@[elab_as_elim]
protected def construct {C : FreeMonad f α → Type*}
    (pure : (x : α) → C (pure x))
    (roll : {β : Type u} → (x : f β) → (r : β → FreeMonad f α) →
      ((y : β) → C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | .pure x => pure x
  | .roll x r => roll x _ (λ u ↦ FreeMonad.construct pure roll (r u))

probOutput

noncomputable def probOutput (oa : OracleComp spec α) (x : α) : ℝ≥0∞ :=
  (evalDist oa).run (some x)

inductionOn

@[elab_as_elim]
protected def inductionOn {C : OracleComp spec α → Prop}
    (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

probEvent

noncomputable def probEvent (oa : OracleComp spec α) (p : α → Prop) : ℝ≥0∞ :=
  (evalDist oa).run.toOuterMeasure (Option.some '' {x | p x})

cases

def cases {α} {motive : {n : ℕ} → Vector α n → Sort*} (v_empty : motive #v[])
  (v_insert : {n : ℕ} → (hd : α) → (tl : Vector α n) → motive (tl.insertIdx 0 hd)) {m : ℕ} :
    (v : Vector α m) → motive v := match hm : m with
  | 0 => fun v => match v with | ⟨⟨[]⟩, rfl⟩ => v_empty
  | n + 1 => fun v => match hv : v with
    | ⟨⟨hd :: tl⟩, hSize⟩ => by admit /- proof elided -/

probOutput

notation "Pr[=" x "|" mx "]" => probOutput mx x

probEvent

notation "Pr[" p "|" mx "]" => probEvent mx p

probEvent

notation "[" p "|" oa "]" => probEvent oa p

@[simp] lemma support_map (oa : OracleComp spec α) (f : α → β) :
    (f <$> oa).support = f '' oa.support

@[simp] lemma support_bind (oa : OracleComp spec α) (ob : α → OracleComp spec β) :
    (oa >>= ob).support = ⋃ x ∈ oa.support, (ob x).support

@[simp] lemma support_pure (x : α) :
    (pure x : OracleComp spec α).support = {x}

lemma probEvent_congr' {p q : α → Prop} {oa : OracleComp spec α} {oa' : OracleComp spec' α}
    (h1 : ∀ x, x ∈ oa.support → x ∈ oa'.support → (p x ↔ q x))
    (h2 : evalDist oa = evalDist oa') : [p | oa] = [q | oa']

lemma mem_support_iff_of_evalDist_eq {oa : OracleComp spec α} {oa' : OracleComp spec' α}
    (h : evalDist oa = evalDist oa') (x : α) : x ∈ oa.support ↔ x ∈ oa'.support

lemma mem_support_iff_probOutput_ne_zero : x ∈ oa.support ↔ [= x | oa] ≠ 0

@[simp low]
lemma probOutput_eq_zero_iff : [= x | oa] = 0 ↔ x ∉ oa.support

@[simp]
lemma mem_support_evalDist_iff (oa : OracleComp spec α) (x : α) :
    some x ∈ (evalDist oa).run.support ↔ x ∈ oa.support

lemma probOutput_def (oa : OracleComp spec α) (x : α) :
    [= x | oa] = (evalDist oa).run (some x)

lemma probEvent_eq_tsum_indicator (oa : OracleComp spec α) (p : α → Prop) :
    [p | oa] = ∑' x : α, {x | p x}.indicator ([= · | oa]) x

lemma probEvent_def (oa : OracleComp spec α) (p : α → Prop) :
    [p | oa] = (evalDist oa).run.toOuterMeasure (Option.some '' {x | p x})

lemma probOutput_congr {x y : α} {oa : OracleComp spec α} {oa' : OracleComp spec' α}
    (h1 : x = y) (h2 : evalDist oa = evalDist oa') : [= x | oa] = [= y | oa']

lemma probEvent_comp (q : β → Prop) : [q ∘ f | oa] = [q | f <$> oa]

@[simp]
lemma probEvent_map (q : β → Prop) : [q | f <$> oa] = [q ∘ f | oa]

@[simp]
lemma evalDist_map (oa : OracleComp spec α) (f : α → β) :
    evalDist (f <$> oa) = f <$> (evalDist oa)

@[simp low]
lemma support_seq : (og <*> oa).support = ⋃ g ∈ og.support, g '' oa.support

@[simp low + 1]
lemma support_seq_map_eq_image2 :
    (f <$> oa <*> ob).support = Set.image2 f oa.support ob.support

import VCVio.OracleComp.DistSemantics.Monad

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {α β γ : Type v}

variable (oa : OracleComp spec α) (og : OracleComp spec (α → β))

section seq_map

variable (oa : OracleComp spec α) (ob : OracleComp spec β) (f : α → β → γ)

lemma probEvent_seq_map_eq_probEvent_comp_uncurry [spec.FiniteRange]
    (p : γ → Prop) : [p | f <$> oa <*> ob] =
      [p ∘ f.uncurry | Prod.mk <$> oa <*> ob] :=

:= by
  rw [probEvent_comp]
  refine probEvent_congr' ?_ (congr_arg evalDist ?_)
  · simp only [support_seq_map_eq_image2, Set.mem_image2, support_map, Set.image2_mk_eq_prod,
      Set.image_uncurry_prod, implies_true]
  · simp only [map_seq, Function.comp, Functor.map_map, Function.uncurry_apply_pair]
    rfl


domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

lift

@[always_inline, inline]
def lift (x : f α) : FreeMonad f α := FreeMonad.roll x FreeMonad.pure

bind

@[always_inline, inline]
protected def bind : FreeMonad f α → (α → FreeMonad f β) → FreeMonad f β
  | FreeMonad.pure x, g => g x
  | FreeMonad.roll x r, g => FreeMonad.roll x (λ u ↦ FreeMonad.bind (r u) g)

notation:50 m₁ " >>=ₕ " m₂ => bind m₁ m₂

@[simp]
lemma monad_bind_def (x : FreeMonad f α) (g : α → FreeMonad f β) :
    x >>= g = FreeMonad.bind x g

@[simp]
lemma bind_lift (x : f α) (r : α → FreeMonad f β) :
    FreeMonad.bind (FreeMonad.lift x) r = FreeMonad.roll x r

@[simp]
lemma monad_pure_def (x : α) : (pure x : FreeMonad f α) = FreeMonad.pure x

OracleComp

protected lemma liftM_def (q : OracleQuery spec α) :
    (q : OracleComp spec α) = OptionT.lift (FreeMonad.lift q)

import ToMathlib.Control.Monad.Free

import ToMathlib.Control.WriterT

import ToMathlib.Control.AlternativeMonad

import ToMathlib.Control.OptionT

import Mathlib.Control.Lawful

import VCVio.OracleComp.OracleSpec

namespace OracleSpec

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

namespace OracleQuery

variable {ι : Type u} {spec : OracleSpec ι} {α β : Type v}

end OracleQuery

end OracleSpec

open OracleSpec

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {α β : Type v}

section lift

end lift

notation "$[0.." n "]" => uniformFin n

notation:50 "$[" n "⋯" m "]" => uniformFin' n m

example : OracleComp probSpec ℕ := do
  let x ← $[314⋯31415]; let y ← $[0⋯x]
  return x + 2 * y

section construct

variable {C : OracleComp spec α → Type w}
  (h_pure : (a : α) → C (pure a))
  (h_query_bind : {β : Type v} → (q : OracleQuery spec β) →
      (oa : β → OracleComp spec α) → ((u : β) → C (oa u)) → C (q >>= oa))
  (h_failure : C failure) (oa : OracleComp spec α)

end construct

section noConfusion

variable (x : α) (y : β) (q : OracleQuery spec β) (oa : β → OracleComp spec α)

end noConfusion

section mapM

variable {m : Type v → Type w} [Monad m]
  (fail : {α : Type v} → m α) (qm : {α : Type v} → OracleQuery spec α → m α)

end mapM

section inj

@[simp]
lemma liftM_inj (q q' : OracleQuery spec α) : (q : OracleComp spec α) = q' ↔ q = q' :=

:= by
  simp only [OracleComp.liftM_def, OptionT.lift, OptionT.mk, FreeMonad.monad_pure_def,
    FreeMonad.monad_bind_def, FreeMonad.bind_lift]
  rw [FreeMonad.roll.injEq]
  simp only [heq_eq_eq, and_true, true_and]


Lens

structure Lens (P : PFunctor.{uA₁, uB₁}) (Q : PFunctor.{uA₂, uB₂}) where
  toFunA : P.A → Q.A
  toFunB : ∀ a, Q.B (toFunA a) → P.B a

Chart

structure Chart (P : PFunctor.{uA₁, uB₁}) (Q : PFunctor.{uA₂, uB₂}) where
  toFunA : P.A → Q.A
  toFunB : ∀ a, P.B a → Q.B (toFunA a)

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

PFunctor.Lens.ext

@[ext (iff := false)]
theorem ext {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₂}} (l₁ l₂ : Lens P Q)
    (h₁ : ∀ a, l₁.toFunA a = l₂.toFunA a) (h₂ : ∀ a, l₁.toFunB a = (h₁ a) ▸ l₂.toFunB a) :
    l₁ = l₂

import ToMathlib.PFunctor.Basic

section find_home

variable {α : Sort u} {β : α → Sort v} {γ : α → Sort v}

end find_home

namespace PFunctor

namespace Lens

@[inherit_doc] infixl:75 " ∘ₗ " => comp

@[inherit_doc] infix:50 " ≃ₗ " => Equiv

namespace Equiv

end Equiv

def prodPair {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₂}} {R : PFunctor.{uA₃, uB₃}}
    (l₁ : Lens P Q) (l₂ : Lens P R) :
    Lens.{uA₁, uB₁, max uA₂ uA₃, max uB₂ uB₃} P (Q * R) :=
  (fun p => (l₁.toFunA p, l₂.toFunA p)) ⇆
    (fun p => Sum.elim (l₁.toFunB p) (l₂.toFunB p))

@[inherit_doc] infixl:75 " ◃ₗ " => compMap

@[inherit_doc] infixl:75 " ×ₗ " => prodMap

@[inherit_doc] infixl:75 " ⊎ₗ " => sumMap

@[inherit_doc] infixl:75 " ⊗ₗ " => tensorMap

notation "[" l₁ "," l₂ "]ₗ" => sumPair l₁ l₂

notation "⟨" l₁ "," l₂ "⟩ₗ" => prodPair l₁ l₂

section Coprod

variable {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₁}}
  {R : PFunctor.{uA₃, uB₃}} {W : PFunctor.{uA₄, uB₃}} {X : PFunctor.{uA₅, uB₅}}

namespace Equiv

variable {P : PFunctor.{uA₁, uB}} {Q : PFunctor.{uA₂, uB}} {R : PFunctor.{uA₃, uB}}

end Equiv

end Coprod

section Prod

variable {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₂}} {R : PFunctor.{uA₃, uB₃}}
  {W : PFunctor.{uA₄, uB₄}} {X : PFunctor.{uA₅, uB₅}}

@[simp]
theorem prodPair_fst_snd :
    Lens.prodPair Lens.fst Lens.snd = Lens.id.{max uA₁ uA₂, max uB₁ uB₂} (P * Q) :=

:= by
  ext a x
  · rfl
  · cases x <;> rfl


OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

DecidableEq

protected class DecidableEq (spec : OracleSpec ι) where
  domain_decidableEq' (i : ι) : DecidableEq (spec.domain i)
  range_decidableEq' (i : ι) : DecidableEq (spec.range i)

domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

induction

@[elab_as_elim]
protected def induction {C : OracleComp spec α → Prop}
    (oa : OracleComp spec α) (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

inductionOn

@[elab_as_elim]
protected def inductionOn {C : FreeMonad f α → Prop}
    (pure : ∀ x, C (pure x))
    (roll : ∀ {β} (x : f β), (r : β → FreeMonad f α) →
      (∀ y, C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | FreeMonad.pure x => pure x
  | FreeMonad.roll x r => roll x _ (λ u ↦
      FreeMonad.inductionOn pure roll (r u))

/-- Add a list of values to the query seed.-/
def addValues [DecidableEq ι] {i : ι}
    (us : List (spec.range i)) (seed : QuerySeed spec) : QuerySeed spec :=
  Function.update seed i (seed i ++ us)

/-- Take only the first `n` values of the seed at index `i`. -/
def takeAtIndex [DecidableEq ι] (seed : QuerySeed spec) (i : ι) (n : ℕ) : QuerySeed spec :=
  Function.update seed i ((seed i).take n)

OracleSpec.QuerySeed

import VCVio.OracleComp.SimSemantics.SimulateQ

open OracleSpec OracleComp

namespace OracleSpec

variable {ι : Type u} {spec : OracleSpec ι}

namespace QueryCache

variable [spec.DecidableEq] [DecidableEq ι] (cache : QueryCache spec)

end QueryCache

namespace QueryCount

end QueryCount

namespace QueryLog

section getQ

variable [DecidableEq ι]

end getQ

section countQ

variable [DecidableEq ι]

end countQ

section prod

variable {ι₁ ι₂ : Type*} {spec₁ : OracleSpec ι₁} {spec₂ : OracleSpec ι₂}

end prod

end QueryLog

def QuerySeed (spec : OracleSpec ι) : Type _ :=
  (i : ι) → List (spec.range i)

namespace QuerySeed

section addValues

variable [DecidableEq ι] {i : ι} (seed : QuerySeed spec) (us : List (spec.range i))

end addValues

section takeAtIndex

variable [DecidableEq ι] (seed : QuerySeed spec) (i : ι) (n : ℕ)

lemma eq_takeAtIndex_length_iff (seed seed' : QuerySeed spec) (i : ι) :
    seed = seed'.takeAtIndex i (seed i).length ↔
      seed' = seed.addValues ((seed' i).drop (seed i).length) :=

:= by
  refine ⟨λ h ↦ QuerySeed.ext _ _ (λ j ↦ ?_), λ h ↦ ?_⟩
  · by_cases hj : j = i
    · induction hj
      rw [h]
      suffices (seed j).length ≤ (seed' j).length
      by simp [this]
      simpa using congr_arg List.length (congr_fun h j)
    · rw [h]
      simp [hj]
  · rw [h]
    simp


OracleQuery

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

OracleComp

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

inductionOn

@[elab_as_elim]
protected def inductionOn {C : FreeMonad f α → Prop}
    (pure : ∀ x, C (pure x))
    (roll : ∀ {β} (x : f β), (r : β → FreeMonad f α) →
      (∀ y, C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | FreeMonad.pure x => pure x
  | FreeMonad.roll x r => roll x _ (λ u ↦
      FreeMonad.inductionOn pure roll (r u))

construct

@[elab_as_elim]
protected def construct {C : OracleComp spec α → Type*}
    (pure : (a : α) → C (pure a))
    (query_bind : {β : Type v} → (q : OracleQuery spec β) →
      (oa : β → OracleComp spec α) → ((u : β) → C (oa u)) → C (q >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.construct (Option.rec failure pure) query_bind oa

@[elab_as_elim]
protected def construct {C : FreeMonad f α → Type*}
    (pure : (x : α) → C (pure x))
    (roll : {β : Type u} → (x : f β) → (r : β → FreeMonad f α) →
      ((y : β) → C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | .pure x => pure x
  | .roll x r => roll x _ (λ u ↦ FreeMonad.construct pure roll (r u))

supportWhen

def supportWhen (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Set α) : Set α :=

inductionOn

@[elab_as_elim]
protected def inductionOn {C : OracleComp spec α → Prop}
    (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

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

OracleComp.allWhen

@[simp] lemma allWhen_query_bind (q : OracleQuery spec α) (oa : α → OracleComp spec β) :
    ((q : OracleComp spec α) >>= oa).allWhen Q F possible_outputs ↔
      Q q ∧ ∀ x ∈ possible_outputs q, (oa x).allWhen Q F possible_outputs

import VCVio.OracleComp.Support

open OracleSpec

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {α β γ : Type v}

section When

variable (Q : {α : Type v} → OracleQuery spec α → Prop)
    (F : Prop) (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Set α)

def allWhen (possible_outputs : {α : Type v} → OracleQuery spec α → Set α)
    (oa : OracleComp spec α) : Prop :=

@[simp] lemma allWhen_bind_iff (oa : OracleComp spec α) (ob : α → OracleComp spec β) :
    (oa >>= ob).allWhen Q F possible_outputs ↔ oa.allWhen Q F possible_outputs ∧
      ∀ x ∈ oa.supportWhen possible_outputs, (ob x).allWhen Q F possible_outputs :=

:= by
  induction oa using OracleComp.inductionOn with
  | pure x => {
    simp [supportWhen]
  }
  | failure => {
    simp [supportWhen]
  }
  | query_bind i t oa h => {
    rw [bind_assoc, allWhen_query_bind]
    simp [h, supportWhen]
    grind only [cases Or]
  }


HasEvalDist

class HasEvalDist (m : Type u → Type v) [Monad m] where
  evalDist {α : Type u} (mx : m α) : SPMF α
  evalDist_pure {α : Type u} (x : α) : evalDist (pure x : m α) = pure x
  evalDist_bind {α β : Type u} (mx : m α) (my : α → m β) :
    evalDist (mx >>= my) = evalDist mx >>= fun x => evalDist (my x)

domain

@[inline, reducible]
protected def domain (spec : OracleSpec ι) (i : ι) : Type v := (spec i).1

OracleSpec

def OracleSpec (ι : Type u) : Type (max u (v + 1)) :=
  (i : ι) → Type v × Type v

range

@[inline, reducible]
protected def range (spec : OracleSpec ι) (i : ι) : Type w := (spec i).2

FreeMonad

inductive FreeMonad (f : Type u → Type v) (α : Type w) : Type (max (u + 1) v w)
  | protected pure (x : α) : FreeMonad f α
  | roll {β : Type u} (x : f β) (r : β → FreeMonad f α) : FreeMonad f α

cases

def cases {α} {motive : {n : ℕ} → Vector α n → Sort*} (v_empty : motive #v[])
  (v_insert : {n : ℕ} → (hd : α) → (tl : Vector α n) → motive (tl.insertIdx 0 hd)) {m : ℕ} :
    (v : Vector α m) → motive v := match hm : m with
  | 0 => fun v => match v with | ⟨⟨[]⟩, rfl⟩ => v_empty
  | n + 1 => fun v => match hv : v with
    | ⟨⟨hd :: tl⟩, hSize⟩ => by admit /- proof elided -/

simulateQ

def simulateQ [AlternativeMonad m] (so : QueryImpl spec m) (oa : OracleComp spec α) : m α :=
  do Option.getM (← FreeMonad.mapM oa.run so.impl)

QueryImpl.Inhabited

instance QueryImpl.Inhabited [∀ i, Inhabited (spec.range i)] [Pure m] :
  Inhabited (QueryImpl spec m) := ⟨{impl q := pure q.defaultOutput}⟩

mapM

protected def mapM [Pure m] [Bind m] :
    (oa : FreeMonad f α) → (s : {α : Type u} → f α → m α) → m α
  | .pure x, _ => pure x
  | .roll x r, s => s x >>= λ u ↦ (r u).mapM s

@[simp] lemma simulateQ_query (q : OracleQuery spec α) : simulateQ so q = so.impl q

OracleComp.probFailure

@[simp]
lemma evalDist_liftM [Nonempty α] [Fintype α] (q : OracleQuery spec α) :
    evalDist (q : OracleComp spec α) = OptionT.lift (PMF.uniformOfFintype α)

import VCVio.OracleComp.Traversal

import VCVio.OracleComp.SimSemantics.SimulateQ

import Mathlib.Probability.Distributions.Uniform

import ToMathlib.General

open OracleSpec Option ENNReal BigOperators

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {ι' : Type v} {spec' : OracleSpec ι'}
  {α β γ : Type w} [spec.FiniteRange] [spec'.FiniteRange]

section evalDist

end evalDist

notation "[=" x "|" oa "]" => probOutput oa x

noncomputable def probFailure (oa : OracleComp spec α) : ℝ≥0∞ :=
  (evalDist oa).run none

notation "[⊥" "|" oa "]" => probFailure oa

notation "[" p "|" oa "]" => probEvent oa p

section bounds

variable {oa : OracleComp spec α} {x : α} {p : α → Prop}

end bounds

section support

variable (oa : OracleComp spec α) (x : α) (p q : α → Prop)

variable {oa x p q}

end support

section sums

variable (oa : OracleComp spec α) (p : α → Prop)

end sums

section pure

variable (x : α)

end pure

section bind

variable (oa : OracleComp spec α) (ob : α → OracleComp spec β)

end bind

section mul_le_probEvent_bind

end mul_le_probEvent_bind

section bind_const

variable (oa : OracleComp spec α) (ob : OracleComp spec β)

end bind_const

section query

variable (i : ι) (t : spec.domain i)

@[simp]
lemma probFailure_liftM (q : OracleQuery spec α) :
    [⊥ | (q : OracleComp spec _)] = 0 :=

:= by
  have : Fintype α := q.rangeFintype
  have : Inhabited α := q.rangeInhabited
  simp only [probFailure, evalDist_liftM]
  erw [PMF.bind_apply]
  simp only [PMF.uniformOfFintype_apply, ENNReal.tsum_eq_zero, mul_eq_zero, ENNReal.inv_eq_zero,
    natCast_ne_top, false_or]
  intro i
  erw [PMF.pure_apply]
  simp


probOutput

notation "[=" x "|" oa "]" => probOutput oa x

noncomputable def probOutput (oa : OracleComp spec α) (x : α) : ℝ≥0∞ :=
  (evalDist oa).run (some x)

OracleComp

def OracleComp {ι : Type u} (spec : OracleSpec.{u,v} ι) :
    Type w → Type (max u (v + 1) w) :=
  OptionT (FreeMonad (OracleQuery.{u,v} spec))

OracleQuery

inductive OracleQuery {ι : Type u} (spec : OracleSpec.{u,v} ι) : Type v → Type (max u v)
  | query (i : ι) (t : spec.domain i) : OracleQuery spec (spec.range i)

support

def support (oa : OracleComp spec α) : Set α :=
  oa.supportWhen fun _ => Set.univ

supportWhen

def supportWhen (oa : OracleComp spec α)
    (possible_outputs : {α : Type v} → OracleQuery spec α → Set α) : Set α :=

induction

@[elab_as_elim]
protected def induction {C : OracleComp spec α → Prop}
    (oa : OracleComp spec α) (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

inductionOn

@[elab_as_elim]
protected def inductionOn {C : FreeMonad f α → Prop}
    (pure : ∀ x, C (pure x))
    (roll : ∀ {β} (x : f β), (r : β → FreeMonad f α) →
      (∀ y, C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | FreeMonad.pure x => pure x
  | FreeMonad.roll x r => roll x _ (λ u ↦
      FreeMonad.inductionOn pure roll (r u))

construct

@[elab_as_elim]
protected def construct {C : OracleComp spec α → Type*}
    (pure : (a : α) → C (pure a))
    (query_bind : {β : Type v} → (q : OracleQuery spec β) →
      (oa : β → OracleComp spec α) → ((u : β) → C (oa u)) → C (q >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.construct (Option.rec failure pure) query_bind oa

@[elab_as_elim]
protected def construct {C : FreeMonad f α → Type*}
    (pure : (x : α) → C (pure x))
    (roll : {β : Type u} → (x : f β) → (r : β → FreeMonad f α) →
      ((y : β) → C (r y)) → C (x >>= r)) :
    (oa : FreeMonad f α) → C oa
  | .pure x => pure x
  | .roll x r => roll x _ (λ u ↦ FreeMonad.construct pure roll (r u))

FiniteRange

class FiniteRange (spec : OracleSpec ι) where
    range_inhabited' (i : ι) : Inhabited (spec.range i)
    range_fintype' (i : ι) : Fintype (spec.range i)

DecidableEq

protected class DecidableEq (spec : OracleSpec ι) where
  domain_decidableEq' (i : ι) : DecidableEq (spec.domain i)
  range_decidableEq' (i : ι) : DecidableEq (spec.range i)

inductionOn

@[elab_as_elim]
protected def inductionOn {C : OracleComp spec α → Prop}
    (pure : (a : α) → C (pure a))
    (query_bind : (i : ι) → (t : spec.domain i) →
      (oa : spec.range i → OracleComp spec α) → (∀ u, C (oa u)) → C (query i t >>= oa))
    (failure : C failure) (oa : OracleComp spec α) : C oa :=
  FreeMonad.inductionOn (Option.rec failure pure) (λ (query i t) ↦ query_bind i t) oa

probOutput

notation "Pr[=" x "|" mx "]" => probOutput mx x

lemma probOutput_bind_eq_tsum (y : β) :
    [= y | oa >>= ob] = ∑' x : α, [= x | oa] * [= y | ob x]

@[simp]
lemma probOutput_pure [DecidableEq α] (y : α) :
    [= y | (pure x : OracleComp spec α)] = if y = x then 1 else 0

@[simp low]
lemma probOutput_eq_zero_iff : [= x | oa] = 0 ↔ x ∉ oa.support

@[simp]
lemma mem_support_evalDist_iff (oa : OracleComp spec α) (x : α) :
    some x ∈ (evalDist oa).run.support ↔ x ∈ oa.support

lemma probOutput_seq_map_eq_tsum [spec.FiniteRange]
    (z : γ) : [= z | f <$> oa <*> ob] = ∑' (x : α) (y : β),
      [= x | oa] * [= y | ob] * [= z | (pure (f x y) : OracleComp spec γ)]

lemma probOutput_seq_map_eq_tsum_ite [spec.FiniteRange] [DecidableEq γ]
    (z : γ) : [= z | f <$> oa <*> ob] =
      ∑' (x : α) (y : β), if z = f x y then [= x | oa] * [= y | ob] else 0

import VCVio.OracleComp.DistSemantics.Monad

namespace OracleComp

variable {ι : Type u} {spec : OracleSpec ι} {α β γ : Type v}

variable (oa : OracleComp spec α) (og : OracleComp spec (α → β))

section seq_map

variable (oa : OracleComp spec α) (ob : OracleComp spec β) (f : α → β → γ)

section swap

end swap

section injective2

end injective2

lemma probOutput_seq_map_eq_mul [spec.FiniteRange] (x : α) (y : β) (z : γ)
    (h : ∀ x' ∈ oa.support, ∀ y' ∈ ob.support, z = f x' y' ↔ x' = x ∧ y' = y) :
    [= z | f <$> oa <*> ob] = [= x | oa] * [= y | ob] :=

:= by
  have : DecidableEq γ := Classical.decEq γ
  rw [probOutput_seq_map_eq_tsum_ite, ← ENNReal.tsum_prod]
  refine (tsum_eq_single (x, y) (λ (x', y') ↦ ?_)).trans ?_
  · simp only [ne_eq, Prod.mk.injEq, ite_eq_right_iff, mul_eq_zero,
      probOutput_eq_zero_iff, ← not_and_or]
    exact λ h1 h2 h3 ↦ h1 ((h x' h3.1 y' h3.2).1 h2)
  · simp only [ite_eq_left_iff, zero_eq_mul, probOutput_eq_zero_iff, ← not_and_or]
    intro h1 h2
    refine h1 ((h x h2.1 y h2.2).2 ⟨rfl, rfl⟩)


Lens

structure Lens (P : PFunctor.{uA₁, uB₁}) (Q : PFunctor.{uA₂, uB₂}) where
  toFunA : P.A → Q.A
  toFunB : ∀ a, Q.B (toFunA a) → P.B a

Chart

structure Chart (P : PFunctor.{uA₁, uB₁}) (Q : PFunctor.{uA₂, uB₂}) where
  toFunA : P.A → Q.A
  toFunB : ∀ a, P.B a → Q.B (toFunA a)

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

PFunctor.Lens.ext

@[ext (iff := false)]
theorem ext {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₂}} (l₁ l₂ : Lens P Q)
    (h₁ : ∀ a, l₁.toFunA a = l₂.toFunA a) (h₂ : ∀ a, l₁.toFunB a = (h₁ a) ▸ l₂.toFunB a) :
    l₁ = l₂

import ToMathlib.PFunctor.Basic

section find_home

variable {α : Sort u} {β : α → Sort v} {γ : α → Sort v}

end find_home

namespace PFunctor

namespace Lens

@[inherit_doc] infixl:75 " ∘ₗ " => comp

@[inherit_doc] infix:50 " ≃ₗ " => Equiv

namespace Equiv

end Equiv

def prodPair {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₂}} {R : PFunctor.{uA₃, uB₃}}
    (l₁ : Lens P Q) (l₂ : Lens P R) :
    Lens.{uA₁, uB₁, max uA₂ uA₃, max uB₂ uB₃} P (Q * R) :=
  (fun p => (l₁.toFunA p, l₂.toFunA p)) ⇆
    (fun p => Sum.elim (l₁.toFunB p) (l₂.toFunB p))

@[inherit_doc] infixl:75 " ◃ₗ " => compMap

@[inherit_doc] infixl:75 " ×ₗ " => prodMap

@[inherit_doc] infixl:75 " ⊎ₗ " => sumMap

@[inherit_doc] infixl:75 " ⊗ₗ " => tensorMap

notation "[" l₁ "," l₂ "]ₗ" => sumPair l₁ l₂

notation "⟨" l₁ "," l₂ "⟩ₗ" => prodPair l₁ l₂

section Coprod

variable {P : PFunctor.{uA₁, uB₁}} {Q : PFunctor.{uA₂, uB₁}}
  {R : PFunctor.{uA₃, uB₃}} {W : PFunctor.{uA₄, uB₃}} {X : PFunctor.{uA₅, uB₅}}

@[simp]
theorem sumPair_inl_inr :
    Lens.sumPair Lens.inl Lens.inr = Lens.id.{max uA₁ uA₂, uB₁} (P + Q) :=


syntax (name:= assumption) "assumptionDef" : attr

Veil.SProp

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

Veil.BigStep

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

Veil.GenBigStep

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

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

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


syntax (name:= assumption) "assumptionDef" : attr

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

Veil.SProp

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

Veil.BigStep

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

Veil.GenBigStep

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)

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

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

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

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

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

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]


syntax (name:= assumption) "assumptionDef" : attr

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

Veil.SProp

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

Veil.BigStep

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

Veil.LawfulAction

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

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

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

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

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

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

:= by
  intro hterm hreq; ext post; constructor
  { simp [BigStep.toWp]; intro _ _ _
    solve_by_elim [big_step_sound'] }
  simp [BigStep.toWp]
  intro h; apply big_step_always_terminating_sound (req := (s = ·)) <;> try simp
  { solve_by_elim }
  intro; simp_all


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

Veil.SProp

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

Veil.Wp.lift

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

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

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

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

:= by
  intro ensTaut htriple s hreq
  by_cases h: (¬ ∀ r s, ens r s)
  { solve_by_elim [big_step_sound] }
  apply LawfulAction.impl (post := fun _ _ => True) <;> try simp_all


syntax (name:= assumption) "assumptionDef" : attr

Veil.SProp

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

Veil.Wp.triple

theorem TwoState_sound' [LawfulAction act] (req : SProp σ) (ens : RProp σ ρ) :
  act.triple req ens → act.toTwoState.triple req (∃ r, ens r ·)

theorem exists_over_PUnit (p : PUnit → Prop) : (∃ (u : PUnit), p u) = p ()

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

return value `r : ρ` and a post-state `s' : σ` -/

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

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

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'

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

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

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

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

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

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

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

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

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

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

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

theorem TwoState_sound'_ret_unit [LawfulAction act] (req : SProp σ) (ens : RProp σ PUnit) :
  act.triple req ens → act.toTwoState.triple req (ens () ·) :=

:= by
  have heq : (ens () ·) = (∃ r, ens r ·) := by ext ; rw [exists_over_PUnit]
  rw [heq] ; apply TwoState_sound'


FBA.intact

theorem Set.ne_empty_iff_exists_mem {α : Type u} {s : Set α} : s ≠ ∅ ↔ ∃ a, a ∈ s

theorem intact_implies_intertwined : ∀ I, intact (inst := inst) I → intertwined I

theorem intertwined_node_is_well_behaved : ∀ n S, intertwined (inst := inst) S → n ∈ S → n ∈ W

theorem intact_node_is_well_behaved : ∀ n I, intact (inst := inst) I → n ∈ I → n ∈ W

import Mathlib.Data.Set.Basic

namespace FBA

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

class System (Node : Type) where

  W : Set Node
  slices : Node → Set (Set Node)

  slices_ne : ∀ p ∈ W, slices p ≠ ∅

variable {Node : Type}

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

variable [inst : System Node]

open System

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

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

structure intertwined (S : Set Node) where
  well_behaved : S ⊆ W

  q_inter : (∀ Q Q',
    quorum (inst := inst.project S) Q →
    quorum (inst := inst.project S) Q' →
    Q ∩ S ≠ ∅ → Q' ∩ S ≠ ∅ → Q ∩ Q' ∩ S ≠ ∅)

structure intact (I : Set Node) extends intertwined I where

  q_avail : quorum (inst := inst) I

theorem slice_blocks_ne : ∀ n S I, intact (inst := inst) I → n ∈ I → blocks_slices S n →
    S ∩ I ≠ ∅ :=

:= by
  intro n S I hI hin hblock
  unfold blocks_slices at hblock
  have h := hI.q_avail ; unfold quorum at h
  simp at h ; specialize h _ hin (intact_node_is_well_behaved _ _ hI hin)
  rcases h with ⟨Sl, hSl, h⟩ ; specialize hblock _ hSl
  rw [Set.ne_empty_iff_exists_mem] at hblock ⊢ ; simp at hblock ⊢
  aesop


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

Ty

inductive Ty
  | bool
  | nat

Program

abbrev Program := List Instruction

Stack

abbrev Stack := List Nat

HEquiv

@[simp]
theorem jmp_def (offset s) : exec (.jmp offset) s = some ⟨s, offset⟩

@[simp]
theorem jez_zero (offset s) : exec (.jez offset) (0 :: s) = some ⟨s, offset⟩

@[simp]
theorem jez_succ (n offset s) : exec (.jez offset) ((n + 1) :: s) = some ⟨s, 0⟩

@[simp]
theorem goto_zero (prog : Program) : goto prog 0 = some prog

@[simp]
theorem goto_suffix (prog₁ prog₂ : Program) : goto (prog₁ ++ prog₂) prog₁.length = some prog₂

@[simp]
theorem goto_end {prog : Program} (h : offset = prog.length) : goto prog offset = some []

theorem exec_goto (hi : i.exec s₁ = some ⟨s₂, offset⟩) (hg : goto prog₁ offset = some prog₂) :
    exec (i :: prog₁) s₁ = exec prog₂ s₂

theorem goto_mono (prog₂ : Program) (h : goto prog₁ offset = some prog₁') :
    goto (prog₁ ++ prog₂) offset = some (prog₁' ++ prog₂)

@[simp]
theorem exec_prog_mono (prog₂ : Program) (h : exec prog₁ s₁ = some s₂) :
    exec (prog₁ ++ prog₂) s₁ = exec prog₂ s₂

theorem eq_false_of_toNat_eq_zero {v : Value .bool} (h : v.toNat = 0) : v = false

theorem eq_true_of_toNat_eq_succ {v : Value .bool} (h : v.toNat = n + 1) : v = true

inductive Ty
  | bool
  | nat

inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

namespace Term

def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

namespace Equiv

infixl:50 " ~ " => Equiv

end Equiv

end Term

open Term (eval)

inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

abbrev Program := List Instruction

abbrev Stack := List Nat

def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

structure Instruction.Result where
  stack : Stack
  offset := 0

def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

namespace Program

def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

end Program

def Value.toNat : Value τ → Nat
  | bool false => 0
  | bool true  => 1
  | nat n      => n

def Term.lower : Term τ → Program
  | val v            => [.const v.toNat]
  | and lhs rhs      => (lower lhs) ++ (lower rhs) ++ [.and]
  | ite cond pos neg =>
    let p := lower pos
    let n := lower neg
    lower cond ++ [.jez (p.length + 1)] ++ p ++ [.jmp n.length] ++ n

def HEquiv (t : Term τ) (prog : Program) : Prop :=
  prog.exec [] = some [t.eval.toNat]

infixl:60 " ≈ " => HEquiv

namespace Instruction

end Instruction

namespace Program

end Program

namespace Term

open Program List

open Instruction hiding exec

theorem lower_ite_hEquiv {cond : Term .bool} {pos neg : Term τ}
    (hc : cond ≈ lower cond) (hp : pos ≈ lower pos) (hn : neg ≈ lower neg) :
    ite cond pos neg ≈ lower (ite cond pos neg) :=

:= by
  rw [HEquiv, lower, append_assoc, append_assoc, append_assoc] at *
  -- Give names to terms needed later.
  let pl    := pos.lower.length + 1
  let nl    := neg.lower.length
  let prog₃ := [.jmp nl] ++ neg.lower
  let prog₂ := pos.lower ++ prog₃
  let prog₁ := [.jez pl] ++ prog₂
  -- Peel off the leading `lower cond`.
  rw [exec_prog_mono prog₁ hc]
  -- Continue differently depending on what's on top of the stack.
  cases h : cond.eval.toNat
  case zero =>
    -- Peel off the leading `jez`.
    have hg := goto_suffix (pos.lower ++ [jmp nl]) neg.lower
    simp only [length_append, length_singleton, append_assoc] at hg
    have he := exec_goto (jez_zero pl []) hg
    simp only [prog₁, singleton_append, he]
    -- Close the goal by establishing that `eval` yields `neg.eval`.
    simp_all only [prog₂, prog₃, eval, eq_false_of_toNat_eq_zero h]
  case succ n =>
    -- Peel off the leading `jez`.
    have he := exec_goto (jez_succ n pl []) (goto_zero prog₂)
    simp only [prog₁, singleton_append, he]
    -- Peel off the leading `lower pos`.
    rw [exec_prog_mono prog₃ hp]
    -- Peel off the leading `jmp`.
    have he := exec_goto (jmp_def nl [pos.eval.toNat]) (goto_end rfl)
    simp only [prog₃, singleton_append, he]
    -- Close the goal by establishing that `eval` yields `pos.eval`.
    simp only [eval, exec, eq_true_of_toNat_eq_succ h]


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

Ty

inductive Ty
  | bool
  | nat

Value

inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

Term

inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

Term.eval

def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

Instruction

inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

Program

abbrev Program := List Instruction

Stack

abbrev Stack := List Nat

Nat.conj

def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

Instruction.Result

structure Instruction.Result where
  stack : Stack
  offset := 0

Instruction.exec

def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

Program.goto

def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

Program.exec

def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

Value.toNat

def Value.toNat : Value τ → Nat
  | bool false => 0
  | bool true  => 1
  | nat n      => n

Term.lower

def Term.lower : Term τ → Program
  | val v            => [.const v.toNat]
  | and lhs rhs      => (lower lhs) ++ (lower rhs) ++ [.and]
  | ite cond pos neg =>
    let p := lower pos
    let n := lower neg
    lower cond ++ [.jez (p.length + 1)] ++ p ++ [.jmp n.length] ++ n

HEquiv

def HEquiv (t : Term τ) (prog : Program) : Prop :=
  prog.exec [] = some [t.eval.toNat]

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec inst s₁ = some ⟨s₂, o⟩) :
    exec inst (s₁ ++ s) = some ⟨s₂ ++ s, o⟩

theorem goto_mono (prog₂ : Program) (h : goto prog₁ offset = some prog₁') :
    goto (prog₁ ++ prog₂) offset = some (prog₁' ++ prog₂)

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec prog s₁ = some s₂) :
    exec prog (s₁ ++ s) = s₂ ++ s

@[simp]
theorem exec_prog_mono (prog₂ : Program) (h : exec prog₁ s₁ = some s₂) :
    exec (prog₁ ++ prog₂) s₁ = exec prog₂ s₂

theorem lower_and_hEquiv (hl : lhs ≈ lower lhs) (hr : rhs ≈ lower rhs) :
    and lhs rhs ≈ lower (and lhs rhs) :=

:= by
  have h₁ := exec_prog_mono (lower rhs ++ [.and]) hl
  have h₂ := exec_stack_mono [lhs.eval.toNat] hr
  simp only [nil_append, singleton_append] at h₂
  have h₃ := exec_prog_mono [.and] h₂
  simp [h₁, h₃, HEquiv, lower, exec, goto, Instruction.exec]


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

Ty

inductive Ty
  | bool
  | nat

Value

inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

Term

inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

Term.eval

def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

Instruction

inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

Program

abbrev Program := List Instruction

Stack

abbrev Stack := List Nat

Nat.conj

def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

Instruction.Result

structure Instruction.Result where
  stack : Stack
  offset := 0

Instruction.exec

def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

Program.goto

def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

Program.exec

def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

Value.toNat

def Value.toNat : Value τ → Nat
  | bool false => 0
  | bool true  => 1
  | nat n      => n

Term.lower

def Term.lower : Term τ → Program
  | val v            => [.const v.toNat]
  | and lhs rhs      => (lower lhs) ++ (lower rhs) ++ [.and]
  | ite cond pos neg =>
    let p := lower pos
    let n := lower neg
    lower cond ++ [.jez (p.length + 1)] ++ p ++ [.jmp n.length] ++ n

HEquiv

def HEquiv (t : Term τ) (prog : Program) : Prop :=
  prog.exec [] = some [t.eval.toNat]

@[simp]
theorem jmp_def (offset s) : exec (.jmp offset) s = some ⟨s, offset⟩

@[simp]
theorem jez_zero (offset s) : exec (.jez offset) (0 :: s) = some ⟨s, offset⟩

@[simp]
theorem jez_succ (n offset s) : exec (.jez offset) ((n + 1) :: s) = some ⟨s, 0⟩

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec inst s₁ = some ⟨s₂, o⟩) :
    exec inst (s₁ ++ s) = some ⟨s₂ ++ s, o⟩

@[simp]
theorem goto_zero (prog : Program) : goto prog 0 = some prog

@[simp]
theorem goto_suffix (prog₁ prog₂ : Program) : goto (prog₁ ++ prog₂) prog₁.length = some prog₂

@[simp]
theorem goto_end {prog : Program} (h : offset = prog.length) : goto prog offset = some []

theorem exec_goto (hi : i.exec s₁ = some ⟨s₂, offset⟩) (hg : goto prog₁ offset = some prog₂) :
    exec (i :: prog₁) s₁ = exec prog₂ s₂

theorem goto_mono (prog₂ : Program) (h : goto prog₁ offset = some prog₁') :
    goto (prog₁ ++ prog₂) offset = some (prog₁' ++ prog₂)

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec prog s₁ = some s₂) :
    exec prog (s₁ ++ s) = s₂ ++ s

@[simp]
theorem exec_prog_mono (prog₂ : Program) (h : exec prog₁ s₁ = some s₂) :
    exec (prog₁ ++ prog₂) s₁ = exec prog₂ s₂

theorem eq_false_of_toNat_eq_zero {v : Value .bool} (h : v.toNat = 0) : v = false

theorem eq_true_of_toNat_eq_succ {v : Value .bool} (h : v.toNat = n + 1) : v = true

theorem lower_val_hEquiv (v : Value τ) : val v ≈ lower (val v)

theorem lower_and_hEquiv (hl : lhs ≈ lower lhs) (hr : rhs ≈ lower rhs) :
    and lhs rhs ≈ lower (and lhs rhs)

theorem lower_ite_hEquiv {cond : Term .bool} {pos neg : Term τ}
    (hc : cond ≈ lower cond) (hp : pos ≈ lower pos) (hn : neg ≈ lower neg) :
    ite cond pos neg ≈ lower (ite cond pos neg)

theorem lower_hEquiv (t : Term τ) : t ≈ lower t :=

:= by
  induction t
  case val          => exact lower_val_hEquiv _
  case and hl hr    => exact lower_and_hEquiv hl hr
  case ite hc hp hn => exact lower_ite_hEquiv hc hp hn


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

Ty

inductive Ty
  | bool
  | nat

Term.Equiv

inductive Ty
  | bool
  | nat

inductive Value : Ty → Type
  | bool : Bool → Value .bool
  | nat  : Nat  → Value .nat

inductive Term : Ty → Type
  | val (v : Value τ)                          : Term τ
  | ite (cond : Term .bool) (pos neg : Term τ) : Term τ
  | and (lhs rhs : Term .bool)                 : Term .bool

namespace Term

def eval : Term τ → Value τ
  | val v => v
  | ite cond pos neg =>
    match eval cond with
    | true  => eval pos
    | false => eval neg
  | and lhs rhs =>
    match eval lhs, eval rhs with
    | true, true => true
    | _,    _    => false

def constFold : Term τ → Term τ
  | val v                             => val v
  | ite cond pos neg                  => ite (constFold cond) (constFold pos) (constFold neg)
  | and true true                     => true
  | and (Value.bool _) (Value.bool _) => false
  | and lhs rhs                       => and (constFold lhs) (constFold rhs)

def Equiv (t₁ t₂ : Term τ) : Prop :=
  eval t₁ = eval t₂

namespace Equiv

infixl:50 " ~ " => Equiv

end Equiv

theorem constFold_equiv (t : Term τ) : t ~ constFold t :=

:= by
  induction t
  case val v => rfl
  case ite hc hp hn => exact Equiv.ite_congr hc hp hn
  case and lhs rhs hl hr =>
    unfold constFold
    cases lhs <;> cases rhs
    case val.val v₁ v₂ => cases v₁; cases v₂; cases ‹Bool› <;> cases ‹Bool› <;> simp
    all_goals simp only [Equiv.and_congr hl hr]


Program

abbrev Program := List Instruction

Stack

abbrev Stack := List Nat

Program.exec

theorem goto_mono (prog₂ : Program) (h : goto prog₁ offset = some prog₁') :
    goto (prog₁ ++ prog₂) offset = some (prog₁' ++ prog₂)

namespace Term

namespace Equiv

infixl:50 " ~ " => Equiv

end Equiv

end Term

open Term (eval)

inductive Instruction
  | const (n : Nat)
  | and
  | jmp (offset : Nat)
  | jez (offset : Nat)

abbrev Program := List Instruction

abbrev Stack := List Nat

def Nat.conj : Nat → Nat → Nat
  | 0, _ | _, 0 => 0
  | _, _        => 1

structure Instruction.Result where
  stack : Stack
  offset := 0

def Instruction.exec : Instruction → Stack → Option Instruction.Result
  | .const n,    stack        => some { stack := n :: stack }
  | .and,        r :: l :: tl => some { stack := (l.conj r) :: tl }
  | .and,        _            => none
  | .jmp offset, stack        => some { stack, offset }
  | .jez offset, 0 :: tl      => some { stack := tl, offset }
  | .jez _,      _ :: tl      => some { stack := tl }
  | .jez _,      _            => none

namespace Program

def goto : Program → Nat → Option Program
  | prog,    0          => prog
  | [],      _ + 1      => none
  | _ :: tl, offset + 1 => goto tl offset

def exec : Program → Stack → Option Stack
  | [],       stack => stack
  | hd :: tl, stack =>
    match Instruction.exec hd stack with
    | none => none
    | some { stack, offset } =>
      match h : goto tl offset with
      | none   => none
      | some p => exec p stack
termination_by p => p.length
decreasing_by simp +arith [goto_decreasing h]

end Program

infixl:60 " ≈ " => HEquiv

namespace Instruction

end Instruction

namespace Program

@[simp]
theorem exec_prog_mono (prog₂ : Program) (h : exec prog₁ s₁ = some s₂) :
    exec (prog₁ ++ prog₂) s₁ = exec prog₂ s₂ :=

:= by
  induction prog₁, s₁ using exec.induct <;> try (simp_all [exec]; done)
  next hh hg =>
    simp only [exec, hh] at h
    rw [hg] at h
    contradiction
  next hh _ hg hi =>
    simp only [exec, hh, List.cons_append] at *
    rw [hg] at h
    rw [Program.goto_mono _ hg, ←(hi h)]


Program

abbrev Program := List Instruction

Stack

abbrev Stack := List Nat

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec inst s₁ = some ⟨s₂, o⟩) :
    exec inst (s₁ ++ s) = some ⟨s₂ ++ s, o⟩

@[simp]
theorem exec_stack_mono (s : Stack) (h : exec prog s₁ = some s₂) :
    exec prog (s₁ ++ s) = s₂ ++ s :=

:= by
  induction prog, s₁ using exec.induct <;> try (simp_all [exec]; done)
  next hh hg =>
    simp only [exec, hh] at h
    rw [hg] at h
    contradiction
  next hh _ hg hi =>
    simp only [exec, hh, Instruction.exec_stack_mono _ hh] at *
    rw [hg] at h ⊢
    exact hi h