rtmfun

Cslib/Computability/Machines/RTM/PB.lean

@@ -114,6 +114,23 @@ This allows statements that `PB`s compute functions on lean datatypes. -/
 def ComputesEnc {α : Type} [DataEncode α] (env : List Value) (impl : PB) (x : α) :=
   Computes env impl (.data (DataEncode.encode x))
 
+def ComputesFunEnc {α β : Type} [DataEncode α] [DataEncode β]
+    (p : PB → PB) (φ : α → β) : Prop :=
+  ∀ (env : List Value) (a : PB) (x : α), a.ComputesEnc env x → (p a).ComputesEnc env (φ x)
+
+structure RTMFun (α : Type) [DataEncode α] where
+  φ : Data → α
+  impl : PB → PB
+  h_impl : ComputesFunEnc impl φ
+
+structure RTMFun' (α : Type) [DataEncode α] where
+  φ : (List Value) → α
+  impl : PB
+  h_impl : ∀ env, ∃ t s, ProgSem env (impl env.length) (.data (DataEncode.encode (φ env))) t s
+
+def RTMFun'.var (i : ℕ) : RTMFun' Value :=
+  ⟨fun env => env[i]?.getD Value.empty, PB.var i, sorry⟩
+
 /-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/
 @[simp]
 lemma var_computes {i : ℕ} (h : i < env.length) :
@@ -320,6 +337,96 @@ lemma app_fn_computes {body : PB → PB} {arg : PB} {dx out : Value}
     rw [hmap]; exact hb
   exact ⟨_, _, ProgSem.app ProgSem.fn ha (AppSem.mk hb')⟩
 
+/-- Lift `PB.elim` into `RTMFun`. The scrutinee `v` produces a list-shaped `Data`; on the empty
+list the `em` branch runs, and on a `head :: tail` the cons branch `cs` is run with `head` and
+`tail` supplied as `RTMFun`s over the same input (computed by projecting from `v`). Both the
+program and the correctness proof are derived. -/
+def RTMFun.elim (v em : RTMFun Data) (cs : RTMFun Data → RTMFun Data → RTMFun Data) :
+    RTMFun Data :=
+  let hd : RTMFun Data :=
+    ⟨fun d => (v.φ d).asList.headD .empty,
+     fun a => PB.elim (v.impl a) PB.empty (fun h _ => h),
+     by
+       intro env a d h
+       have hv := v.h_impl env a d h
+       simp only [ComputesEnc, DataEncode.encode] at hv ⊢
+       cases hvd : v.φ d with
+       | l xs =>
+         cases xs with
+         | nil =>
+           rw [hvd] at hv
+           exact elim_nil_computes hv empty_computes
+         | cons hd0 tl0 =>
+           rw [hvd] at hv
+           exact elim_cons_computes hv
+             (computesFun₂_branch (fun ext => var_computes_fresh ext [.data (Data.l tl0)]))⟩
+  let tl : RTMFun Data :=
+    ⟨fun d => Data.l (v.φ d).asList.tail,
+     fun a => PB.elim (v.impl a) PB.empty (fun _ t => t),
+     by
+       intro env a d h
+       have hv := v.h_impl env a d h
+       simp only [ComputesEnc, DataEncode.encode] at hv ⊢
+       cases hvd : v.φ d with
+       | l xs =>
+         cases xs with
+         | nil =>
+           rw [hvd] at hv
+           exact elim_nil_computes hv empty_computes
+         | cons hd0 tl0 =>
+           rw [hvd] at hv
+           exact elim_cons_computes hv
+             (computesFun₂_branch2 (body := fun _ t => t)
+               (fun ext => var_computes_fresh' ext (binds := [.data hd0, .data (Data.l tl0)])
+                 (j := 1) (by simp)))⟩
+  ⟨fun d => match v.φ d with
+    | Data.l [] => em.φ d
+    | Data.l (_ :: _) => (cs hd tl).φ d,
+   fun a => PB.elim (v.impl a) (em.impl a) (fun _ _ => (cs hd tl).impl a),
+   by
+     intro env a d h
+     have hv := v.h_impl env a d h
+     simp only [ComputesEnc, DataEncode.encode] at hv ⊢
+     cases hvd : v.φ d with
+     | l xs =>
+       cases xs with
+       | nil =>
+         rw [hvd] at hv
+         exact elim_nil_computes hv (em.h_impl env a d h)
+       | cons hd0 tl0 =>
+         rw [hvd] at hv
+         exact elim_cons_computes hv
+           (computesFun₂_const ((cs hd tl).h_impl env a d h))⟩
+
+def RTMFun'.cons (hd tl : RTMFun' Data) :
+    RTMFun' Data :=
+  ⟨fun env => Data.l (hd.φ env :: (tl.φ env).asList),
+  PB.cons hd.impl tl.impl, sorry ⟩
+
+
+def RTMFun'.elim (v em : RTMFun' Data) (cs : RTMFun' Data → RTMFun' Data → RTMFun' Data) :
+    RTMFun' Data :=
+  ⟨fun env => match v.φ env with
+    | Data.l [] => em.φ env
+    | Data.l (hd :: tl) =>
+      (cs (.var (env.length)) (.var (env.length + 1))).φ (env ++ [Value.data hd, Value.data (Data.l tl)]),
+   fun a => PB.elim (v.impl a) (em.impl a) (fun h t => (cs ⟨fun _ => h, sorry⟩ ⟨fun _ => t, sorry⟩).impl a),
+   by
+     intro env a d h
+     have hv := v.h_impl env a d h
+     simp only [ComputesEnc, DataEncode.encode] at hv ⊢
+     cases hvd : v.φ env with
+     | l xs =>
+       cases xs with
+       | nil =>
+         rw [hvd] at hv
+         exact elim_nil_computes hv (em.h_impl env a d h)
+       | cons hd0 tl0 =>
+         rw [hvd] at hv
+         exact elim_cons_computes hv
+           (computesFun₂_const ((cs ⟨fun _ => hd0, sorry⟩ ⟨fun _ => Data.l tl0, sorry⟩).h_impl env a d h))⟩
+
+
 /-- Resource-erased iteration of a `while_` loop body. `WhileComputes env body acc r` says that,
 under any outer extension `ext`, repeatedly applying the loop-body closure (the closure produced by
 `while_ _ body` at the current depth) starting from accumulator `acc` eventually yields `r`.

Cslib/Computability/Machines/RTM/Prog.lean

@@ -86,6 +86,12 @@ lemma Value.size_pos {v : Value} : 0 < v.size := by
   | data d => simp only [Value.size]; exact Data.size_le
   | closure _ env => simp only [Value.size]; omega
 
+instance : DataEncode Value where
+  encode
+    | .data d => sorry
+    | .closure body env => sorry
+  h_inj := sorry
+
 mutual
 /-- Semantics of `Prog` including time and space resource bounds.
 `ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value

Cslib/Computability/Machines/RTM/TMSimulator.lean

@@ -100,6 +100,42 @@ lemma stackTapeCons_computes
     apply PB.optionElim_computesEnc_some h_x
       (PB.computesFun₂_const (PB.cons_computes h_x h_st))
 
+/-! ### Proof-of-concept: `stackTapeCons` rebuilt from the composable `RTMFun` combinators
+
+The block below demonstrates the `RTMFun` combinator library (`Tools.lean`). `stackTapeConsF` is the
+applicative-style combinator: it takes the head and tail transformers (over an arbitrary ambient
+input `I`) and produces the consed list, mirroring the direct `PB.optionElim`/`PB.elim`/`PB.cons`
+version. The program and its correctness proof are *derived*; only a small bridge from the derived
+list-valued `φ` to `StackTape.cons` is proven by hand (`stackTapeConsF_φ`). -/
+
+/-- A `StackTape` is encoded exactly as its `toList`, so the identity program retyped at
+`List (Option Symbol)` computes `StackTape.toList`. -/
+def toListF : PB.RTMFun (α := StackTape Symbol) (β := List (Option Symbol)) :=
+  ⟨StackTape.toList, id, fun _ _ _ h => h⟩
+
+open scoped PB in
+/-- `stackTapeCons` in applicative style: a combinator over an ambient input `I` taking the head
+transformer `x` and tail transformer `st`. The body mirrors the direct `PB.optionElim`/`PB.elim`/
+`PB.cons` version almost verbatim; both the program and the correctness proof are derived. -/
+def stackTapeConsF {I : Type} [DataEncode I]
+    (x : PB.RTMFun (α := I) (β := Option Symbol))
+    (st : PB.RTMFun (α := I) (β := StackTape Symbol)) :
+    PB.RTMFun (α := I) (β := List (Option Symbol)) :=
+  let stl := st >>> toListF
+  PB.RTMFun.optionElimC x
+    (PB.RTMFun.elimC stl PB.RTMFun.emptyF (PB.RTMFun.consF x stl))
+    (PB.RTMFun.consF x stl)
+
+/-- Bridge: the derived `φ` of `stackTapeConsF` computes `StackTape.cons` pointwise. -/
+lemma stackTapeConsF_φ {I : Type} [DataEncode I]
+    (x : PB.RTMFun (α := I) (β := Option Symbol))
+    (st : PB.RTMFun (α := I) (β := StackTape Symbol)) (i : I) :
+    (stackTapeConsF x st).φ i = (StackTape.cons (x.φ i) (st.φ i)).toList := by
+  simp only [stackTapeConsF, PB.RTMFun.optionElimC, PB.RTMFun.elimC, PB.RTMFun.consF,
+    PB.RTMFun.comp, toListF, Function.comp]
+  obtain ⟨l, hl⟩ := st.φ i
+  cases x.φ i <;> cases l <;> rfl --simp [StackTape.cons]
+
 --- The head component of the bitape
 def bitapeHead (t : PB) : PB := t.fst
 --- The left component of the bitape

Cslib/Computability/Machines/RTM/Tools.lean

@@ -82,6 +82,10 @@ lemma fst_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) :
   obtain ⟨a, b⟩ := a
   apply PB.head_computes hx
 
+def fst' (p : RTMFun (α × β)) : RTMFun α :=
+  ⟨fun d => (p.φ d).fst, fun a => head (p.impl a), fun env a d h_x =>
+    PB.head_computes (p.h_impl env a d h_x)⟩
+
 /-- Second projection (`head` of `tail`). -/
 def snd (x : PB) : PB := head (PB.tail x)
 
@@ -90,6 +94,10 @@ lemma snd_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) :
   obtain ⟨a, b⟩ := a
   apply PB.head_computes (PB.tail_computes hx)
 
+def snd' (p : RTMFun (α × β)) : RTMFun β :=
+  ⟨fun d => (p.φ d).snd, fun x => (p.impl x).tail.head,
+    fun env a d h_x => PB.head_computes (PB.tail_computes (p.h_impl env a d h_x))⟩
+
 /-- `Option.some` as a singleton list. -/
 def some (x : PB) : PB := cons x empty
 
@@ -101,6 +109,26 @@ lemma some_ComputesEnc {x : PB} {a : α} (hx : x.ComputesEnc env a) :
 def optionElim (x noneCase : PB) (someCase : PB → PB) : PB :=
   elim x noneCase (fun v _ => someCase v)
 
+def optionElim' (x : RTMFun (Option α)) (noneCase : RTMFun β) (someCase : RTMFun α → RTMFun β) :
+    RTMFun β :=
+  ⟨fun d => match x.φ d with
+      | .none => noneCase.φ d
+      | .some v => (someCase (⟨fun _ => v, fun _ => PB.empty, fun _ _ _ _ => empty_computes⟩)).φ d,
+   fun a => optionElim (x.impl a) (noneCase.impl a) (fun v => someCase.impl a v),
+   by
+     intro env a d h_x
+     dsimp only
+     have hcond := x.h_impl env a d h_x
+     cases hc : x.φ d with
+     | none =>
+       rw [hc] at hcond
+       exact optionElim_computesEnc_none hcond (noneCase.h_impl env a d h_x)
+     | some v =>
+       rw [hc] at hcond
+       exact optionElim_computesEnc_some hcond
+         (computesFun₂_branch2 (someCase.h_impl env a d h_x))⟩
+
+
 lemma optionElim_computesEnc_none
     {x noneCase : PB} {someCase : PB → PB}
     (hx : x.ComputesEnc env (none : Option α))
@@ -148,6 +176,132 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} :
     (constantEnc a).ComputesEnc env a := by
   simp [ComputesEnc, constantEnc]
 
+/-! ### Composable `RTMFun` combinators
+
+`RTMFun` bundles a mathematical function `φ`, a program builder `impl`, and a proof that `impl`
+computes `φ`. The combinators below are closed under this bundle: each derives the resulting `φ`,
+the resulting `impl`, and the correctness proof in one go. Branching combinators (`optionElimC`,
+`elimC`, `ifEqC`) pay their `cases` proof obligation *once*, here, so user code never repeats it.
+
+The function `φ` is automatically *derived* (verifiable by `rfl`), so a program built from these
+combinators needs no separate `_computes` lemma. The combinators operate on the structural encoding
+types (products, lists, `Option`); connecting to abstractions carrying invariants (e.g. `StackTape`)
+still requires a small bridge lemma relating the derived `φ` to the abstraction. -/
+
+/-- Identity transformer: computes `id`. -/
+def RTMFun.idF : RTMFun (α := α) (β := α) :=
+  ⟨id, id, fun _ _ _ h => h⟩
+
+/-- Composition: `g.comp f` computes `g.φ ∘ f.φ` via `fun a => g.impl (f.impl a)`. -/
+def RTMFun.comp {γ : Type} [DataEncode γ]
+    (g : RTMFun (α := β) (β := γ)) (f : RTMFun (α := α) (β := β)) :
+    RTMFun (α := α) (β := γ) :=
+  ⟨g.φ ∘ f.φ, fun a => g.impl (f.impl a),
+    fun env a x h => g.h_impl env (f.impl a) (f.φ x) (f.h_impl env a x h)⟩
+
+@[inherit_doc RTMFun.comp]
+scoped infixr:90 " >>> " => fun f g => RTMFun.comp g f
+
+/-- First projection of a pair-valued transformer: `f.fst` computes `Prod.fst ∘ f.φ`. Lets you write
+`x.fst` to project a sub-result, keeping the "arrow" style close to direct `PB` code. -/
+def RTMFun.fst {I A B : Type} [DataEncode I] [DataEncode A] [DataEncode B]
+    (f : RTMFun (α := I) (β := A × B)) : RTMFun (α := I) (β := A) :=
+  RTMFun.comp fst' f
+
+/-- Second projection of a pair-valued transformer: `f.snd` computes `Prod.snd ∘ f.φ`. -/
+def RTMFun.snd {I A B : Type} [DataEncode I] [DataEncode A] [DataEncode B]
+    (f : RTMFun (α := I) (β := A × B)) : RTMFun (α := I) (β := B) :=
+  RTMFun.comp snd' f
+
+/-- Fanout: run `f` and `g` on the same input and pair the results. -/
+def RTMFun.fanout {γ : Type} [DataEncode γ]
+    (f : RTMFun (α := α) (β := β)) (g : RTMFun (α := α) (β := γ)) :
+    RTMFun (α := α) (β := β × γ) :=
+  ⟨fun a => (f.φ a, g.φ a), fun a => toPair (f.impl a) (g.impl a),
+    fun env a x h => toPair_computesEnc (f.h_impl env a x h) (g.h_impl env a x h)⟩
+
+/-- Constant transformer: ignores the input, computes a fixed value `c`. -/
+def RTMFun.const (c : β) : RTMFun (α := α) (β := β) :=
+  ⟨fun _ => c, fun _ => constantEnc c, fun _ _ _ _ => constantEnc_computesEnc⟩
+
+/-- Lifted empty list. -/
+def RTMFun.emptyF : RTMFun (α := α) (β := (List β)) :=
+  ⟨fun _ => [], fun _ => empty, fun _ _ _ _ => empty_computesEnc β⟩
+
+/-- Lifted `cons`: prepend the head transformer's result to the tail transformer's list. -/
+def RTMFun.consF (h : RTMFun (α := α) (β := β)) (t : RTMFun (α := α) (β := (List β))) :
+    RTMFun (α := α) (β := (List β)) :=
+  ⟨fun a => h.φ a :: t.φ a, fun a => cons (h.impl a) (t.impl a),
+    fun env a x hx => cons_computesEnc (h.h_impl env a x hx) (t.h_impl env a x hx)⟩
+
+/-- Lifted `Option.some`. -/
+def RTMFun.someF (h : RTMFun (α := α) (β := β)) : RTMFun (α := α) (β := (Option β)) :=
+  ⟨fun a => Option.some (h.φ a), fun a => PB.some (h.impl a),
+    fun env a x hx => some_ComputesEnc (h.h_impl env a x hx)⟩
+
+/-- Lifted `optionElim` with constant branches: branches on whether the condition is `none` or
+`some`, ignoring the wrapped value. The `cases` proof is paid once. -/
+def RTMFun.optionElimC {I : Type} [DataEncode I]
+    (cond : RTMFun (α := I) (β := Option α))
+    (noneCase someCase : RTMFun (α := I) (β := β)) : RTMFun (α := I) (β := β) :=
+  ⟨fun i => (cond.φ i).elim (noneCase.φ i) (fun _ => someCase.φ i),
+   fun a => optionElim (cond.impl a) (noneCase.impl a) (fun _ => someCase.impl a),
+   by
+     intro env a x h
+     dsimp only
+     have hcond := cond.h_impl env a x h
+     cases hc : cond.φ x with
+     | none =>
+       rw [hc] at hcond
+       exact optionElim_computesEnc_none hcond (noneCase.h_impl env a x h)
+     | some v =>
+       rw [hc] at hcond
+       exact optionElim_computesEnc_some hcond
+         (computesFun₂_const (someCase.h_impl env a x h))⟩
+
+/-- Lifted list `elim` with constant branches: branches on whether the condition is `[]` or
+`hd :: tl`, ignoring `hd`/`tl`. The `cases` proof is paid once. -/
+def RTMFun.elimC {I : Type} [DataEncode I]
+    (cond : RTMFun (α := I) (β := List α))
+    (nilCase consCase : RTMFun (α := I) (β := β)) : RTMFun (α := I) (β := β) :=
+  ⟨fun i => (cond.φ i).casesOn (nilCase.φ i) (fun _ _ => consCase.φ i),
+   fun a => elim (cond.impl a) (nilCase.impl a) (fun _ _ => consCase.impl a),
+   by
+     intro env a x h
+     dsimp only
+     have hcond := cond.h_impl env a x h
+     cases hc : cond.φ x with
+     | nil =>
+       rw [hc] at hcond
+       exact elim_nil_computes hcond (nilCase.h_impl env a x h)
+     | cons hd tl =>
+       rw [hc] at hcond
+       refine elim_cons_computes (head := DataEncode.encode hd)
+         (tail := (tl.map DataEncode.encode)) ?_
+         (computesFun₂_const (consCase.h_impl env a x h))
+       simpa [ComputesEnc, DataEncode.encode] using hcond⟩
+
+/-- Lifted `ifEq` against a constant `c`: takes `thenCase` when the condition equals `c` (decided by
+`DecidableEq`), else `elseCase`. The case split is paid once. -/
+def RTMFun.ifEqC {I : Type} [DataEncode I] [DecidableEq α]
+    (cond : RTMFun (α := I) (β := α)) (c : α)
+    (thenCase elseCase : RTMFun (α := I) (β := β)) : RTMFun (α := I) (β := β) :=
+  ⟨fun i => if cond.φ i = c then thenCase.φ i else elseCase.φ i,
+   fun a => PB.ifEq (cond.impl a) (constantEnc c) (thenCase.impl a) (elseCase.impl a),
+   by
+     intro env a x h
+     dsimp only
+     have hcond := cond.h_impl env a x h
+     by_cases hx : cond.φ x = c
+     · rw [if_pos hx]
+       rw [hx] at hcond
+       exact ifeq_eq_computes hcond constantEnc_computesEnc (thenCase.h_impl env a x h)
+     · rw [if_neg hx]
+       refine ifeq_ne_computes hcond constantEnc_computesEnc ?_ (elseCase.h_impl env a x h)
+       intro heq
+       exact hx (DataEncode.h_inj heq)⟩
+
+
 /-- `foldl f init list`: left fold of `f` (taking `acc` then `el`) over `list`. -/
 def foldl (f : PB → PB → PB) (init list : PB) : PB :=
   snd (PB.while_ (toPair list init)