From cb9e7a3d965258ffa1508102aaf0d825a92358b1 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 17:54:17 +0100 Subject: [PATCH 01/51] Update Cslib/Computability/Machines/MultiTapeTuring/Basic.lean Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- .../Machines/MultiTapeTuring/Basic.lean | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 6bf325db8b..b3c45032ac 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -343,21 +343,12 @@ public lemma eval_eq_some_iff_transformsTapes constructor · intro ⟨h_dom, h_get⟩ use Nat.find h_dom - rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some] - rw [← configs, Option.eq_some_iff_get_eq] - use configs_isSome_of_haltsAtStep (Nat.find_spec h_dom) - ext1 - · simp - grind [haltsAtStep, Nat.find_spec h_dom] - · exact h_get + grind [TransformsTapesInExactTime, configs, haltCfgTapes, haltsAtStep] · intro ⟨t, h_iter⟩ - rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some] at h_iter - rw [← configs] at h_iter - have h_halts_at_t : tm.haltsAtStep tapes t := by simp [haltsAtStep, h_iter] - let h_halts : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩ - use h_halts - have h_eq : Nat.find h_halts = t := halting_step_unique (Nat.find_spec h_halts) h_halts_at_t - simp [h_eq, h_iter] + rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some, ← configs] at h_iter + have h_halts_at_t : tm.haltsAtStep tapes t := by grind [haltsAtStep] + have : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩ + grind [haltCfgTapes, halting_step_unique] end MultiTapeTM From cc78278fa4262b7df7a3fe8ea316b4ade1680983 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 17:37:56 +0100 Subject: [PATCH 02/51] Extract common parts. --- Cslib.lean | 1 + .../Machines/MultiTapeTuring/Basic.lean | 14 ++++++------- .../Machines/SingleTapeTuring/Basic.lean | 21 ++----------------- 3 files changed, 10 insertions(+), 26 deletions(-) diff --git a/Cslib.lean b/Cslib.lean index d64e025eff..48a755f506 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -30,6 +30,7 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Machines.SingleTapeTuring.Basic +public import Cslib.Computability.Machines.TuringCommon public import Cslib.Computability.Machines.MultiTapeTuring.Basic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index b3c45032ac..2ca7e81cd4 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -6,12 +6,12 @@ Authors: Christian Reitwiessner module --- TODO create a "common file"? -public import Cslib.Computability.Machines.SingleTapeTuring.Basic - public import Mathlib.Data.Part - -import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Data.Fintype.Defs +public import Cslib.Foundations.Data.BiTape +public import Cslib.Foundations.Data.RelatesInSteps +public import Cslib.Computability.Machines.TuringCommon +public import Mathlib.Algebra.Order.BigOperators.Group.Finset /-! # Multi-Tape Turing Machines @@ -84,7 +84,7 @@ public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where (q₀ : State) /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke for each tape and optionally the new state to transition to afterwards (`none` for halt) -/ - (tr : State → (Fin k → Option Symbol) → ((Fin k → (SingleTapeTM.Stmt Symbol)) × Option State)) + (tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State)) namespace MultiTapeTM @@ -104,7 +104,7 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩ instance : Fintype tm.State := tm.stateFintype -instance inhabitedStmt : Inhabited (SingleTapeTM.Stmt Symbol) := inferInstance +instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance /-- diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean index 4f31c1530f..adec507055 100644 --- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean @@ -9,6 +9,7 @@ module public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.RelatesInSteps public import Mathlib.Algebra.Polynomial.Eval.Defs +public import Cslib.Computability.Machines.TuringCommon @[expose] public section @@ -44,7 +45,6 @@ for convenience in composition of machines. We define a number of structures related to Turing machine computation: -* `Stmt`: the write and movement operations a TM can do in a single step. * `SingleTapeTM`: the TM itself. * `Cfg`: the configuration of a TM, including internal and tape state. * `TimeComputable f`: a TM for computing `f`, packaged with a bound on runtime. @@ -70,21 +70,6 @@ open BiTape StackTape variable {Symbol : Type} -namespace SingleTapeTM - -/-- -A Turing machine "statement" is just a `Option`al command to move left or right, -and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape` --/ -structure Stmt (Symbol : Type) where - /-- The symbol to write at the current head position -/ - symbol : Option Symbol - /-- The direction to move the tape head -/ - movement : Option Dir -deriving Inhabited - -end SingleTapeTM - /-- A single-tape Turing machine over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol). @@ -98,7 +83,7 @@ structure SingleTapeTM Symbol [Inhabited Symbol] [Fintype Symbol] where (q₀ : State) /-- Transition function, mapping a state and a head symbol to a `Stmt` to invoke, and optionally the new state to transition to afterwards (`none` for halt) -/ - (tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State) + (tr : State → Option Symbol → Stmt Symbol × Option State) namespace SingleTapeTM @@ -118,8 +103,6 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩ instance : Fintype tm.State := tm.stateFintype -instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance - /-- The configurations of a Turing machine consist of: an `Option`al state (or none for the halting state), From 07d7bcd3ac11e72f0823d6492bd369091594ec05 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 17:54:30 +0100 Subject: [PATCH 03/51] Simplify definitions and proofs. --- .../Machines/MultiTapeTuring/Basic.lean | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 2ca7e81cd4..900c4556c4 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -77,14 +77,14 @@ over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol) -/ public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where /-- type of state labels -/ - (State : Type) + State : Type /-- finiteness of the state type -/ [stateFintype : Fintype State] /-- initial state -/ - (q₀ : State) + q₀ : State /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke for each tape and optionally the new state to transition to afterwards (`none` for halt) -/ - (tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State)) + tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State) namespace MultiTapeTM @@ -139,10 +139,8 @@ public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by rw [Function.iterate_succ_apply] induction n with - | zero => simp [step] - | succ n ih => - simp only [Function.iterate_succ_apply', ih] - simp [step] + | zero => rfl + | succ n ih => grind [Function.iterate_succ_apply'] /-- A collection of tapes where the first tape contains `s` -/ public def firstTape (s : List Symbol) : Fin k → BiTape Symbol @@ -280,7 +278,7 @@ public lemma relatesInSteps_iff_step_iter_eq_some | succ t ih => rw [RelatesInSteps.succ_iff, Function.iterate_succ_apply'] constructor - · grind only [TransitionRelation, = Option.bind_some] + · grind · intro h_configs cases h : (Option.bind · tm.step)^[t] cfg₁ with | none => grind From 841be7f40ff647e163459e2394b9f5b3889e75f0 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 18:26:03 +0100 Subject: [PATCH 04/51] Use "@[expose] public section" --- .../Machines/MultiTapeTuring/Basic.lean | 57 +++++++++---------- 1 file changed, 26 insertions(+), 31 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 900c4556c4..e08ab23992 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -13,6 +13,8 @@ public import Cslib.Foundations.Data.RelatesInSteps public import Cslib.Computability.Machines.TuringCommon public import Mathlib.Algebra.Order.BigOperators.Group.Finset +@[expose] public section + /-! # Multi-Tape Turing Machines @@ -75,7 +77,7 @@ variable {k : ℕ} A `k`-tape Turing machine over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol). -/ -public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where +structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where /-- type of state labels -/ State : Type /-- finiteness of the state type -/ @@ -113,7 +115,7 @@ an `Option`al state (or none for the halting state), and a `BiTape` representing the tape contents. -/ @[ext] -public structure Cfg : Type where +structure Cfg : Type where /-- the state of the TM (or none for the halting state) -/ state : Option tm.State /-- the BiTape contents -/ @@ -121,7 +123,7 @@ public structure Cfg : Type where deriving Inhabited /-- The step function corresponding to a `MultiTapeTM`. -/ -public def step : tm.Cfg → Option tm.Cfg +def step : tm.Cfg → Option tm.Cfg | ⟨none, _⟩ => -- If in the halting state, there is no next configuration none @@ -135,7 +137,7 @@ public def step : tm.Cfg → Option tm.Cfg /-- Any number of positive steps run from a halting configuration lead to `none`. -/ @[simp, scoped grind =] -public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) : +lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) : (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by rw [Function.iterate_succ_apply] induction n with @@ -143,7 +145,7 @@ public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) | succ n ih => grind [Function.iterate_succ_apply'] /-- A collection of tapes where the first tape contains `s` -/ -public def firstTape (s : List Symbol) : Fin k → BiTape Symbol +def firstTape (s : List Symbol) : Fin k → BiTape Symbol | ⟨0, _⟩ => BiTape.mk₁ s | ⟨_, _⟩ => default @@ -153,46 +155,42 @@ Note that the entries of the tape constructed by `BiTape.mk₁` are all `some` v This is to ensure that distinct lists map to distinct initial configurations. -/ @[simp] -public def initCfg (s : List Symbol) : tm.Cfg := +def initCfg (s : List Symbol) : tm.Cfg := ⟨some tm.q₀, firstTape s⟩ /-- Create an initial configuration given a tuple of tapes. -/ @[simp] -public def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := +def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := ⟨some tm.q₀, tapes⟩ /-- The final configuration corresponding to a list in the output alphabet. (We demand that the head halts at the leftmost position of the output.) -/ @[simp] -public def haltCfg (s : List Symbol) : tm.Cfg := +def haltCfg (s : List Symbol) : tm.Cfg := ⟨none, firstTape s⟩ /-- The final configuration of a Turing machine given a tuple of tapes. -/ @[simp] -public def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := +def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := ⟨none, tapes⟩ /-- The sequence of configurations of the Turing machine starting with initial state and given tapes at step `t`. If the Turing machine halts, it will eventually get and stay `none` after reaching the halting configuration. -/ -public def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg := +def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg := (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes) - - --- TODO shouldn't this be spaceUsed? (If yes, also change it in SingleTapeTM) - /-- The space used by a configuration is the sum of the space used by its tapes. -/ -public def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used +def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used /-- The space used by a configuration grows by at most `k` each step. -/ -public lemma Cfg.space_used_step (cfg cfg' : tm.Cfg) +lemma Cfg.space_used_step (cfg cfg' : tm.Cfg) (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + k := by obtain ⟨_ | q, tapes⟩ := cfg · simp [step] at hstep @@ -220,12 +218,12 @@ is defined by the `step` function, which maps a configuration to its next configuration, if it exists. -/ @[scoped grind =] -public def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := +def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := tm.step c₁ = some c₂ /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps. -/ -public def TransformsTapesInExactTime +def TransformsTapesInExactTime (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) (t : ℕ) : Prop := @@ -233,21 +231,19 @@ public def TransformsTapesInExactTime /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in up to `t` steps. -/ -public def TransformsTapesInTime +def TransformsTapesInTime (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) (t : ℕ) : Prop := RelatesWithinSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t /-- The Turing machine `tm` transforms tapes `tapes` to `tapes'`. -/ -public def TransformsTapes - (tm : MultiTapeTM k Symbol) - (tapes tapes' : Fin k → BiTape Symbol) : Prop := +def TransformsTapes (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) : Prop := ∃ t, tm.TransformsTapesInExactTime tapes tapes' t /-- A proof that the Turing machine `tm` uses at most space `s` when run for up to `t` steps on initial tapes `tapes`. -/ -public def UsesSpaceUntilStep +def UsesSpaceUntilStep (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (s t : ℕ) : Prop := @@ -257,7 +253,7 @@ public def UsesSpaceUntilStep /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps and uses at most `s` space. -/ -public def TransformsTapesInTimeAndSpace +def TransformsTapesInTimeAndSpace (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) (t s : ℕ) : Prop := @@ -267,7 +263,7 @@ public def TransformsTapesInTimeAndSpace /-- This lemma translates between the relational notion and the iterated step notion. The latter can be more convenient especially for deterministic machines as we have here. -/ @[scoped grind =] -public lemma relatesInSteps_iff_step_iter_eq_some +lemma relatesInSteps_iff_step_iter_eq_some (tm : MultiTapeTM k Symbol) (cfg₁ cfg₂ : tm.Cfg) (t : ℕ) : @@ -287,14 +283,13 @@ public lemma relatesInSteps_iff_step_iter_eq_some grind /-- The Turing machine `tm` halts after exactly `t` steps on initial tapes `tapes`. -/ -public def haltsAtStep - (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool := +def haltsAtStep (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool := match (tm.configs tapes t) with | some ⟨none, _⟩ => true | _ => false /-- If a Turing machine halts, the time step is uniquely determined. -/ -public lemma halting_step_unique +lemma halting_step_unique {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t₁ t₂ : ℕ} @@ -316,7 +311,7 @@ public lemma halting_step_unique simp at h_halts₂ /-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/ -public lemma configs_isSome_of_haltsAtStep +lemma configs_isSome_of_haltsAtStep {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t : ℕ} (h_halts : tm.haltsAtStep tapes t) : (tm.configs tapes t).isSome := by @@ -324,7 +319,7 @@ public lemma configs_isSome_of_haltsAtStep /-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes if it eventually halts. -/ -public def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : +def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : Part (Fin k → BiTape Symbol) := ⟨∃ t, tm.haltsAtStep tapes t, fun h => ((tm.configs tapes (Nat.find h)).get @@ -333,7 +328,7 @@ public def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : /-- Evaluating a Turing machine on a tuple of tapes `tapes` has a value `tapes'` if and only if it transforms `tapes` into `tapes'`. -/ @[scoped grind =] -public lemma eval_eq_some_iff_transformsTapes +lemma eval_eq_some_iff_transformsTapes {tm : MultiTapeTM k Symbol} {tapes tapes' : Fin k → BiTape Symbol} : tm.eval tapes = .some tapes' ↔ tm.TransformsTapes tapes tapes' := by From abac0f11ddf6579691556eb705599353f16a5cca Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 18:26:49 +0100 Subject: [PATCH 05/51] Update Cslib.lean --- Cslib.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cslib.lean b/Cslib.lean index 48a755f506..4e8f8d568b 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -29,9 +29,9 @@ public import Cslib.Computability.Languages.Language public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage +public import Cslib.Computability.Machines.MultiTapeTuring.Basic public import Cslib.Computability.Machines.SingleTapeTuring.Basic public import Cslib.Computability.Machines.TuringCommon -public import Cslib.Computability.Machines.MultiTapeTuring.Basic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable public import Cslib.Computability.URM.Defs From ae6c498526fed9a2002d0396a60068782c8e3cd7 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 10 Mar 2026 23:52:23 +0100 Subject: [PATCH 06/51] Add missed file. --- .../Computability/Machines/TuringCommon.lean | 28 +++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 Cslib/Computability/Machines/TuringCommon.lean diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean new file mode 100644 index 0000000000..e9e19184f0 --- /dev/null +++ b/Cslib/Computability/Machines/TuringCommon.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey, Pim Spelier, Daan van Gent +-/ + +module + +public import Mathlib.Computability.Tape + +@[expose] public section + +namespace Turing + +/-- +A Turing machine "statement" is just a `Option`al command to move left or right, +and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape` +-/ +structure Stmt (Symbol : Type) where + /-- The symbol to write at the current head position -/ + symbol : Option Symbol + /-- The direction to move the tape head -/ + movement : Option Dir +deriving Inhabited + +instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance + +end Turing From 7401a21ab47ac4cf53cd964f1f7d7e9896867a64 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 19 Mar 2026 12:15:06 +0100 Subject: [PATCH 07/51] fix import. --- Cslib/Computability/Machines/TuringCommon.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean index e9e19184f0..60d0636639 100644 --- a/Cslib/Computability/Machines/TuringCommon.lean +++ b/Cslib/Computability/Machines/TuringCommon.lean @@ -6,7 +6,7 @@ Authors: Bolton Bailey, Pim Spelier, Daan van Gent module -public import Mathlib.Computability.Tape +public import Mathlib.Computability.TuringMachine.Tape @[expose] public section From 3110f77821d3c3798e724c68a470e605cea22927 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 30 Apr 2026 10:25:46 +0200 Subject: [PATCH 08/51] Move "expose" command below module-level documentation. --- Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index e08ab23992..91ee0c781d 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -13,8 +13,6 @@ public import Cslib.Foundations.Data.RelatesInSteps public import Cslib.Computability.Machines.TuringCommon public import Mathlib.Algebra.Order.BigOperators.Group.Finset -@[expose] public section - /-! # Multi-Tape Turing Machines @@ -63,6 +61,8 @@ There are multiple ways to talk about the behaviour of a multi-tape Turing machi -/ +@[expose] public section + open Cslib Relation namespace Turing From 883e8687949015f702629dc1722445386c2d6a5b Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 2 Jun 2026 18:03:35 +0200 Subject: [PATCH 09/51] Introduce read-only input tape and write-only output tape and define time and space consumption. --- .../Machines/MultiTapeTuring/Basic.lean | 404 ++++++++++-------- 1 file changed, 223 insertions(+), 181 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 91ee0c781d..5aed397c69 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -8,56 +8,51 @@ module public import Mathlib.Data.Part public import Mathlib.Data.Fintype.Defs +public import Mathlib.Data.Finset.Max +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Computability.Language public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.RelatesInSteps public import Cslib.Computability.Machines.TuringCommon -public import Mathlib.Algebra.Order.BigOperators.Group.Finset /-! # Multi-Tape Turing Machines -Defines Turing machines with `k` tapes (bidirectionally infinite, `BiTape`) containing symbols -from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the blank symbol). +Defines Turing machines with a read-only input tape, `k` work tapes and one write-only output tape. +The tapes contain symbols from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the +blank symbol). ## Design -The design of the multi-tape Turing machine follows the one for single-tape Turing machines. -With multiple tapes, it is not immediatly clear how to define the function computed by a Turing -machine. For a single-tape Turing machine, function composition follows easily from composition -of configurations. For multi-tape machines, we focus on composition of tape configurations -(cf. `MultiTapeTM.eval`) and defer the decision of how to define the function computed by a -Turing machine to a later stage. - -Since these Turing machines are deterministic, we base the definition of semantics on the sequence -of configurations instead of reachability in a configuration relation, although equivalence -between these two notions is proven. +The multi-tape Turing machine uses a read-only input tape, `k` work tapes and a write-only output +tape. +The input head can move freely on the input, but any move attempt beyond one cell outside the input +results in no movement. +The transition function can optionally output one symbol, which models the write-only output tape. +Because of these restrictions, the input and output tapes do not count towards the space usage of +the machine. The space usage of the work tapes is the number of cells the head accessed. ## Important Declarations -We define a number of structures related to multi-tape Turing machine computation: +We define a number of structures and concepts related to multi-tape Turing machine computation: * `MultiTapeTM`: the TM itself -* `Cfg`: the configuration of a TM, including internal state and the state of the tapes -* `UsesSpaceUntilStep`: a TM uses at most space `s` when run for up to `t` steps -* `TrasformsTapesInExactTime`: a TM transforms tapes `tapes` to `tapes'` in exactly `t` steps -* `TransformsTapesInTime`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps -* `TransformsTapes`: a TM transforms tapes `tapes` to `tapes'` in some number of steps -* `TransformsTapesInTimeAndSpace`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps - and uses at most `s` space - -There are multiple ways to talk about the behaviour of a multi-tape Turing machine: +* `Cfg`: the configuration of a TM, including internal state, the tapes and the output so far +* `spaceUsed`: the number of work tape cells touched by the head until a certain step +* `TransitionRelation`: the transition relation from one configuration to the next +* `ComputesInTimeAndSpace`: a proof that a TM computes an output from an input in a certain number + of steps and using a certain number of tape cells +* `ComputesFunInTimeAndSpace`: a proof that a TM computes a function (on strings) respecting a + time and space bound in the input length +* `DecidesLanguageInTimeAndSpace`: a proof that a TM decides a language within a certain time + and space bound + +There are two ways to talk about the behaviour of a multi-tape Turing machine, and they are +proven to be equivalent. * `MultiTapeTM.configs`: a sequence of configurations by execution step -* `TransformsTapes`: a TM transforms initial tapes `tapes` and halts with tapes `tapes'` -* `MultiTapeTM.eval`: executes a TM on initial tapes `tapes` and returns the resulting tapes if it - eventually halts - -## TODOs - -* Define sequential composition of multi-tape Turing machines. -* Define different kinds of tapes (input-only, output-only, oracle, etc) and how they influence - how space is counted. -* Define the notion of a multi-tape Turing machine computing a function. +* `RelatesInSteps tm.TransitionRelation cfg cfg' t`: a proof that `tm` transforms the configuration + `cfg` into `cfg'` in exactly `t` steps -/ @@ -73,9 +68,20 @@ variable {Symbol : Type} variable {k : ℕ} +/-- The output of the transition function. -/ +structure TransitionOut (k : ℕ) (Symbol State : Type) where + /-- The movement (attempt) of the input head. -/ + inputMove : Option Dir + /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/ + stmts : Fin k → Stmt Symbol + /-- An optional symbol to output. -/ + outS : Option Symbol + /-- The successor state or none to halt. -/ + q' : Option State + /-- -A `k`-tape Turing machine -over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol). +A multi-tape Turing machine with `k` work tapes over the alphabet of `Option Symbol` (where `none` +is the blank `BiTape` symbol). -/ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where /-- type of state labels -/ @@ -84,9 +90,9 @@ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where [stateFintype : Fintype State] /-- initial state -/ q₀ : State - /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke - for each tape and optionally the new state to transition to afterwards (`none` for halt) -/ - tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State) + /-- transition function, mapping a state and a tuple of head symbols to a movement for the + input head, actions on the work tape, optionally a symbol to output and the successor state -/ + tr : State → (Fin (k + 1) → Option Symbol) → TransitionOut k Symbol State namespace MultiTapeTM @@ -102,43 +108,54 @@ and the intended initial and final configurations. variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) -instance : Inhabited tm.State := ⟨tm.q₀⟩ - -instance : Fintype tm.State := tm.stateFintype - -instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance - - /-- The configurations of a Turing machine consist of: -an `Option`al state (or none for the halting state), -and a `BiTape` representing the tape contents. +- an `Option`al state (or none for the halting state), +- `BiTape`s representing the tape contents and +- the output so far. -/ @[ext] structure Cfg : Type where /-- the state of the TM (or none for the halting state) -/ state : Option tm.State - /-- the BiTape contents -/ - tapes : Fin k → BiTape Symbol + /-- the tape contents -/ + tapes : Fin (k + 1) → BiTape Symbol + /-- the output so far -/ + output : List Symbol deriving Inhabited +/-- Applies the actions / statements to the tapes. +The input tape is handled specially: The machine can read one empty cell outside of the input, +but any attempted movement beyond that results in no movement. -/ +def applyTapeActions + (inputMove : Option Dir) + (stmts : Fin k → Stmt Symbol) + (tapes : Fin (k + 1) → BiTape Symbol) : + Fin (k + 1) → BiTape Symbol + | ⟨0, _⟩ => match inputMove, tapes ⟨0, by omega⟩ with + | none, t => t + | some .left, t => if t.left.toList = [] ∧ t.head = none then t else t.move_left + | some .right, t => if t.right.toList = [] ∧ t.head = none then t else t.move_right + | ⟨i + 1, _⟩ => let s := stmts ⟨i, by omega⟩ + ((tapes ⟨i + 1, by omega⟩).write s.symbol).optionMove s.movement + +/-- The output of the transition function applied to a configuration. -/ +def transitionOutput : tm.Cfg → Option (TransitionOut k Symbol tm.State) + | ⟨none, _, _⟩ => none -- halting state + | ⟨some q, tapes, _⟩ => some (tm.tr q (fun i => (tapes i).head)) + /-- The step function corresponding to a `MultiTapeTM`. -/ -def step : tm.Cfg → Option tm.Cfg - | ⟨none, _⟩ => - -- If in the halting state, there is no next configuration - none - | ⟨some q, tapes⟩ => - -- If in state q, perform look up in the transition function - match tm.tr q (fun i => (tapes i).head) with - -- and enter a new configuration with state q' (or none for halting) - -- and tapes updated according to the Stmt - | ⟨stmts, q'⟩ => some ⟨q', fun i => - ((tapes i).write (stmts i).symbol).optionMove (stmts i).movement⟩ +def step (cfg : tm.Cfg) : Option tm.Cfg := + (tm.transitionOutput cfg).map fun {inputMove, stmts, outS, q'} => + let output := match outS with + | none => cfg.output + | some s => cfg.output ++ [s] + ⟨q', applyTapeActions inputMove stmts cfg.tapes, output⟩ /-- Any number of positive steps run from a halting configuration lead to `none`. -/ @[simp, scoped grind =] -lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) : - (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by +lemma step_iter_none_eq_none (tapes : Fin (k + 1) → BiTape Symbol) (out : List Symbol) (n : ℕ) : + (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes, out⟩) = none := by rw [Function.iterate_succ_apply] induction n with | zero => rfl @@ -149,64 +166,124 @@ def firstTape (s : List Symbol) : Fin k → BiTape Symbol | ⟨0, _⟩ => BiTape.mk₁ s | ⟨_, _⟩ => default -/-- -The initial configuration corresponding to a list in the input alphabet. -Note that the entries of the tape constructed by `BiTape.mk₁` are all `some` values. -This is to ensure that distinct lists map to distinct initial configurations. --/ +/-- The initial configuration corresponding to a list in the input alphabet. -/ @[simp] def initCfg (s : List Symbol) : tm.Cfg := - ⟨some tm.q₀, firstTape s⟩ + ⟨some tm.q₀, firstTape s, []⟩ -/-- Create an initial configuration given a tuple of tapes. -/ -@[simp] -def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := - ⟨some tm.q₀, tapes⟩ +/-- The sequence of configurations of the Turing machine starting from `cfg`. +If the Turing machine halts, it will eventually get and stay `none` after reaching the halting +configuration. -/ +def configs (cfg : tm.Cfg) (t : ℕ) : Option tm.Cfg := + (Option.bind · tm.step)^[t] cfg + +end Cfg + +section Space +/-! Now we define space usage and add some helper lemmas. -/ + +variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) + +/-- Convert an "optional movement" to an integer where positive is "right". -/ +@[simp, grind] +def OptionDirToInt : Option Dir → ℤ + | some .left => -1 + | none => 0 + | some .right => 1 -/-- The final configuration corresponding to a list in the output alphabet. -(We demand that the head halts at the leftmost position of the output.) +/-- The movements of the work tape heads after configuration `cfg`. -/ +def headMovements (cfg : tm.Cfg) : Fin k → ℤ + | i => match tm.transitionOutput cfg with + | some tro => OptionDirToInt (tro.stmts ⟨i, by omega⟩).movement + | none => 0 + +/-- The head positions of the work tapes as a function of the number of steps, relative to +the starting position in `cfg`. -/ +def headPositions (cfg : tm.Cfg) (t : ℕ) : Fin k → ℤ + | i => ∑ t' ∈ Finset.range t, (tm.configs cfg t').elim 0 (tm.headMovements · i) + +/-- +The number of work tape cells touched by the head of tape `i` in the computation starting from +configuration `cfg` up to step `t`. -/ -@[simp] -def haltCfg (s : List Symbol) : tm.Cfg := - ⟨none, firstTape s⟩ +def spaceUsedByTape (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : ℕ := + let positions := (Finset.range (t + 1)).image (fun t' => tm.headPositions cfg t' i) + have ne := Finset.image_nonempty.mpr ⟨0, by simp⟩ + (positions.max' ne - positions.min' ne).toNat + 1 -/-- The final configuration of a Turing machine given a tuple of tapes. -/ -@[simp] -def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := - ⟨none, tapes⟩ +/-- +The number of work tape cells touched by a computation starting from configuration +`cfg` up to step `t`. +-/ +def spaceUsed (cfg : tm.Cfg) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i -/-- The sequence of configurations of the Turing machine starting with initial state and -given tapes at step `t`. -If the Turing machine halts, it will eventually get and stay `none` after reaching the halting -configuration. -/ -def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg := - (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes) +/-- A zero-tape Turing machine uses zero space. -/ +@[simp] +lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) : + tm.spaceUsed cfg t = 0 := by + unfold spaceUsed + subst h_zero + simp + +@[scoped grind .] +lemma OptionDirToInt_bound (d : Option Dir) : + -1 ≤ OptionDirToInt d ∧ OptionDirToInt d ≤ 1 := by + rcases d with _ | d + · decide + · rcases d <;> decide + +/-- A single step moves each work tape head by at most one cell. -/ +lemma step_head_movement_bound (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : + -1 ≤ (tm.configs cfg t).elim 0 (tm.headMovements · i) + ∧ (tm.configs cfg t).elim 0 (tm.headMovements · i) ≤ 1 := by + unfold headMovements + dsimp + rcases h : tm.configs cfg t <;> + grind + +/-- The head position changes by the corresponding head movement on each step. -/ +lemma headPositions_succ (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : + tm.headPositions cfg (t + 1) i + = tm.headPositions cfg t i + (tm.configs cfg t).elim 0 (tm.headMovements · i) := by + simp only [headPositions, Finset.sum_range_succ] /-- -The space used by a configuration is the sum of the space used by its tapes. +Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned +interval `max' - min'` by at most one cell. -/ -def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used +lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty) + {a q : ℤ} (hSeq : S = insert a s) (hq : q ∈ s) (h1 : a ≤ q + 1) (h2 : q ≤ a + 1) : + (S.max' hS - S.min' hS).toNat ≤ (s.max' hs - s.min' hs).toNat + 1 := by + subst hSeq + rw [Finset.max'_insert _ _ hs, Finset.min'_insert _ _ hs] + have hm := Finset.min'_le _ _ hq + have hM := Finset.le_max' _ _ hq + grind + +/-- The number of cells touched by a single work tape grows by at most one each step. -/ +lemma spaceUsedByTape_succ_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : + tm.spaceUsedByTape cfg (t + 1) i ≤ tm.spaceUsedByTape cfg t i + 1 := by + unfold spaceUsedByTape + have hs := tm.headPositions_succ cfg t i + have step_bound := tm.step_head_movement_bound cfg t i + apply Nat.add_le_add_right + refine span_insert_le _ _ + (by rw [Finset.range_add_one, Finset.image_insert]) + (by exact Finset.mem_image_of_mem _ (Finset.mem_range.mpr (Nat.lt_succ_self t))) + (by grind) + (by grind) /-- The space used by a configuration grows by at most `k` each step. -/ -lemma Cfg.space_used_step (cfg cfg' : tm.Cfg) - (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + k := by - obtain ⟨_ | q, tapes⟩ := cfg - · simp [step] at hstep - · simp only [step] at hstep - generalize h_tr : tm.tr q (fun i => (tapes i).head) = result at hstep - obtain ⟨stmts, q''⟩ := result - injection hstep with hstep - subst hstep - simp only [space_used] - trans ∑ i : Fin k, ((tapes i).space_used + 1) - · refine Finset.sum_le_sum fun i _ => ?_ - unfold BiTape.optionMove - grind [BiTape.space_used_write, BiTape.space_used_move] - · simp [Finset.sum_add_distrib] +lemma spaceUsed_linear (cfg : tm.Cfg) (t : ℕ) : + tm.spaceUsed cfg (t + 1) ≤ tm.spaceUsed cfg t + k := by + calc tm.spaceUsed cfg (t + 1) + ≤ ∑ i, (tm.spaceUsedByTape cfg t i + 1) := + Finset.sum_le_sum fun i _ => tm.spaceUsedByTape_succ_le cfg t i + _ = (∑ i, tm.spaceUsedByTape cfg t i) + k := by simp [Finset.sum_add_distrib] -end Cfg +end Space open Cfg @@ -221,44 +298,38 @@ which maps a configuration to its next configuration, if it exists. def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := tm.step c₁ = some c₂ -/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly -`t` steps. -/ -def TransformsTapesInExactTime - (tm : MultiTapeTM k Symbol) - (tapes tapes' : Fin k → BiTape Symbol) - (t : ℕ) : Prop := - RelatesInSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t - -/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in up to -`t` steps. -/ -def TransformsTapesInTime - (tm : MultiTapeTM k Symbol) - (tapes tapes' : Fin k → BiTape Symbol) - (t : ℕ) : Prop := - RelatesWithinSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t - -/-- The Turing machine `tm` transforms tapes `tapes` to `tapes'`. -/ -def TransformsTapes (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) : Prop := - ∃ t, tm.TransformsTapesInExactTime tapes tapes' t - -/-- A proof that the Turing machine `tm` uses at most space `s` when run for up to `t` steps -on initial tapes `tapes`. -/ -def UsesSpaceUntilStep - (tm : MultiTapeTM k Symbol) - (tapes : Fin k → BiTape Symbol) - (s t : ℕ) : Prop := - ∀ t' ≤ t, match tm.configs tapes t' with - | none => true - | some cfg => cfg.space_used ≤ s - -/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps +/-- A proof that the Turing machine `tm` on input `input` outputs `output` in exactly `t` steps and uses at most `s` space. -/ -def TransformsTapesInTimeAndSpace +def ComputesInTimeAndSpace (tm : MultiTapeTM k Symbol) - (tapes tapes' : Fin k → BiTape Symbol) + (input output : List Symbol) (t s : ℕ) : Prop := - tm.TransformsTapesInExactTime tapes tapes' t ∧ - tm.UsesSpaceUntilStep tapes s t + ∃ cfg, + cfg.state = none ∧ + cfg.output = output ∧ + RelatesInSteps tm.TransitionRelation (tm.initCfg input) cfg t ∧ + tm.spaceUsed (tm.initCfg input) t = s + +/-- A proof that the Turing machine `tm` computes the function `f` such that on all inputs of +length `n` it uses at most `t n` steps and `s n` space. -/ +def ComputesFunInTimeAndSpace + (tm : MultiTapeTM k Symbol) + (f : List Symbol → List Symbol) + (t s : ℕ → ℕ) : Prop := + ∀ input, ∃ t' ≤ t input.length, ∃ s' ≤ s input.length, + ComputesInTimeAndSpace tm input (f input) t' s' + +open Classical in +/-- The indicator function of a language. -/ +noncomputable def indicator (l : Language Symbol) : List Symbol → List Symbol + | x => if x ∈ l then [default] else [] + +/-- A proof that a Turing machine `tm` decides a language `l` with time and space bounds. -/ +def DecidesLanguageInTimeAndSpace + (tm : MultiTapeTM k Symbol) + (L : Language Symbol) + (t s : ℕ → ℕ) : Prop := + ComputesFunInTimeAndSpace tm (indicator L) t s /-- This lemma translates between the relational notion and the iterated step notion. The latter can be more convenient especially for deterministic machines as we have here. -/ @@ -282,19 +353,19 @@ lemma relatesInSteps_iff_step_iter_eq_some use cfg' grind -/-- The Turing machine `tm` halts after exactly `t` steps on initial tapes `tapes`. -/ -def haltsAtStep (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool := - match (tm.configs tapes t) with - | some ⟨none, _⟩ => true +/-- The Turing machine `tm` halts after exactly `t` steps on input `input`. -/ +def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool := + match (tm.configs (tm.initCfg input) t) with + | some ⟨none, _, _⟩ => true | _ => false /-- If a Turing machine halts, the time step is uniquely determined. -/ lemma halting_step_unique {tm : MultiTapeTM k Symbol} - {tapes : Fin k → BiTape Symbol} + {input : List Symbol} {t₁ t₂ : ℕ} - (h_halts₁ : tm.haltsAtStep tapes t₁) - (h_halts₂ : tm.haltsAtStep tapes t₂) : + (h_halts₁ : tm.haltsAtStep input t₁) + (h_halts₂ : tm.haltsAtStep input t₂) : t₁ = t₂ := by wlog h : t₁ ≤ t₂ · exact (this h_halts₂ h_halts₁ (Nat.le_of_not_le h)).symm @@ -302,46 +373,17 @@ lemma halting_step_unique cases d with | zero => rfl | succ d => - -- this is a contradiction. unfold haltsAtStep configs at h_halts₁ h_halts₂ - split at h_halts₁ <;> try contradiction - next tapes' h_iter_t₁ => - rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply, h_iter_t₁, - step_iter_none_eq_none (tm := tm) tapes' d] at h_halts₂ - simp at h_halts₂ + rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply] at h_halts₂ + grind /-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/ lemma configs_isSome_of_haltsAtStep - {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t : ℕ} - (h_halts : tm.haltsAtStep tapes t) : - (tm.configs tapes t).isSome := by + {tm : MultiTapeTM k Symbol} {input : List Symbol} {t : ℕ} + (h_halts : tm.haltsAtStep input t) : + (tm.configs (tm.initCfg input) t).isSome := by grind [haltsAtStep] -/-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes -if it eventually halts. -/ -def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : - Part (Fin k → BiTape Symbol) := - ⟨∃ t, tm.haltsAtStep tapes t, - fun h => ((tm.configs tapes (Nat.find h)).get - (configs_isSome_of_haltsAtStep (Nat.find_spec h))).tapes⟩ - -/-- Evaluating a Turing machine on a tuple of tapes `tapes` has a value `tapes'` if and only if -it transforms `tapes` into `tapes'`. -/ -@[scoped grind =] -lemma eval_eq_some_iff_transformsTapes - {tm : MultiTapeTM k Symbol} - {tapes tapes' : Fin k → BiTape Symbol} : - tm.eval tapes = .some tapes' ↔ tm.TransformsTapes tapes tapes' := by - simp only [eval, Part.eq_some_iff, Part.mem_mk_iff] - constructor - · intro ⟨h_dom, h_get⟩ - use Nat.find h_dom - grind [TransformsTapesInExactTime, configs, haltCfgTapes, haltsAtStep] - · intro ⟨t, h_iter⟩ - rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some, ← configs] at h_iter - have h_halts_at_t : tm.haltsAtStep tapes t := by grind [haltsAtStep] - have : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩ - grind [haltCfgTapes, halting_step_unique] end MultiTapeTM From 3ac3ac872da42fa2b2f45f672c7fdc49270852bd Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 2 Jun 2026 18:06:03 +0200 Subject: [PATCH 10/51] Clean up imports. --- Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 2 -- 1 file changed, 2 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 5aed397c69..6147be7269 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -6,8 +6,6 @@ Authors: Christian Reitwiessner module -public import Mathlib.Data.Part -public import Mathlib.Data.Fintype.Defs public import Mathlib.Data.Finset.Max public import Mathlib.Algebra.Order.BigOperators.Group.Finset public import Mathlib.Computability.Language From b5689a11b478d952501d7e69c42e0514c6c9f775 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 2 Jun 2026 18:09:34 +0200 Subject: [PATCH 11/51] more cleanup --- Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 6147be7269..4c5bb9d500 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -249,7 +249,7 @@ lemma headPositions_succ (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned interval `max' - min'` by at most one cell. -/ -lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty) +private lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty) {a q : ℤ} (hSeq : S = insert a s) (hq : q ∈ s) (h1 : a ≤ q + 1) (h2 : q ≤ a + 1) : (S.max' hS - S.min' hS).toNat ≤ (s.max' hs - s.min' hs).toNat + 1 := by subst hSeq @@ -319,8 +319,8 @@ def ComputesFunInTimeAndSpace open Classical in /-- The indicator function of a language. -/ -noncomputable def indicator (l : Language Symbol) : List Symbol → List Symbol - | x => if x ∈ l then [default] else [] +noncomputable def indicator (L : Language Symbol) : List Symbol → List Symbol + | x => if x ∈ L then [default] else [] /-- A proof that a Turing machine `tm` decides a language `l` with time and space bounds. -/ def DecidesLanguageInTimeAndSpace From 3d406b75e131e3e010056ad847f9b8f380f43cdd Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 4 Jun 2026 16:37:36 +0200 Subject: [PATCH 12/51] Do not use BiTape for input. --- .../Machines/MultiTapeTuring/Basic.lean | 105 +++++++++++------- 1 file changed, 65 insertions(+), 40 deletions(-) diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index 4c5bb9d500..aa53df046d 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -88,9 +88,10 @@ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where [stateFintype : Fintype State] /-- initial state -/ q₀ : State - /-- transition function, mapping a state and a tuple of head symbols to a movement for the - input head, actions on the work tape, optionally a symbol to output and the successor state -/ - tr : State → (Fin (k + 1) → Option Symbol) → TransitionOut k Symbol State + /-- transition function, mapping a state, the current input symbol and a tuple of head symbols + to a movement for the input head, actions on the work tape, optionally a symbol to output and + the successor state -/ + tr : State → (Option Symbol) → (Fin k → Option Symbol) → TransitionOut k Symbol State namespace MultiTapeTM @@ -116,58 +117,73 @@ The configurations of a Turing machine consist of: structure Cfg : Type where /-- the state of the TM (or none for the halting state) -/ state : Option tm.State - /-- the tape contents -/ - tapes : Fin (k + 1) → BiTape Symbol + /-- the input -/ + input : List Symbol + /-- the position of the input head, shifted by one -/ + inputPos : Fin (input.length + 2) + /-- the work tape -/ + workTapes : Fin k → BiTape Symbol /-- the output so far -/ output : List Symbol deriving Inhabited -/-- Applies the actions / statements to the tapes. -The input tape is handled specially: The machine can read one empty cell outside of the input, -but any attempted movement beyond that results in no movement. -/ -def applyTapeActions - (inputMove : Option Dir) - (stmts : Fin k → Stmt Symbol) - (tapes : Fin (k + 1) → BiTape Symbol) : - Fin (k + 1) → BiTape Symbol - | ⟨0, _⟩ => match inputMove, tapes ⟨0, by omega⟩ with - | none, t => t - | some .left, t => if t.left.toList = [] ∧ t.head = none then t else t.move_left - | some .right, t => if t.right.toList = [] ∧ t.head = none then t else t.move_right - | ⟨i + 1, _⟩ => let s := stmts ⟨i, by omega⟩ - ((tapes ⟨i + 1, by omega⟩).write s.symbol).optionMove s.movement - -/-- The output of the transition function applied to a configuration. -/ -def transitionOutput : tm.Cfg → Option (TransitionOut k Symbol tm.State) - | ⟨none, _, _⟩ => none -- halting state - | ⟨some q, tapes, _⟩ => some (tm.tr q (fun i => (tapes i).head)) +/-- Attempt to move the input tape head. +The machine can only read one empty cell outside of the input, +any attempted movement beyond that results in no movement. -/ +@[scoped grind =] +def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : Option Dir) : Fin (n + 2) := + let p := (pos + optionDirToInt m).toNat + if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ + +/-- The output of the transition function applied to a state and the set of topes. -/ +def transitionOutput (q : tm.State) (inputSymbol : Option Symbol) (work : Fin k → BiTape Symbol) : + TransitionOut k Symbol tm.State := + tm.tr q inputSymbol (fun i => (work i).head) + +/-- The symbol currently under the input tape head. -/ +@[scoped grind =] +def inputSymbol (cfg : tm.Cfg) : Option Symbol := + if h₁ : cfg.inputPos = 0 then none + else if h₂ : cfg.inputPos = cfg.input.length + 1 then none + else cfg.input[cfg.inputPos.val - 1]'(by grind) + +@[simp] +lemma inputSymbolInner {cfg : tm.Cfg} (p : ℕ) + (h₁ : cfg.inputPos.val = 1 + p) + (h₂ : p < cfg.input.length) : + tm.inputSymbol cfg = some cfg.input[p] := by + simp [inputSymbol, h₁] + grind /-- The step function corresponding to a `MultiTapeTM`. -/ def step (cfg : tm.Cfg) : Option tm.Cfg := - (tm.transitionOutput cfg).map fun {inputMove, stmts, outS, q'} => - let output := match outS with + match cfg.state with + | none => none + | some q => + let {inputMove, stmts, outS, q'} := tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes + some { + state := q', + input := cfg.input, + inputPos := moveInputPos cfg.inputPos inputMove, + workTapes i := cfg.workTapes i |>.write (stmts i).symbol |>.optionMove (stmts i).movement + output := match outS with | none => cfg.output | some s => cfg.output ++ [s] - ⟨q', applyTapeActions inputMove stmts cfg.tapes, output⟩ + } /-- Any number of positive steps run from a halting configuration lead to `none`. -/ @[simp, scoped grind =] -lemma step_iter_none_eq_none (tapes : Fin (k + 1) → BiTape Symbol) (out : List Symbol) (n : ℕ) : - (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes, out⟩) = none := by +lemma step_iter_none_eq_none (cfg : tm.Cfg) (n : ℕ) (h_halt : cfg.state = none) : + (Option.bind · tm.step)^[n + 1] (some cfg) = none := by rw [Function.iterate_succ_apply] induction n with - | zero => rfl + | zero => simp [step, h_halt] | succ n ih => grind [Function.iterate_succ_apply'] -/-- A collection of tapes where the first tape contains `s` -/ -def firstTape (s : List Symbol) : Fin k → BiTape Symbol - | ⟨0, _⟩ => BiTape.mk₁ s - | ⟨_, _⟩ => default - /-- The initial configuration corresponding to a list in the input alphabet. -/ @[simp] def initCfg (s : List Symbol) : tm.Cfg := - ⟨some tm.q₀, firstTape s, []⟩ + ⟨some tm.q₀, s, 1, default, []⟩ /-- The sequence of configurations of the Turing machine starting from `cfg`. If the Turing machine halts, it will eventually get and stay `none` after reaching the halting @@ -175,6 +191,14 @@ configuration. -/ def configs (cfg : tm.Cfg) (t : ℕ) : Option tm.Cfg := (Option.bind · tm.step)^[t] cfg +lemma configs_succ' (cfg : tm.Cfg) (t : ℕ) : + tm.configs cfg (t + 1) = (Option.bind · tm.step) (tm.configs cfg t) := by + simp [configs, Function.iterate_succ_apply'] + +lemma configs_succ (cfg : tm.Cfg) (t : ℕ) : + tm.configs cfg (t + 1) = tm.configs cfg t >>= tm.step := by + simp [configs, Function.iterate_succ_apply'] + end Cfg section Space @@ -191,9 +215,10 @@ def OptionDirToInt : Option Dir → ℤ /-- The movements of the work tape heads after configuration `cfg`. -/ def headMovements (cfg : tm.Cfg) : Fin k → ℤ - | i => match tm.transitionOutput cfg with - | some tro => OptionDirToInt (tro.stmts ⟨i, by omega⟩).movement - | none => 0 + | i => match cfg.state with + | none => 0 + | some q => OptionDirToInt + (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.movement) /-- The head positions of the work tapes as a function of the number of steps, relative to the starting position in `cfg`. -/ @@ -354,7 +379,7 @@ lemma relatesInSteps_iff_step_iter_eq_some /-- The Turing machine `tm` halts after exactly `t` steps on input `input`. -/ def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool := match (tm.configs (tm.initCfg input) t) with - | some ⟨none, _, _⟩ => true + | some ⟨none, _, _, _, _⟩ => true | _ => false /-- If a Turing machine halts, the time step is uniquely determined. -/ From 6847a62c39b365a3404809394a75d286813c7bcc Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 5 Jun 2026 17:46:49 +0200 Subject: [PATCH 13/51] Make move optional. --- Cslib.lean | 1 - .../Machines/MultiTapeTuring/Basic.lean | 15 +++++----- .../Machines/SingleTapeTuring/Basic.lean | 21 ++++++++++++-- .../Computability/Machines/TuringCommon.lean | 28 ------------------- Cslib/Foundations/Data/BiTape.lean | 9 ++++++ 5 files changed, 36 insertions(+), 38 deletions(-) delete mode 100644 Cslib/Computability/Machines/TuringCommon.lean diff --git a/Cslib.lean b/Cslib.lean index 32cde3201e..7dd907cd62 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -33,7 +33,6 @@ public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Machines.MultiTapeTuring.Basic public import Cslib.Computability.Machines.SingleTapeTuring.Basic -public import Cslib.Computability.Machines.TuringCommon public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable public import Cslib.Computability.URM.Defs diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean index aa53df046d..f83bf9c47a 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -11,7 +11,6 @@ public import Mathlib.Algebra.Order.BigOperators.Group.Finset public import Mathlib.Computability.Language public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.RelatesInSteps -public import Cslib.Computability.Machines.TuringCommon /-! # Multi-Tape Turing Machines @@ -71,7 +70,7 @@ structure TransitionOut (k : ℕ) (Symbol State : Type) where /-- The movement (attempt) of the input head. -/ inputMove : Option Dir /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/ - stmts : Fin k → Stmt Symbol + stmts : Fin k → (Option (Option Symbol)) × (Option Dir) /-- An optional symbol to output. -/ outS : Option Symbol /-- The successor state or none to halt. -/ @@ -165,7 +164,9 @@ def step (cfg : tm.Cfg) : Option tm.Cfg := state := q', input := cfg.input, inputPos := moveInputPos cfg.inputPos inputMove, - workTapes i := cfg.workTapes i |>.write (stmts i).symbol |>.optionMove (stmts i).movement + workTapes i := match stmts i with + | (none, m) => cfg.workTapes i |>.optionMove m + | (some s, m) => cfg.workTapes i |>.write s |>.optionMove m output := match outS with | none => cfg.output | some s => cfg.output ++ [s] @@ -208,7 +209,7 @@ variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) /-- Convert an "optional movement" to an integer where positive is "right". -/ @[simp, grind] -def OptionDirToInt : Option Dir → ℤ +def optionDirToInt : Option Dir → ℤ | some .left => -1 | none => 0 | some .right => 1 @@ -217,8 +218,8 @@ def OptionDirToInt : Option Dir → ℤ def headMovements (cfg : tm.Cfg) : Fin k → ℤ | i => match cfg.state with | none => 0 - | some q => OptionDirToInt - (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.movement) + | some q => optionDirToInt + (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.2) /-- The head positions of the work tapes as a function of the number of steps, relative to the starting position in `cfg`. -/ @@ -250,7 +251,7 @@ lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) : @[scoped grind .] lemma OptionDirToInt_bound (d : Option Dir) : - -1 ≤ OptionDirToInt d ∧ OptionDirToInt d ≤ 1 := by + -1 ≤ optionDirToInt d ∧ optionDirToInt d ≤ 1 := by rcases d with _ | d · decide · rcases d <;> decide diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean index 80d5d13181..debad7d43f 100644 --- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean @@ -9,7 +9,6 @@ module public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.RelatesInSteps public import Mathlib.Algebra.Polynomial.Eval.Defs -public import Cslib.Computability.Machines.TuringCommon /-! # Single-Tape Turing Machines @@ -43,6 +42,7 @@ for convenience in composition of machines. We define a number of structures related to Turing machine computation: +* `Stmt`: the write and movement operations a TM can do in a single step. * `SingleTapeTM`: the TM itself. * `Cfg`: the configuration of a TM, including internal and tape state. * `TimeComputable f`: a TM for computing `f`, packaged with a bound on runtime. @@ -70,6 +70,21 @@ open BiTape StackTape variable {Symbol : Type} +namespace SingleTapeTM + +/-- +A Turing machine "statement" is just a `Option`al command to move left or right, +and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape` +-/ +structure Stmt (Symbol : Type) where + /-- The symbol to write at the current head position -/ + symbol : Option Symbol + /-- The direction to move the tape head -/ + movement : Option Dir +deriving Inhabited + +end SingleTapeTM + /-- A single-tape Turing machine over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol). @@ -83,7 +98,7 @@ structure SingleTapeTM Symbol [Inhabited Symbol] [Fintype Symbol] where (q₀ : State) /-- Transition function, mapping a state and a head symbol to a `Stmt` to invoke, and optionally the new state to transition to afterwards (`none` for halt) -/ - (tr : State → Option Symbol → Stmt Symbol × Option State) + (tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State) namespace SingleTapeTM @@ -103,6 +118,8 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩ instance : Fintype tm.State := tm.stateFintype +instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance + /-- The configurations of a Turing machine consist of: an `Option`al state (or none for the halting state), diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean deleted file mode 100644 index 60d0636639..0000000000 --- a/Cslib/Computability/Machines/TuringCommon.lean +++ /dev/null @@ -1,28 +0,0 @@ -/- -Copyright (c) 2026 Bolton Bailey. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Bolton Bailey, Pim Spelier, Daan van Gent --/ - -module - -public import Mathlib.Computability.TuringMachine.Tape - -@[expose] public section - -namespace Turing - -/-- -A Turing machine "statement" is just a `Option`al command to move left or right, -and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape` --/ -structure Stmt (Symbol : Type) where - /-- The symbol to write at the current head position -/ - symbol : Option Symbol - /-- The direction to move the tape head -/ - movement : Option Dir -deriving Inhabited - -instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance - -end Turing diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean index e61272d57d..7df3d2e736 100644 --- a/Cslib/Foundations/Data/BiTape.lean +++ b/Cslib/Foundations/Data/BiTape.lean @@ -114,6 +114,15 @@ lemma moveLeft_moveRight (t : BiTape Symbol) : t.moveLeft.moveRight = t := by lemma moveRight_moveLeft (t : BiTape Symbol) : t.moveRight.moveLeft = t := by simp [moveLeft, moveRight] +/-- Translate an optional direction into a head movement offset, where the positive +direction is to the right. -/ +@[scoped grind =] +def optionDirToInt (d : Option Dir) : ℤ := + match d with + | none => 0 + | some .left => -1 + | some .right => 1 + end Move /-- From 82e06e3846a9167e411415b3ce952ffa7fd8d236 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Wed, 10 Jun 2026 14:00:01 +0200 Subject: [PATCH 14/51] feat(Governance): Add new area maintainers for algorithms and logic (#610) Adds new area maintainers for algorithms and logic, resp. @sorrachai and @arademaker. --------- Co-authored-by: Alexandre Rademaker --- .github/CODEOWNERS | 3 +++ GOVERNANCE.md | 6 ++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index fefafe3e50..5f565a3a11 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -12,6 +12,9 @@ ### Area access # Each area maintainer has access to parts that pertain them. They get automatically asked for # reviewing new PRs that touch those areas. +/Cslib/Algorithms/ @sorrachai +/Cslib/Foundations/Logic/ @arademaker @fmontesi +/Cslib/Logics/ @arademaker @fmontesi /Cslib/Languages/LambdaCalculus/ @chenson2018 /.github/workflows @kim-em @fmontesi @chenson2018 /scripts @kim-em @fmontesi @chenson2018 diff --git a/GOVERNANCE.md b/GOVERNANCE.md index 200340c6e7..8ffbf3d3ca 100644 --- a/GOVERNANCE.md +++ b/GOVERNANCE.md @@ -23,7 +23,7 @@ The maintainer team is responsible for the quality of the codebase, establishing ### Lead maintainer -The lead maintainer coordinates the overall work of the maintainer team and oversees the project's repositories. +The lead maintainer coordinates the maintainer team's overall work and oversees the project's repositories. - Fabrizio Montesi (@fmontesi), FORM, University of Southern Denmark and Danish Institute for Advanced Study. @@ -31,7 +31,7 @@ The lead maintainer coordinates the overall work of the maintainer team and over Technical leads guide long-term developments that may span multiple areas of the codebase, offering specialised expertise. -- Alexandre Rademaker (@arademaker), Atlas Computing and Getulio Vargas Foundation. +- Alexandre Rademaker (@arademaker), Renaissance Philanthropy and Getulio Vargas Foundation. - Sorrachai Yingchareonthawornchai (@sorrachai), ETH Zurich. ### Area maintainers @@ -40,6 +40,8 @@ Area maintainers are trusted contributors who take ownership of specific areas o - Chris Henson (@chenson2018), Drexel University. Areas: Lambda calculus, metaprogramming. - Kim Morrison (@kim-em), Lean FRO. Areas: Continuous Integration and Deployment (CI/CD) with upstream (Lean, mathlib). +- Alexandre Rademaker (@arademaker), Atlas Computing and Getulio Vargas Foundation. Areas: logic. +- Sorrachai Yingchareonthawornchai (@sorrachai), ETH Zurich. Areas: algorithms and data structures. ### Reviewers From b9d8076d0eee6bb2f8ec54db60b36280bfd8b2b4 Mon Sep 17 00:00:00 2001 From: thomaskwaring <51426330+thomaskwaring@users.noreply.github.com> Date: Wed, 10 Jun 2026 13:59:06 +0200 Subject: [PATCH 15/51] chore(Semantics/LTS/Bisimulation): golf and simplify (#613) Some of the arguments in `Bisimulation` can be simplified by symmetry and use of API lemmas. --------- Co-authored-by: twwar --- .../Semantics/LTS/Bisimulation.lean | 693 ++++-------------- Cslib/Foundations/Semantics/LTS/HasTau.lean | 3 + .../Foundations/Semantics/LTS/Simulation.lean | 59 +- Cslib/Foundations/Semantics/LTS/TraceEq.lean | 4 + Cslib/Languages/CCS/BehaviouralTheory.lean | 16 +- Cslib/Logics/HML/Basic.lean | 2 +- CslibTests/GrindLint.lean | 6 +- 7 files changed, 217 insertions(+), 566 deletions(-) diff --git a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean index 21ffd67eb5..a33aad0780 100644 --- a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean @@ -1,13 +1,12 @@ /- Copyright (c) 2025 Fabrizio Montesi. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Fabrizio Montesi +Authors: Fabrizio Montesi, Thomas Waring -/ module public import Cslib.Foundations.Data.Relation -public import Cslib.Foundations.Semantics.LTS.HasTau public import Cslib.Foundations.Semantics.LTS.Simulation public import Cslib.Foundations.Semantics.LTS.TraceEq @@ -51,7 +50,7 @@ we prove to be sound and complete. - `LTS.IsBisimulation.inv`: the inverse of a bisimulation is a bisimulation. - `Bisimilarity.eqv`: bisimilarity is an equivalence relation (see `Equivalence`). - `Bisimilarity.isBisimulation`: bisimilarity is itself a bisimulation. -- `Bisimilarity.largest_bisimulation`: bisimilarity is the largest bisimulation. +- `IsBisimulation.le_bisimilarity`: bisimilarity is the largest bisimulation. - `Bisimilarity.gfp`: the union of bisimilarity and any bisimulation is equal to bisimilarity. - `LTS.IsBisimulationUpTo.isBisimulation`: any bisimulation up to bisimilarity is a bisimulation. - `LTS.IsBisimulation.traceEq`: any bisimulation that relates two states implies that they are @@ -68,12 +67,13 @@ equivalence coincide. namespace Cslib.LTS +variable {State₁ State₂ Label : Type*} {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} + section Bisimulation /-- A relation is a bisimulation if, whenever it relates two states, the transitions originating from these states mimic each other and the reached derivatives are themselves related. -/ -@[scoped grind =] def IsBisimulation (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) (r : State₁ → State₂ → Prop) : Prop := ∀ ⦃s₁ s₂⦄, r s₁ s₂ → ∀ μ, ( @@ -82,9 +82,6 @@ def IsBisimulation (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) (∀ s₂', lts₂.Tr s₂ μ s₂' → ∃ s₁', lts₁.Tr s₁ μ s₁' ∧ r s₁' s₂') ) -/-- A homogeneous bisimulation is a bisimulation where the underlying LTSs are the same. -/ -abbrev IsHomBisimulation (lts : LTS State Label) := IsBisimulation lts lts - /-- Helper for following a transition by the first state in a pair of a `Bisimulation`. -/ theorem IsBisimulation.follow_fst (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) (htr : lts₁.Tr s₁ μ s₁') : @@ -97,6 +94,21 @@ theorem IsBisimulation.follow_snd ∃ s₁', lts₁.Tr s₁ μ s₁' ∧ r s₁' s₂' := (hb hr μ).2 _ htr +/-! ## Relation to simulation -/ + +/-- Any bisimulation is also a simulation. -/ +theorem IsBisimulation.isSimulation : IsBisimulation lts₁ lts₂ r → IsSimulation lts₁ lts₂ r := by + grind [IsBisimulation, IsSimulation] + +/-- A relation is a bisimulation iff both it and its inverse are simulations. -/ +theorem IsBisimulation.isSimulation_iff : + IsBisimulation lts₁ lts₂ r ↔ (IsSimulation lts₁ lts₂ r ∧ IsSimulation lts₂ lts₁ (flip r)) := by + have _ (s₁ s₂) : r s₁ s₂ → flip r s₂ s₁ := id + grind [IsBisimulation, IsSimulation, flip] + +/-- A homogeneous bisimulation is a bisimulation where the underlying LTSs are the same. -/ +abbrev IsHomBisimulation (lts : LTS State Label) := IsBisimulation lts lts + /-- Two states are bisimilar if they are related by some bisimulation. -/ @[scoped grind =] def Bisimilarity (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) : State₁ → State₂ → Prop := @@ -116,28 +128,37 @@ abbrev HomBisimilarity (lts : LTS State Label) := Bisimilarity lts lts /-- Notation for homogeneous bisimilarity. -/ scoped notation s:max " ~[" lts "] " s':max => HomBisimilarity lts s s' +/-- Helper for following a transition by the first state in a pair of a `Bisimilarity`. -/ +theorem Bisimilarity.follow_fst (hr : s₁ ~[lts₁,lts₂] s₂) (htr : lts₁.Tr s₁ μ s₁') : + ∃ s₂', lts₂.Tr s₂ μ s₂' ∧ s₁' ~[lts₁,lts₂ ] s₂' := by grind [IsBisimulation] + +/-- Helper for following a transition by the first state in a pair of a `Bisimilarity`. -/ +theorem Bisimilarity.follow_snd (hr : s₁ ~[lts₁,lts₂] s₂) (htr : lts₂.Tr s₂ μ s₂') : + ∃ s₁', lts₁.Tr s₁ μ s₁' ∧ s₁' ~[lts₁,lts₂] s₂' := by grind [IsBisimulation] + /-- Homogeneous bisimilarity is reflexive. -/ @[scoped grind ., refl] theorem HomBisimilarity.refl (s : State) : s ~[lts] s := by exists Eq - grind + grind [IsBisimulation] /-- The inverse of a bisimulation is a bisimulation. -/ @[scoped grind →] theorem IsBisimulation.inv (h : IsBisimulation lts₁ lts₂ r) : - IsBisimulation lts₂ lts₁ (flip r) := by grind [flip] + IsBisimulation lts₂ lts₁ (flip r) := by grind [IsBisimulation, flip] open scoped IsBisimulation in /-- Bisimilarity is symmetric. -/ @[scoped grind →, symm] -theorem Bisimilarity.symm {s₁ s₂ : State} (h : s₁ ~[lts₁,lts₂] s₂) : s₂ ~[lts₂,lts₁] s₁ := by +theorem Bisimilarity.symm {lts₁ lts₂ : LTS State Label} {s₁ s₂ : State} + (h : s₁ ~[lts₁,lts₂] s₂) : s₂ ~[lts₂,lts₁] s₁ := by grind [flip] /-- The composition of two bisimulations is a bisimulation. -/ @[scoped grind .] theorem IsBisimulation.comp (h1 : IsBisimulation lts₁ lts₂ r1) (h2 : IsBisimulation lts₂ lts₃ r2) : - IsBisimulation lts₁ lts₃ (Relation.Comp r1 r2) := by grind [Relation.Comp] + IsBisimulation lts₁ lts₃ (Relation.Comp r1 r2) := by grind [IsBisimulation, Relation.Comp] /-- Bisimilarity is transitive. -/ @[scoped grind →] @@ -147,7 +168,7 @@ theorem Bisimilarity.trans obtain ⟨r1, _, _⟩ := h1 obtain ⟨r2, _, _⟩ := h2 exists Relation.Comp r1 r2 - grind [Relation.Comp] + grind [IsBisimulation, Relation.Comp] /-- Homogeneous bisimilarity is an equivalence relation. -/ theorem HomBisimilarity.eqv : @@ -165,64 +186,27 @@ instance : IsEquiv State (HomBisimilarity lts) where /-- The union of two bisimulations is a bisimulation. -/ @[scoped grind .] theorem IsBisimulation.sup (hrb : IsBisimulation lts₁ lts₂ r) (hsb : IsBisimulation lts₁ lts₂ s) : - IsBisimulation lts₁ lts₂ (r ⊔ s) := by - intro s₁ s₂ hrs μ - cases hrs - case inl h => - constructor - · intro s₁' htr - obtain ⟨s₂', htr', hr'⟩ := hrb.follow_fst h htr - exists s₂' - constructor - · assumption - · simp only [max, SemilatticeSup.sup] - left - exact hr' - · intro s₂' htr - obtain ⟨s₁', htr', hr'⟩ := hrb.follow_snd h htr - exists s₁' - constructor - · assumption - · simp only [max, SemilatticeSup.sup] - left - exact hr' - case inr h => - constructor - · intro s₁' htr - obtain ⟨s₂', htr', hs'⟩ := hsb.follow_fst h htr - exists s₂' - constructor - · assumption - · simp only [max, SemilatticeSup.sup] - right - exact hs' - · intro s₂' htr - obtain ⟨s₁', htr', hs'⟩ := hsb.follow_snd h htr - exists s₁' - constructor - · assumption - · simp only [max, SemilatticeSup.sup] - right - exact hs' + IsBisimulation lts₁ lts₂ (r ⊔ s) := by + rw [IsBisimulation.isSimulation_iff] at hrb hsb ⊢ + rw [show flip (r ⊔ s) = flip r ⊔ flip s by ext; rfl] + exact ⟨hrb.1.sup hsb.1, hrb.2.sup hsb.2⟩ /-- Bisimilarity is a bisimulation. -/ @[scoped grind .] -theorem Bisimilarity.is_bisimulation : IsBisimulation lts₁ lts₂ (Bisimilarity lts₁ lts₂) := by grind +theorem Bisimilarity.isBisimulation (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) : + IsBisimulation lts₁ lts₂ (Bisimilarity lts₁ lts₂) := by grind [IsBisimulation] /-- Bisimilarity is the largest bisimulation. -/ @[scoped grind →] -theorem Bisimilarity.largest_bisimulation (h : IsBisimulation lts₁ lts₂ r) : - Subrelation r (Bisimilarity lts₁ lts₂) := by +theorem IsBisimulation.le_bisimilarity (h : IsBisimulation lts₁ lts₂ r) : + r ≤ (Bisimilarity lts₁ lts₂) := by intro s₁ s₂ hr exists r /-- The union of bisimilarity with any bisimulation is bisimilarity. -/ @[scoped grind =, simp] theorem Bisimilarity.gfp (r : State₁ → State₂ → Prop) (h : IsBisimulation lts₁ lts₂ r) : - (Bisimilarity lts₁ lts₂) ⊔ r = Bisimilarity lts₁ lts₂ := by - funext s₁ s₂ - simp only [max, SemilatticeSup.sup] - grind + (Bisimilarity lts₁ lts₂) ⊔ r = Bisimilarity lts₁ lts₂ := sup_eq_left.mpr h.le_bisimilarity /-- `calc` support for bisimilarity. -/ instance : Trans (Bisimilarity lts₁ lts₂) (Bisimilarity lts₂ lts₃) (Bisimilarity lts₁ lts₃) where @@ -235,30 +219,15 @@ section Order instance : Max {r // IsBisimulation lts₁ lts₂ r} where max r s := ⟨r.1 ⊔ s.1, IsBisimulation.sup r.2 s.2⟩ +@[simp] lemma coe_sup (r s : {r // IsBisimulation lts₁ lts₂ r}) : + (↑(r ⊔ s) : State₁ → State₂ → Prop) = (r : State₁ → State₂ → Prop) ⊔ s := rfl + /-- Bisimulations equipped with union form a join-semilattice. -/ instance : SemilatticeSup {r // IsBisimulation lts₁ lts₂ r} where sup r s := r ⊔ s - le_sup_left r s := by - simp only [LE.le] - intro s₁ s₂ hr - simp only [max, SemilatticeSup.sup] - left - exact hr - le_sup_right r s := by - simp only [LE.le] - intro s₁ s₂ hs - simp only [max, SemilatticeSup.sup] - right - exact hs - sup_le r s t := by - intro h1 h2 - simp only [LE.le, max, SemilatticeSup.sup] - intro s₁ s₂ h - cases h - case inl h => - apply h1 _ _ h - case inr h => - apply h2 _ _ h + le_sup_left r s := by simp [←Subtype.coe_le_coe] + le_sup_right r s := by simp [←Subtype.coe_le_coe] + sup_le r s t := by simp [←Subtype.coe_le_coe]; tauto /-- The empty (heterogeneous) relation is a bisimulation. -/ @[scoped grind .] @@ -270,7 +239,7 @@ instance : Bot {r // IsBisimulation lts₁ lts₂ r} := ⟨Relation.emptyHRelation, IsBisimulation.bot⟩ instance : Top {r // IsBisimulation lts₁ lts₂ r} := - ⟨Bisimilarity lts₁ lts₂, Bisimilarity.is_bisimulation⟩ + ⟨Bisimilarity lts₁ lts₂, Bisimilarity.isBisimulation ..⟩ /-- In the inclusion order on bisimulations: @@ -280,15 +249,8 @@ instance : Top {r // IsBisimulation lts₁ lts₂ r} := instance : BoundedOrder {r // IsBisimulation lts₁ lts₂ r} where top := ⊤ bot := ⊥ - le_top r := by - intro s₁ s₂ - simp only [LE.le, Top.top] - grind - bot_le r := by - intro s₁ s₂ - simp only [LE.le] - intro hr - cases hr + le_top r := r.property.le_bisimilarity + bot_le r := by simp [Bot.bot, LE.le] end Order @@ -302,7 +264,6 @@ def UpToHomBisimilarity (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Lab /-- A relation `r` is a bisimulation up to homogeneous bisimilarity if, whenever it relates two states in an lts, the transitions originating from these states mimic each other and the reached derivatives are themselves related by `r` up to bisimilarity. -/ -@[scoped grind] def IsBisimulationUpTo (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) (r : State₁ → State₂ → Prop) : Prop := ∀ ⦃s₁ s₂⦄, r s₁ s₂ → ∀ μ, ( @@ -315,86 +276,36 @@ def IsBisimulationUpTo (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Labe /-- Any bisimulation up to bisimilarity is a bisimulation. -/ @[scoped grind →] -theorem IsBisimulationUpTo.is_bisimulation (h : IsBisimulationUpTo lts₁ lts₂ r) : - IsBisimulation lts₁ lts₂ (UpToHomBisimilarity lts₁ lts₂ r) := by +theorem IsBisimulationUpTo.isBisimulation (h : IsBisimulationUpTo lts₁ lts₂ r) : + IsBisimulation lts₁ lts₂ (UpToHomBisimilarity lts₁ lts₂ r) := by intro s₁ s₂ hr μ rcases hr with ⟨s₁b, hr1b, s₂b, hrb, hr2b⟩ - obtain ⟨r1, hr1, hr1b⟩ := hr1b - obtain ⟨r2, hr2, hr2b⟩ := hr2b constructor case left => intro s₁' htr1 - obtain ⟨s₁b', hs₁b'tr, hs₁b'r⟩ := (hr1b hr1 μ).1 s₁' htr1 + obtain ⟨s₁b', hs₁b'tr, hs₁b'r⟩ := hr1b.follow_fst htr1 obtain ⟨s₂b', hs₂b'tr, hs₂b'r⟩ := (h hrb μ).1 s₁b' hs₁b'tr - obtain ⟨s₂', hs₂btr, hs₂br⟩ := (hr2b hr2 μ).1 _ hs₂b'tr - exists s₂' - constructor - case left => - exact hs₂btr - case right => - obtain ⟨smid1, hsmidb, smid2, hsmidr, hsmidrb⟩ := hs₂b'r - constructor - constructor - · apply Bisimilarity.trans (Bisimilarity.largest_bisimulation hr1b hs₁b'r) - hsmidb - · exists smid2 - constructor - · exact hsmidr - · apply Bisimilarity.trans hsmidrb - apply Bisimilarity.largest_bisimulation hr2b hs₂br + obtain ⟨s₂', hs₂btr, hs₂br⟩ := hr2b.follow_fst hs₂b'tr + use s₂', hs₂btr + obtain ⟨smid1, hsmidb, smid2, hsmidr, hsmidrb⟩ := hs₂b'r + use smid1, hs₁b'r.trans hsmidb, smid2, hsmidr + exact hsmidrb.trans hs₂br case right => intro s₂' htr2 - obtain ⟨s₂b', hs₂b'tr, hs₂b'r⟩ := (hr2b hr2 μ).2 s₂' htr2 + obtain ⟨s₂b', hs₂b'tr, hs₂b'r⟩ := hr2b.follow_snd htr2 obtain ⟨s₁b', hs₁b'tr, hs₁b'r⟩ := (h hrb μ).2 s₂b' hs₂b'tr - obtain ⟨s₁', hs₁btr, hs₁br⟩ := (hr1b hr1 μ).2 _ hs₁b'tr - exists s₁' - constructor - case left => - exact hs₁btr - case right => - obtain ⟨smid1, hsmidb, smid2, hsmidr, hsmidrb⟩ := hs₁b'r - constructor - constructor - · apply Bisimilarity.trans (Bisimilarity.largest_bisimulation hr1b _) hsmidb - · exact hs₁br - · exists smid2 - constructor - · exact hsmidr - · apply Bisimilarity.trans hsmidrb - apply Bisimilarity.largest_bisimulation hr2b _ - exact hs₂b'r + obtain ⟨s₁', hs₁btr, hs₁br⟩ := hr1b.follow_snd hs₁b'tr + use s₁', hs₁btr + obtain ⟨smid1, hsmidb, smid2, hsmidr, hsmidrb⟩ := hs₁b'r + use smid1, hs₁br.trans hsmidb, smid2, hsmidr + exact hsmidrb.trans hs₂b'r /-- If two states are related by a bisimulation, they can mimic each other's multi-step transitions. -/ theorem IsBisimulation.bisim_trace (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : - ∀ μs s₁', lts₁.MTr s₁ μs s₁' → ∃ s₂', lts₂.MTr s₂ μs s₂' ∧ r s₁' s₂' := by - intro μs - induction μs generalizing s₁ s₂ - case nil => - intro s₁' hmtr1 - exists s₂ - cases hmtr1 - constructor - constructor - exact hr - case cons μ μs' ih => - intro s₁' hmtr1 - cases hmtr1 - case stepL s₁'' htr hmtr => - specialize hb hr μ - have hf := hb.1 s₁'' htr - obtain ⟨s₂'', htr2, hb2⟩ := hf - specialize ih hb2 s₁' hmtr - obtain ⟨s₂', hmtr2, hr'⟩ := ih - exists s₂' - constructor - case left => - constructor - · exact htr2 - · exact hmtr2 - case right => - exact hr' + ∀ μs s₁', lts₁.MTr s₁ μs s₁' → ∃ s₂', lts₂.MTr s₂ μs s₂' ∧ r s₁' s₂' := + hb.isSimulation.sim_trace hr /-! ## Relation to trace equivalence -/ @@ -403,21 +314,18 @@ theorem IsBisimulation.bisim_trace theorem IsBisimulation.traceEq (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : s₁ ~tr[lts₁,lts₂] s₂ := by - funext μs - simp only [eq_iff_iff] + ext μs constructor case mp => intro h obtain ⟨s₁', h⟩ := h obtain ⟨s₂', hmtr⟩ := IsBisimulation.bisim_trace hb hr μs s₁' h - exists s₂' - exact hmtr.1 + use s₂', hmtr.1 case mpr => intro h obtain ⟨s₂', h⟩ := h obtain ⟨s₁', hmtr⟩ := IsBisimulation.bisim_trace hb.inv hr μs s₂' h - exists s₁' - exact hmtr.1 + use s₁', hmtr.1 /-- Bisimilarity is included in trace equivalence. -/ @[scoped grind .] @@ -444,303 +352,67 @@ example `Bisimulation.deterministic_trace_eq_is_bisim`). -/ theorem IsBisimulation.traceEq_not_bisim : ∃ (State : Type) (Label : Type) (lts : LTS State Label), ¬(IsHomBisimulation lts (HomTraceEq lts)) := by - exists ℕ - exists Char let lts := LTS.mk BisimMotTr - exists lts + exists ℕ, Char, lts intro h - -- specialize h 1 5 have htreq : (1 ~tr[lts] 5) := by - simp [TraceEq] have htraces₁ : lts.traces 1 = {[], ['a'], ['a', 'b'], ['a', 'c']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro + ext μs + constructor case mp => - intro h1 - obtain ⟨s', htr⟩ := h1 - cases htr - case refl => - simp - case stepL μ sb μs' htr hmtr => - cases htr - cases hmtr - case one2two.stepL μ sb μs' htr hmtr => - cases htr <;> cases hmtr <;> - simp only [↓Char.isValue, Set.mem_insert_iff, reduceCtorEq, List.cons.injEq, - List.cons_ne_self, and_false, Set.mem_singleton_iff, Char.reduceEq, and_true, - or_false, or_true] <;> - contradiction - simp + rintro ⟨_, (_ | ⟨⟨_⟩, (_ | ⟨(_ | _), (_ | ⟨⟨_⟩, _⟩)⟩)⟩)⟩ + all_goals simp case mpr => - intro h1 - cases h1 - case inl h1 => - simp only [h1] - exists 1 - constructor - case inr h1 => - cases h1 - case inl h1 => - simp only [h1] - exists 2 - apply MTr.single; constructor - case inr h1 => - cases h1 - case inl h1 => - simp only [h1] - exists 3 - constructor - · apply BisimMotTr.one2two - · apply MTr.single - apply BisimMotTr.two2three - case inr h1 => - cases h1 - exists 4 - constructor - · apply BisimMotTr.one2two - · apply MTr.single - apply BisimMotTr.two2four - have htraces₂ : lts.traces 5 = {[], ['a'], ['a', 'b'], ['a', 'c']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro + rintro (rfl | rfl | rfl | rfl) + · exact ⟨1, .refl⟩ + · exact ⟨2, MTr.single lts .one2two⟩ + · exact ⟨3, MTr.stepL .one2two <| MTr.single lts .two2three⟩ + · exact ⟨4, MTr.stepL .one2two <| MTr.single lts .two2four⟩ + have htraces₅ : lts.traces 5 = {[], ['a'], ['a', 'b'], ['a', 'c']} := by + ext μs + constructor case mp => - intro h1 - obtain ⟨s', htr⟩ := h1 - cases htr - case refl => - simp - case stepL μ sb μs' htr hmtr => - cases htr - case five2six => - cases hmtr - case refl => - simp - case stepL μ sb μs' htr hmtr => - cases htr - cases hmtr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - case five2eight => - cases hmtr - case refl => - simp - case stepL μ sb μs' htr hmtr => - cases htr - cases hmtr - case refl => right; right; simp - case stepL μ sb μs' htr hmtr => - cases htr + rintro ⟨_, (_ | ⟨(_ | _), (_ | ⟨⟨_⟩, (_ | ⟨⟨_⟩, _⟩)⟩)⟩)⟩ + all_goals simp case mpr => - intro h1 - cases h1 - case inl h1 => - simp only [h1] - exists 5 - constructor - case inr h1 => - cases h1 - case inl h1 => - simp only [h1] - exists 6 - apply MTr.single; constructor - case inr h1 => - cases h1 - case inl h1 => - simp only [h1] - exists 7 - constructor - · apply BisimMotTr.five2six - · apply MTr.single - apply BisimMotTr.six2seven - case inr h1 => - cases h1 - exists 9 - constructor - · apply BisimMotTr.five2eight - · apply MTr.single; - apply BisimMotTr.eight2nine - simp [htraces₁, htraces₂] - specialize h htreq - specialize h 'a' - obtain ⟨h1, h2⟩ := h - specialize h1 2 (by constructor) - obtain ⟨s₂', htr5, cih⟩ := h1 + rintro (rfl | rfl | rfl | rfl) + · exact ⟨5, .refl⟩ + · exact ⟨6, MTr.single lts .five2six⟩ + · exact ⟨7, MTr.stepL .five2six <| MTr.single lts .six2seven⟩ + · exact ⟨9, MTr.stepL .five2eight <| MTr.single lts .eight2nine⟩ + exact htraces₁.trans htraces₅.symm + obtain ⟨h1, h2⟩ := h htreq 'a' + obtain ⟨s₂', htr5, cih⟩ := h1 2 (by constructor) + have htraces₂ : {['b'], ['c']} ⊆ lts.traces 2 := by + intro μs h + rcases h with (rfl | rfl) + · refine ⟨3, MTr.single lts .two2three⟩ + · refine ⟨4, MTr.single lts .two2four⟩ cases htr5 case five2six => - simp [TraceEq] at cih - have htraces₂ : lts.traces 2 = {[], ['b'], ['c']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro - case mp => - intro h - obtain ⟨s', htr⟩ := h - cases htr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - case two2three => - cases hmtr - case stepL μ sb μs' htr hmtr => cases htr - simp - case two2four => - cases hmtr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - case mpr => - intro h - cases h - case inl h => - exists 2 - simp [h] - constructor - case inr h => - cases h - case inl h => - exists 3; simp [h]; constructor; constructor; constructor - case inr h => - exists 4 - simp at h - simp [h] - constructor; constructor; constructor - have htraces6 : lts.traces 6 = {[], ['b']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro - case mp => - intro h - obtain ⟨s', htr⟩ := h - cases htr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - cases hmtr - case stepL μ sb μs' htr hmtr => cases htr - simp - case mpr => - intro h - cases h - case inl h => - exists 6 - simp [h] - constructor - case inr h => - exists 7 - simp at h - simp [h] - constructor; constructor; constructor - grind + suffices ['c'] ∉ lts.traces 6 by grind [TraceEq] + rintro ⟨_, (_ | h)⟩ + cases h case five2eight => - simp only [TraceEq] at cih - have htraces₂ : lts.traces 2 = {[], ['b'], ['c']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro - case mp => - intro h - obtain ⟨s', htr⟩ := h - cases htr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - case two2three => - cases hmtr - case stepL μ sb μs' htr hmtr => cases htr - simp - case two2four => - cases hmtr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - case mpr => - intro h - cases h - case inl h => - exists 2 - simp [h] - constructor - case inr h => - cases h - case inl h => - exists 3; simp [h]; constructor; constructor; constructor - case inr h => - exists 4 - simp at h - simp [h] - constructor; constructor; constructor - have htraces8 : lts.traces 8 = {[], ['c']} := by - apply Set.ext_iff.2 - intro μs - apply Iff.intro - case mp => - intro h - obtain ⟨s', htr⟩ := h - cases htr - case refl => simp - case stepL μ sb μs' htr hmtr => - cases htr - cases hmtr - case stepL μ sb μs' htr hmtr => cases htr - simp - case mpr => - intro h - cases h - case inl h => - exists 8 - simp [h] - constructor - case inr h => - exists 9 - simp at h - simp [h] - repeat constructor - rw [htraces₂, htraces8] at cih - apply Set.ext_iff.1 at cih - specialize cih ['b'] - obtain ⟨cih1, cih2⟩ := cih - have cih1h : ['b'] ∈ @insert - (List Char) (Set (List Char)) Set.instInsert [] {['b'], ['c']} := by - simp - specialize cih1 cih1h - simp at cih1 + suffices ['b'] ∉ lts.traces 8 by grind [TraceEq] + rintro ⟨_, (_ | h)⟩ + cases h /-- In general, bisimilarity and trace equivalence are distinct. -/ theorem Bisimilarity.bisimilarity_neq_traceEq : ∃ (State : Type) (Label : Type) (lts : LTS State Label), HomBisimilarity lts ≠ HomTraceEq lts := by obtain ⟨State, Label, lts, h⟩ := IsBisimulation.traceEq_not_bisim - exists State; exists Label; exists lts - intro heq - have hb := Bisimilarity.is_bisimulation (lts₁ := lts) (lts₂ := lts) - simp only [HomBisimilarity] at heq - rw [heq] at hb - contradiction + use State, Label, lts + grind [Bisimilarity.isBisimulation lts lts] /-- In any deterministic LTS, trace equivalence is a bisimulation. -/ theorem IsBisimulation.deterministic_traceEq_isBisimulation {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} [lts₁.Deterministic] [lts₂.Deterministic] : (IsBisimulation lts₁ lts₂ (TraceEq lts₁ lts₂)) := by - simp only [IsBisimulation] - intro s₁ s₂ hteq μ - constructor - case left => - apply TraceEq.deterministic_isSimulation s₁ s₂ hteq - case right => - intro s₂' htr - apply TraceEq.symm at hteq - have h := TraceEq.deterministic_isSimulation s₂ s₁ hteq μ s₂' htr - obtain ⟨s₁', h⟩ := h - exists s₁' - constructor - case left => - exact h.1 - case right => - apply h.2.symm + rw [IsBisimulation.isSimulation_iff, TraceEq.flip_eq] + exact ⟨TraceEq.deterministic_isSimulation, TraceEq.deterministic_isSimulation⟩ /-- In deterministic LTSs, trace equivalence implies bisimilarity. -/ theorem Bisimilarity.deterministic_traceEq_bisim {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} @@ -765,35 +437,19 @@ theorem Bisimilarity.deterministic_bisim_eq_traceEq case mpr => apply Bisimilarity.deterministic_traceEq_bisim -/-! ## Relation to simulation -/ - -/-- Any bisimulation is also a simulation. -/ -theorem IsBisimulation.isSimulation : IsBisimulation lts₁ lts₂ r → IsSimulation lts₁ lts₂ r := by - grind [IsSimulation] - -/-- A relation is a bisimulation iff both it and its inverse are simulations. -/ -theorem IsBisimulation.isSimulation_iff : - IsBisimulation lts₁ lts₂ r ↔ (IsSimulation lts₁ lts₂ r ∧ IsSimulation lts₂ lts₁ (flip r)) := by - have _ (s₁ s₂) : r s₁ s₂ → flip r s₂ s₁ := id - grind [IsSimulation, flip] - -set_option linter.tacticAnalysis.verifyGrindOnly false in /-- Homogeneous bisimilarity can also be characterized through symmetric simulations. -/ theorem HomBisimilarity.symm_simulation : HomBisimilarity lts = fun s₁ s₂ => ∃ r, r s₁ s₂ ∧ Std.Symm r ∧ IsHomSimulation lts r := by - funext s₁ s₂ - apply Iff.eq - apply Iff.intro + ext s₁ s₂ + constructor · intro h - have bisim : HomBisimilarity lts s₁ s₂ ∧ Std.Symm (HomBisimilarity lts) - ∧ IsHomSimulation lts (HomBisimilarity lts) := by - grind [Std.Symm, Bisimilarity.symm, IsBisimulation.isSimulation] - grind - · intro ⟨r, hr, hsymm, hsim⟩ - have : r = (flip r) := by grind only [flip, Std.Symm] - have : IsHomBisimulation lts r := by grind [IsBisimulation.isSimulation_iff] - grind + use lts.HomBisimilarity, h + exact ⟨⟨fun _ _ => Bisimilarity.symm⟩, (Bisimilarity.isBisimulation lts lts).isSimulation⟩ + · intro ⟨r, hrel, ⟨hsymm⟩, hsim⟩ + use r, hrel + have : r = flip r := by grind [flip] + simpa [IsBisimulation.isSimulation_iff, ←this] end Bisimulation @@ -836,47 +492,22 @@ def IsSWBisimulation [HasTau Label] (lts₁ : LTS State₁ Label) (lts₂ : LTS (∀ s₂', lts₂.Tr s₂ μ s₂' → ∃ s₁', lts₁.STr s₁ μ s₁' ∧ r s₁' s₂') ) -/-- Utility theorem for 'following' internal transitions using an `SWBisimulation` -(first component). -/ -theorem IsSWBisimulation.follow_internal_fst - [HasTau Label] {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} - (hswb : IsSWBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) (hstr : lts₁.τSTr s₁ s₁') : - ∃ s₂', lts₂.τSTr s₂ s₂' ∧ r s₁' s₂' := by - induction hstr - case refl => - exists s₂ - constructor; constructor - exact hr - case tail sb hrsb htrsb ih1 ih2 => - obtain ⟨sb2, htrsb2, hrb⟩ := ih2 - have h := (hswb hrb HasTau.τ).left _ ih1 - obtain ⟨sb2', htrsb2', hrb'⟩ := h - exists sb2' - constructor - · simp only [sTr_τSTr] at htrsb htrsb2' - exact Relation.ReflTransGen.trans htrsb2 htrsb2' - · exact hrb' - -/-- Utility theorem for 'following' internal transitions using an `SWBisimulation` -(second component). -/ -theorem IsSWBisimulation.follow_internal_snd - [HasTau Label] {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} - (hswb : IsSWBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) (hstr : lts₂.τSTr s₂ s₂') : - ∃ s₁', lts₁.τSTr s₁ s₁' ∧ r s₁' s₂' := by - induction hstr - case refl => - exists s₁ - constructor; constructor - exact hr - case tail sb hrsb htrsb ih1 ih2 => - obtain ⟨sb2, htrsb2, hrb⟩ := ih2 - have h := (hswb hrb HasTau.τ).right _ ih1 - obtain ⟨sb2', htrsb2', hrb'⟩ := h - exists sb2' - constructor - · simp only [sTr_τSTr] at htrsb htrsb2' - exact Relation.ReflTransGen.trans htrsb2 htrsb2' - · exact hrb' +lemma IsSWBisimulation.isSimulation [HasTau Label] (h : IsSWBisimulation lts₁ lts₂ r) : + IsSimulation lts₁ lts₂.saturate r := by + intro s₁ s₂ hr μ + exact (h hr μ).1 + +lemma IsSWBisimulation.isSimulation_flip [HasTau Label] (h : IsSWBisimulation lts₁ lts₂ r) : + IsSimulation lts₂ lts₁.saturate (flip r) := by + intro s₂ s₁ hr μ + exact (h hr μ).2 + +theorem IsSWBisimulation.iff_isSimulation [HasTau Label] : + IsSWBisimulation lts₁ lts₂ r ↔ + IsSimulation lts₁ lts₂.saturate r ∧ IsSimulation lts₂ lts₁.saturate (flip r) := by + refine ⟨fun h => ⟨h.isSimulation, h.isSimulation_flip⟩, ?_⟩ + intro ⟨h, hflip⟩ s₁ s₂ hr μ + exact ⟨h s₁ s₂ hr μ, hflip s₂ s₁ hr μ⟩ /-- We can now prove that any relation is a `WeakBisimulation` iff it is an `SWBisimulation`. This formalises lemma 4.2.10 in [Sangiorgi2011]. -/ @@ -885,59 +516,15 @@ theorem isWeakBisimulation_iff_isSWBisimulation IsWeakBisimulation lts₁ lts₂ r ↔ IsSWBisimulation lts₁ lts₂ r := by apply Iff.intro case mp => - intro h s₁ s₂ hr μ - apply And.intro - case left => - intro s₁' htr - specialize h hr μ - have h' := h.1 s₁' (STr.single lts₁ htr) - obtain ⟨s₂', htr2, hr2⟩ := h' - exists s₂' - case right => - intro s₂' htr - specialize h hr μ - have h' := h.2 s₂' (STr.single lts₂ htr) - obtain ⟨s₁', htr1, hr1⟩ := h' - exists s₁' + intro h + rw [IsSWBisimulation.iff_isSimulation] + exact ⟨h.isSimulation.mono lts₁.tr_le_tr_saturate le_rfl, + h.inv.isSimulation.mono lts₂.tr_le_tr_saturate le_rfl⟩ case mpr => - intro h s₁ s₂ hr μ - apply And.intro - case left => - intro s₁' hstr - cases hstr - case refl => - exists s₂ - constructor; constructor - exact hr - case tr sb sb' hstr1 htr hstr2 => - rw [←sTr_τSTr] at hstr1 hstr2 - simp only [sTr_τSTr] at hstr1 hstr2 - obtain ⟨sb1, hstr1b, hrb⟩ := IsSWBisimulation.follow_internal_fst h hr hstr1 - obtain ⟨sb2', hstr1b', hrb'⟩ := (h hrb μ).left _ htr - obtain ⟨s₁', hstr1', hrb2⟩ := IsSWBisimulation.follow_internal_fst h hrb' hstr2 - rw [←sTr_τSTr] at hstr1' hstr1b - exists s₁' - constructor - · exact STr.comp lts₂ hstr1b hstr1b' hstr1' - · exact hrb2 - case right => - intro s₂' hstr - cases hstr - case refl => - exists s₁ - constructor; constructor - exact hr - case tr sb sb' hstr1 htr hstr2 => - rw [←sTr_τSTr] at hstr1 hstr2 - simp only [sTr_τSTr] at hstr1 hstr2 - obtain ⟨sb1, hstr1b, hrb⟩ := IsSWBisimulation.follow_internal_snd h hr hstr1 - obtain ⟨sb2', hstr1b', hrb'⟩ := (h hrb μ).right _ htr - obtain ⟨s₁', hstr1', hrb2⟩ := IsSWBisimulation.follow_internal_snd h hrb' hstr2 - rw [←sTr_τSTr] at hstr1' hstr1b - exists s₁' - constructor - · exact STr.comp lts₁ hstr1b hstr1b' hstr1' - · exact hrb2 + intro h + rw [IsWeakBisimulation, IsBisimulation.isSimulation_iff] + exact ⟨h.isSimulation.isSimulation_saturate_left, + h.isSimulation_flip.isSimulation_saturate_left⟩ theorem IsWeakBisimulation.isSwBisimulation [HasTau Label] {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} {r : State₁ → State₂ → Prop} diff --git a/Cslib/Foundations/Semantics/LTS/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 9deb34d449..2b886a2957 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -49,6 +49,9 @@ theorem STr.single [HasTau Label] (lts : LTS State Label) : intro h apply STr.tr .refl h .refl +lemma tr_le_tr_saturate [HasTau Label] (lts : LTS State Label) : lts.Tr ≤ lts.saturate.Tr := + fun _ _ _ => STr.single lts + /-- STr transitions labeled by HasTau.τ are exactly the τSTr transitions. -/ theorem sTr_τSTr [HasTau Label] (lts : LTS State Label) : lts.STr s HasTau.τ s' ↔ lts.τSTr s s' := by diff --git a/Cslib/Foundations/Semantics/LTS/Simulation.lean b/Cslib/Foundations/Semantics/LTS/Simulation.lean index cf401de048..25d8ed75dc 100644 --- a/Cslib/Foundations/Semantics/LTS/Simulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Simulation.lean @@ -6,7 +6,7 @@ Authors: Fabrizio Montesi module -public import Cslib.Foundations.Semantics.LTS.Basic +public import Cslib.Foundations.Semantics.LTS.HasTau /-! # IsSimulation and Similarity @@ -115,6 +115,28 @@ theorem Similarity.trans (h1 : s₁ ≤[lts₁,lts₂] s2) (h2 : s2 ≤[lts₂,l case right => apply IsSimulation.comp r1 r2 hr1s hr2s +theorem IsSimulation.sup (hr : IsSimulation lts₁ lts₂ r) + (hs : IsSimulation lts₁ lts₂ s) : IsSimulation lts₁ lts₂ (r ⊔ s) := by + rintro s₁ s₂ (hrel | hrel) μ s₁' htr + · obtain ⟨s₂', htr', hrel'⟩ := hr s₁ s₂ hrel μ s₁' htr + use s₂', htr', Or.inl hrel' + · obtain ⟨s₂', htr', hrel'⟩ := hs s₁ s₂ hrel μ s₁' htr + use s₂', htr', Or.inr hrel' + +theorem IsSimulation.sim_trace (hr : IsSimulation lts₁ lts₂ r) (hrel : r s₁ s₂) : + ∀ μs s₁', lts₁.MTr s₁ μs s₁' → ∃ s₂', lts₂.MTr s₂ μs s₂' ∧ r s₁' s₂' := by + intro μs s₁' hmtr + induction μs generalizing s₁ s₂ with + | nil => + obtain rfl := hmtr.nil_eq + exact ⟨s₂, MTr.refl, hrel⟩ + | cons μ μs ih => + cases hmtr + case stepL s₁'' htr hmtr => + obtain ⟨s₂'', htr₂, hrel'⟩: ∃ s2', lts₂.Tr s₂ μ s2' ∧ r s₁'' s2' := hr _ _ hrel μ s₁'' htr + obtain ⟨s₂', hmtr₂, hrel'⟩ := ih hrel' hmtr + use s₂', hmtr₂.stepL htr₂, hrel' + /-- Simulation equivalence relates all states `s₁` and `s2` such that `s₁ ≤[lts₁ lts₂] s2` and `s2 ≤[lts₂ lts₁] s₁`. -/ def SimulationEquiv (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) : @@ -160,6 +182,41 @@ instance : (SimulationEquiv lts₁ lts₃) where trans := SimulationEquiv.trans +/-- Utility theorem for following internal transitions along a saturated lts. -/ +lemma IsSimulation.follow_internal [HasTau Label] {lts₁ : LTS State₁ Label} + {lts₂ : LTS State₂ Label} (h : IsSimulation lts₁ lts₂.saturate r) (hr : r s₁ s₂) + (hstr : lts₁.τSTr s₁ s₁') : ∃ s₂', lts₂.τSTr s₂ s₂' ∧ r s₁' s₂' := by + induction hstr + case refl => + use s₂, .refl + case tail sb hrsb htrsb ih1 ih2 => + obtain ⟨sb2, htrsb2, hrb⟩ := ih2 + have ⟨sb2', htrsb2', hrb'⟩ := h _ _ hrb HasTau.τ _ ih1 + use sb2', htrsb2.trans (lts₂.sTr_τSTr.mp htrsb2') + +/-- If the right-hand lts is saturated, a simulation lifts along saturating the left-hand lts. -/ +theorem IsSimulation.isSimulation_saturate_left [HasTau Label] {lts₁ : LTS State₁ Label} + {lts₂ : LTS State₂ Label} (h : IsSimulation lts₁ lts₂.saturate r) : + IsSimulation lts₁.saturate lts₂.saturate r := by + intro s₁ s₂ hr μ s₁' h + cases h + case refl => + use s₂, .refl, hr + case tr sb sb' hstr1 htr hstr2 => + obtain ⟨sb1, hstr1b, hrb⟩ := IsSimulation.follow_internal h hr hstr1 + obtain ⟨sb2', hstr1b', hrb'⟩ := h _ _ hrb μ _ htr + obtain ⟨s₁', hstr1', hrb2⟩ := IsSimulation.follow_internal h hrb' hstr2 + rw [←sTr_τSTr] at hstr1' hstr1b + use s₁', STr.comp lts₂ hstr1b hstr1b' hstr1', hrb2 + +/-- Simulation is preserved by removing transitions on the left, and adding transitions on the +right. -/ +theorem IsSimulation.mono (h₁ : lts₁'.Tr ≤ lts₁.Tr) (h₂ : lts₂.Tr ≤ lts₂'.Tr) + (h : IsSimulation lts₁ lts₂ r) : IsSimulation lts₁' lts₂' r := by + intro s₁ s₂ hr μ s₁' htr + obtain ⟨s₂', htr', hr'⟩ := h s₁ s₂ hr μ s₁' (h₁ _ _ _ htr) + use s₂', h₂ _ _ _ htr', hr' + end Simulation end Cslib.LTS diff --git a/Cslib/Foundations/Semantics/LTS/TraceEq.lean b/Cslib/Foundations/Semantics/LTS/TraceEq.lean index 3e4dbebb48..6a5a6792b5 100644 --- a/Cslib/Foundations/Semantics/LTS/TraceEq.lean +++ b/Cslib/Foundations/Semantics/LTS/TraceEq.lean @@ -71,6 +71,10 @@ theorem TraceEq.symm (h : s₁ ~tr[lts₁,lts₂] s₂) : s₂ ~tr[lts₂,lts₁ simp only [TraceEq] rw [h] +@[simp] theorem TraceEq.flip_eq : flip (TraceEq lts₁ lts₂) = TraceEq lts₂ lts₁ := by + ext s₁ s₂ + grind [flip, TraceEq.symm] + /-- Trace equivalence is transitive. -/ theorem TraceEq.trans (h1 : s₁ ~tr[lts₁,lts₂] s₂) (h2 : s₂ ~tr[lts₂,lts₃] s₃) : s₁ ~tr[lts₁,lts₃] s₃ := by diff --git a/Cslib/Languages/CCS/BehaviouralTheory.lean b/Cslib/Languages/CCS/BehaviouralTheory.lean index 6e24dac126..d71ece4901 100644 --- a/Cslib/Languages/CCS/BehaviouralTheory.lean +++ b/Cslib/Languages/CCS/BehaviouralTheory.lean @@ -213,7 +213,7 @@ theorem bisimilarity_choice_comm : (choice p q) ~[lts (defs := defs)] (choice q cases htr with grind · grind [HomBisimilarity.refl, ChoiceComm] case bisim h => - grind [ChoiceComm] + grind [IsBisimulation, ChoiceComm] private inductive ChoiceAssoc : Process Name Constant → Process Name Constant → Prop where | assoc : ChoiceAssoc (choice p (choice q r)) (choice (choice p q) r) @@ -262,7 +262,7 @@ theorem bisimilarity_congr_pre : case pre p' q' μ hbis => unfold lts constructor <;> intro _ _ <;> [exists q'; exists p'] <;> grind - case bisim => grind [Bisimilarity.largest_bisimulation] + case bisim => grind [IsBisimulation, IsBisimulation.le_bisimilarity] @[local grind] private inductive ResBisim : Process Name Constant → Process Name Constant → Prop where @@ -283,7 +283,7 @@ theorem bisimilarity_congr_res : case left => intro s1' htr cases htr with | res _ _ htr => - obtain ⟨q', _, bisim⟩ := Bisimilarity.is_bisimulation.follow_fst h htr + obtain ⟨q', _, bisim⟩ := h.follow_fst htr exists res a q' unfold lts at * #adaptation_note @@ -294,7 +294,7 @@ theorem bisimilarity_congr_res : case right => intro s2' htr cases htr with | res _ _ htr => - obtain ⟨p', _, bisim⟩ := Bisimilarity.is_bisimulation.follow_snd h htr + obtain ⟨p', _, bisim⟩ := h.follow_snd htr exists res a p' unfold lts at * #adaptation_note @@ -328,7 +328,7 @@ theorem bisimilarity_congr_choice : constructor · apply Tr.choiceL htr2 · constructor - apply Bisimilarity.largest_bisimulation hb hr2 + apply hb.le_bisimilarity _ _ hr2 case choiceR a b c htr => exists s1' constructor @@ -342,7 +342,7 @@ theorem bisimilarity_congr_choice : constructor · assumption constructor - apply Bisimilarity.largest_bisimulation hb hr2 + apply hb.le_bisimilarity _ _ hr2 case right => intro s2' htr cases r @@ -355,7 +355,7 @@ theorem bisimilarity_congr_choice : constructor · apply Tr.choiceL htr1 · constructor - apply Bisimilarity.largest_bisimulation hb hr1 + apply hb.le_bisimilarity _ _ hr1 case choiceR a b c htr => exists s2' constructor @@ -369,7 +369,7 @@ theorem bisimilarity_congr_choice : constructor · assumption · constructor - apply Bisimilarity.largest_bisimulation hb hr1 + apply hb.le_bisimilarity _ _ hr1 @[local grind] private inductive ParBisim : Process Name Constant → Process Name Constant → Prop where diff --git a/Cslib/Logics/HML/Basic.lean b/Cslib/Logics/HML/Basic.lean index f83709a780..de2efd0ca3 100644 --- a/Cslib/Logics/HML/Basic.lean +++ b/Cslib/Logics/HML/Basic.lean @@ -242,7 +242,7 @@ lemma bisimulation_satisfies {lts : LTS State Label} Satisfies lts s2 a := by induction a generalizing s1 s2 with | diamond => cases hs with | diamond htr _ => grind [hrb.follow_fst hr htr] - | _ => grind + | _ => grind [IsBisimulation] lemma bisimulation_TheoryEq {lts : LTS State Label} {hrb : lts.IsHomBisimulation r} diff --git a/CslibTests/GrindLint.lean b/CslibTests/GrindLint.lean index 370e58db3a..d04527c102 100644 --- a/CslibTests/GrindLint.lean +++ b/CslibTests/GrindLint.lean @@ -73,14 +73,14 @@ open_scoped_all Cslib /-- (changes from lean#13166) -/ #grind_lint skip Cslib.ωLanguage.map_id #grind_lint skip Cslib.LTS.Bisimilarity.gfp -#grind_lint skip Cslib.LTS.Bisimilarity.is_bisimulation -#grind_lint skip Cslib.LTS.Bisimilarity.largest_bisimulation +#grind_lint skip Cslib.LTS.Bisimilarity.isBisimulation +#grind_lint skip Cslib.LTS.IsBisimulation.le_bisimilarity #grind_lint skip Cslib.LTS.IsBisimulation.bot #grind_lint skip Cslib.LTS.IsBisimulation.comp #grind_lint skip Cslib.LTS.IsBisimulation.inv #grind_lint skip Cslib.LTS.IsBisimulation.sup #grind_lint skip Cslib.LTS.IsBisimulation.traceEq -#grind_lint skip Cslib.LTS.IsBisimulationUpTo.is_bisimulation +#grind_lint skip Cslib.LTS.IsBisimulationUpTo.isBisimulation #grind_lint skip Cslib.Logic.HML.theoryEq_isBisimulation #guard_msgs in From edfa9742e5b839df1d7dbb1bd2e15552718b4188 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Thu, 11 Jun 2026 10:18:55 +0200 Subject: [PATCH 16/51] Add chenson2018 explicitly to logic CODEOWNERS A previous modification to CODEOWNERS had the unintended consequence that chenson2018 couldn't approve PRs to logic any longer, which is too restrictive until we get more logic maintainers. --- .github/CODEOWNERS | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 5f565a3a11..85dda90a89 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -12,9 +12,9 @@ ### Area access # Each area maintainer has access to parts that pertain them. They get automatically asked for # reviewing new PRs that touch those areas. -/Cslib/Algorithms/ @sorrachai -/Cslib/Foundations/Logic/ @arademaker @fmontesi -/Cslib/Logics/ @arademaker @fmontesi -/Cslib/Languages/LambdaCalculus/ @chenson2018 +/Cslib/Algorithms/ @fmontesi @sorrachai +/Cslib/Foundations/Logic/ @arademaker @fmontesi @chenson2018 +/Cslib/Logics/ @arademaker @fmontesi @chenson2018 +/Cslib/Languages/LambdaCalculus/ @chenson2018 @fmontesi /.github/workflows @kim-em @fmontesi @chenson2018 /scripts @kim-em @fmontesi @chenson2018 From e3991ff21ecf4893e5c7fa21ea2f073477192186 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Thu, 11 Jun 2026 10:19:23 +0200 Subject: [PATCH 17/51] feat: logical equivalence for modal logic (#535) Adds logical equivalence for modal logic, proving that it is a `Congruence` (for any modal logic, regardless of the class of models considered) and a `LogicalEquivalence` (for logic K, i.e., when considering the class of all models). The PR also renames `Proposition.neg` to `Proposition.not` and adds a useful lemma on `Proposition.iff`. Depends on #528. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- Cslib.lean | 1 + Cslib/Logics/Modal/Basic.lean | 30 +++-- Cslib/Logics/Modal/Denotation.lean | 4 +- Cslib/Logics/Modal/LogicalEquivalence.lean | 132 +++++++++++++++++++++ 4 files changed, 154 insertions(+), 13 deletions(-) create mode 100644 Cslib/Logics/Modal/LogicalEquivalence.lean diff --git a/Cslib.lean b/Cslib.lean index 657d106c2e..3ec5b03f6c 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -139,6 +139,7 @@ public import Cslib.Logics.LinearLogic.CLL.PhaseSemantics.Basic public import Cslib.Logics.Modal.Basic public import Cslib.Logics.Modal.Cube public import Cslib.Logics.Modal.Denotation +public import Cslib.Logics.Modal.LogicalEquivalence public import Cslib.Logics.Propositional.Defs public import Cslib.Logics.Propositional.NaturalDeduction.Basic public import Cslib.MachineLearning.PACLearning.Defs diff --git a/Cslib/Logics/Modal/Basic.lean b/Cslib/Logics/Modal/Basic.lean index a627923676..ee6a6a16e2 100644 --- a/Cslib/Logics/Modal/Basic.lean +++ b/Cslib/Logics/Modal/Basic.lean @@ -41,13 +41,13 @@ inductive Proposition (Atom : Type u) : Type u where /-- Atomic proposition. -/ | atom (p : Atom) /-- Negation. -/ - | neg (φ : Proposition Atom) + | not (φ : Proposition Atom) /-- Conjunction. -/ | and (φ₁ φ₂ : Proposition Atom) /-- Possibility. -/ | diamond (φ : Proposition Atom) -@[inherit_doc] scoped prefix:40 "¬" => Proposition.neg +@[inherit_doc] scoped prefix:40 "¬" => Proposition.not @[inherit_doc] scoped infix:36 " ∧ " => Proposition.and @[inherit_doc] scoped prefix:40 "◇" => Proposition.diamond @@ -76,7 +76,7 @@ the proposition `φ`. -/ @[scoped grind] def Satisfies (m : Model World Atom) (w : World) : Proposition Atom → Prop | .atom p => m.v w p - | .neg φ => ¬Satisfies m w φ + | .not φ => ¬Satisfies m w φ | .and φ₁ φ₂ => Satisfies m w φ₁ ∧ Satisfies m w φ₂ | .diamond φ => ∃ w', m.r w w' ∧ Satisfies m w' φ @@ -101,13 +101,13 @@ instance : HasInferenceSystem (Judgement World Atom) := ⟨Satisfies.Bundled⟩ open scoped InferenceSystem Proposition -@[scoped grind =] +@[scoped grind =_] theorem derivation_def {m : Model World Atom} {w : World} {φ : Proposition Atom} : - ⇓Modal[m,w ⊨ φ] = Satisfies m w φ := rfl + Satisfies m w φ = ⇓Modal[m,w ⊨ φ] := rfl /-- A world satisfies a proposition iff it does not satisfy the negation of the proposition. -/ @[scoped grind =] -theorem neg_satisfies : ⇓Modal[m,w ⊨ ¬φ] ↔ ¬⇓Modal[m,w ⊨ φ] := by +theorem not_satisfies : ⇓Modal[m,w ⊨ ¬φ] ↔ ¬⇓Modal[m,w ⊨ φ] := by induction φ generalizing w <;> grind /-- Characterisation of the `∨` connective. @@ -127,6 +127,16 @@ This result proves that the definition is correct. theorem Satisfies.impl_iff_impl {m : Model World Atom} : ⇓Modal[m,w ⊨ φ₁ → φ₂] ↔ (⇓Modal[m,w ⊨ φ₁] → ⇓Modal[m,w ⊨ φ₂]) := by grind [Proposition.impl] +/-- Characterisation of the `↔` connective. + +Bi-implication is defined in terms of the more primitive connectives given in `Proposition`. +This result proves that the definition is correct. -/ +@[scoped grind =] +theorem Satisfies.iff_iff_iff {m : Model World Atom} : + ⇓Modal[m,w ⊨ φ₁ ↔ φ₂] ↔ (⇓Modal[m,w ⊨ φ₁] ↔ ⇓Modal[m,w ⊨ φ₂]) := by + simp only [Proposition.iff] + grind [= derivation_def] + /-- Characterisation of the `□` modality. Necessity is defined in terms of the more primitive connectives given in `Proposition`. @@ -152,7 +162,7 @@ theorem satisfies_theory (h : Satisfies m w φ) : φ ∈ theory m w := by grind /-- If two worlds are not theory equivalent, there exists a distinguishing proposition. -/ lemma not_theoryEq_satisfies (h : ¬TheoryEq m w₁ w₂) : - ∃ φ, (⇓Modal[m,w₁ ⊨ φ] ∧ ¬⇓Modal[m,w₂ ⊨ φ]) := by grind [=_ neg_satisfies] + ∃ φ, (⇓Modal[m,w₁ ⊨ φ] ∧ ¬⇓Modal[m,w₂ ⊨ φ]) := by grind [=_ not_satisfies] /-- If two worlds are theory equivalent and the former satisfies a proposition, the latter does as well. -/ @@ -167,10 +177,8 @@ theorem Satisfies.k : ⇓Modal[m,w ⊨ □(φ₁ → φ₂) → (□φ₁ → set_option linter.tacticAnalysis.verifyGrindOnly false in /-- The dual axiom, valid for all models. -/ theorem Satisfies.dual : ⇓Modal[m,w ⊨ ◇φ ↔ ¬□¬φ] := by - constructor - · grind - · grind only [→ satisfies_theory, usr Set.mem_setOf_eq, = impl_iff_impl, = derivation_def, - = neg_satisfies, Satisfies, = box_iff_forall, = Set.setOf_true] + grind only [Satisfies.iff_iff_iff.mpr, → satisfies_theory, usr Set.mem_setOf_eq, = impl_iff_impl, + =_ derivation_def, = not_satisfies, Satisfies, = box_iff_forall, = Set.setOf_true] /-- The T axiom, valid for all reflexive models. -/ theorem Satisfies.t {m : Model World Atom} [instRefl : Std.Refl m.r] {w : World} diff --git a/Cslib/Logics/Modal/Denotation.lean b/Cslib/Logics/Modal/Denotation.lean index 63e88000e0..b74e8f3f11 100644 --- a/Cslib/Logics/Modal/Denotation.lean +++ b/Cslib/Logics/Modal/Denotation.lean @@ -25,7 +25,7 @@ open scoped Proposition InferenceSystem def Proposition.denotation (m : Model World Atom) : Proposition Atom → Set World | .atom p => {w | m.v w p} - | .neg φ => (φ.denotation m)ᶜ + | .not φ => (φ.denotation m)ᶜ | .and φ₁ φ₂ => φ₁.denotation m ∩ φ₂.denotation m | .diamond φ => {w | ∃ w', m.r w w' ∧ w' ∈ φ.denotation m} @@ -38,7 +38,7 @@ theorem satisfies_mem_denotation {m : Model World Atom} {φ : Proposition Atom} /-- A world is in the denotation of a proposition iff it is not in the denotation of the negation of the proposition. -/ @[scoped grind =] -theorem neg_denotation {m : Model World Atom} (φ : Proposition Atom) : +theorem not_denotation {m : Model World Atom} (φ : Proposition Atom) : w ∉ (¬φ).denotation m ↔ w ∈ φ.denotation m := by grind [_=_ satisfies_mem_denotation] diff --git a/Cslib/Logics/Modal/LogicalEquivalence.lean b/Cslib/Logics/Modal/LogicalEquivalence.lean new file mode 100644 index 0000000000..0fc089e4ec --- /dev/null +++ b/Cslib/Logics/Modal/LogicalEquivalence.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Logics.Modal.Basic +public import Cslib.Foundations.Logic.LogicalEquivalence + +/-! # Logical Equivalence in Modal Logic + +This module defines logical equivalence for modal propositions. +The definitions are parametric on the class of models under consideration. + +We also instantiate `LogicalEquivalence` for Modal Logic K, i.e., equivalence +for the class of all models. +-/ + +@[expose] public section + +namespace Cslib.Logic.Modal + +open scoped InferenceSystem Proposition Satisfies + +/-- The modal propositions `φ₁` and `φ₂` are equivalent in the class of models `S`. -/ +def Proposition.Equiv (S : Set (Model World Atom)) (φ₁ φ₂ : Proposition Atom) + : Prop := + ∀ m ∈ S, ∀ w : World, ⇓Modal[m,w ⊨ φ₁ ↔ φ₂] + +@[inherit_doc] +scoped notation φ₁ " ≡[" S "] " φ₂ => Proposition.Equiv S φ₁ φ₂ + +@[inherit_doc] +scoped notation φ₁ " ≡ " φ₂ => Proposition.Equiv Set.univ φ₁ φ₂ + +@[scoped grind =] +theorem Proposition.equiv_def (S : Set (Model World Atom)) (φ₁ φ₂ : Proposition Atom) : + (φ₁ ≡[S] φ₂) ↔ + (∀ m ∈ S, ∀ w : World, ⇓Modal[m,w ⊨ φ₁ ↔ φ₂]) := by rfl + +@[scoped grind =] +theorem Proposition.equiv_iff (S : Set (Model World Atom)) (φ₁ φ₂ : Proposition Atom) : + (φ₁ ≡[S] φ₂) ↔ + (∀ m ∈ S, ∀ w : World, ⇓Modal[m,w ⊨ φ₁] ↔ ⇓Modal[m,w ⊨ φ₂]) := by + simp [Proposition.equiv_def, Satisfies.iff_iff_iff] + +theorem Proposition.equiv_valid (S : Set (Model World Atom)) + (φ₁ φ₂ : Proposition Atom) (h : φ₁ ≡[S] φ₂) : + (φ₁.valid S ↔ φ₂.valid S) := by + grind + +/-- Propositional contexts. -/ +inductive Proposition.Context (Atom : Type u) : Type u where + | hole + | not (c : Context Atom) + | andL (c : Context Atom) (φ : Proposition Atom) + | andR (φ : Proposition Atom) (c : Context Atom) + | diamond (c : Context Atom) + +/-- Replaces a hole in a propositional context with a proposition. -/ +@[scoped grind =] +def Proposition.Context.fill (c : Context Atom) (φ : Proposition Atom) := + match c with + | hole => φ + | not c => .not (c.fill φ) + | andL c φ' => (c.fill φ).and φ' + | andR φ' c => φ'.and (c.fill φ) + | diamond c => .diamond (c.fill φ) + +instance : HasContext (Proposition Atom) := ⟨Proposition.Context Atom, Proposition.Context.fill⟩ + +@[scoped grind =_] +lemma Proposition.Context.fill_def {Γ : HasContext.Context (Proposition Atom)} : + Γ.fill φ = Γ<[φ] := rfl + +open scoped Proposition Proposition.Context + +/-- Logical equivalence is an equivalence relation. -/ +instance {World Atom} (S : Set (Model World Atom)) : + IsEquiv (Proposition Atom) (Proposition.Equiv S) := by + rw [← equivalence_iff_isEquiv] + grind [Equivalence] + +/-- Logical equivalence is a congruence. -/ +instance {World Atom} (S : Set (Model World Atom)) : + Congruence (Proposition Atom) (Proposition.Equiv S) where + elim ctx φ₁ φ₂ heqv m hₘ w := by + induction ctx generalizing w + case hole => grind + case not c ih | andL c ih | andR c ih => + specialize ih w + grind + case diamond c ih => + rw [Satisfies.iff_iff_iff] + apply Iff.intro + all_goals + rintro ⟨w', h⟩ + specialize ih w' + grind + +/-- Judgemental contexts. -/ +structure Satisfies.Context (World Atom : Type*) where + /-- The model to consider. -/ + m : Model World Atom + /-- The world to check propositions against. -/ + w : World + +/-- Fills a judgemental context with a proposition. -/ +def Satisfies.Context.fill (c : Satisfies.Context World Atom) (φ : Proposition Atom) : + Judgement World Atom := Modal[c.m, c.w ⊨ φ] + +instance judgementalContext : + HasHContext (Judgement World Atom) (Proposition Atom) := + ⟨Satisfies.Context World Atom, Satisfies.Context.fill⟩ + +@[scoped grind =_] +lemma Satisfies.Context.fill_def {c : Satisfies.Context World Atom} : + Modal[c.m,c.w ⊨ φ] = c<[φ] := rfl + +open scoped Satisfies.Context + +/-- Logical equivalence for Modal Logic K. That is, no assumptions on models are made. -/ +instance : LogicalEquivalence + (Proposition Atom) (Judgement World Atom) Satisfies.Bundled where + eqv := Proposition.Equiv Set.univ + eqvFillValid heqv c h := by + specialize heqv c.m + grind + +end Cslib.Logic.Modal From 616e04b0cf19732bd8ed688095847e6967746047 Mon Sep 17 00:00:00 2001 From: Chris Henson <46805207+chenson2018@users.noreply.github.com> Date: Thu, 11 Jun 2026 13:06:26 -0400 Subject: [PATCH 18/51] doc: prefer +/- for Boolean `optConfig` (#620) I forgot `declare_term_config_elab` generated these for Boolean options when writing this documentation. --- Cslib/Foundations/Data/HasFresh.lean | 6 +++--- CslibTests/HasFresh.lean | 10 +++++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/Cslib/Foundations/Data/HasFresh.lean b/Cslib/Foundations/Data/HasFresh.lean index 01ae7bc7fd..df3d980e05 100644 --- a/Cslib/Foundations/Data/HasFresh.lean +++ b/Cslib/Foundations/Data/HasFresh.lean @@ -126,13 +126,13 @@ declare_term_config_elab elabFreeUnionConfig FreeUnionConfig #check free_union [f, g] ℕ info: ∅ ∪ xs : Finset ℕ - #check free_union (singleton := false) ℕ + #check free_union -singleton ℕ -- info: ∅ ∪ {x} : Finset ℕ - #check free_union (finset := false) ℕ + #check free_union -finset ℕ -- info: ∅ : Finset ℕ - #check free_union (singleton := false) (finset := false) ℕ + #check free_union -singleton -finset ℕ ``` -/ syntax (name := freeUnion) "free_union" optConfig (" [" (term,*) "]")? term : term diff --git a/CslibTests/HasFresh.lean b/CslibTests/HasFresh.lean index 95ba08a128..aa1ccffadc 100644 --- a/CslibTests/HasFresh.lean +++ b/CslibTests/HasFresh.lean @@ -40,17 +40,21 @@ def g (_ : String) : Finset ℕ := {4, 5, 6} #guard_msgs in #check free_union [f, g] ℕ +/-- info: ∅ ∪ {x} ∪ xs ∪ f var ∪ g var : Finset ℕ -/ +#guard_msgs in +#check free_union +singleton +finset [f, g] ℕ + /-- info: ∅ ∪ xs : Finset ℕ -/ #guard_msgs in -#check free_union (singleton := false) ℕ +#check free_union -singleton ℕ /-- info: ∅ ∪ {x} : Finset ℕ -/ #guard_msgs in -#check free_union (finset := false) ℕ +#check free_union -finset ℕ /-- info: ∅ : Finset ℕ -/ #guard_msgs in -#check free_union (singleton := false) (finset := false) ℕ +#check free_union -singleton -finset ℕ end From 1f601a245d0b16c68c36c86ea2f7f133dc75ea0b Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Fri, 12 Jun 2026 08:55:57 +0200 Subject: [PATCH 19/51] chore: bump mathlib to 8589236, fix breaking changes (#628) Bump `mathlib` dependency to [8589236](https://github.com/leanprover-community/mathlib4/commit/8589236b8b8cc82492e3306df39c0fb308e0523c): chore: move Data/Nat/Lattice to Order (#39990) (2026-06-09) Previously at: [d90090f](https://github.com/leanprover-community/mathlib4/commit/d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab): chore: bump toolchain to v4.31.0-rc2 (#40358) (2026-06-08) Closes #627 Failure log from the validation run: [download](https://github.com/leanprover-community/downstream-reports/actions/runs/27253259444/artifacts/7526847935) _(link expires after 1 year)_ --- This PR bumps `mathlib` to an identified incompatible (first-known-bad) commit (`8589236`) so you can reproduce and fix the incompatibility locally by checking out this branch. _Opened automatically by [downstream-reports/track-incompatibility](https://github.com/leanprover-community/downstream-reports) via [this workflow run](https://github.com/leanprover/cslib/actions/runs/27305770390)._ --------- Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Chris Henson --- .github/CODEOWNERS | 2 +- .github/workflows/lean_action_ci.yml | 4 +-- CONTRIBUTING.md | 2 +- .../Algorithms/Lean/MergeSort/MergeSort.lean | 2 +- .../Combinatorics/InfiniteGraphRamsey.lean | 4 +-- .../Foundations/Data/OmegaSequence/Init.lean | 2 +- Cslib/MachineLearning/PACLearning/Defs.lean | 2 +- .../PACLearning/VCDimension.lean | 4 +-- CslibTests.lean | 28 +++++++++---------- lake-manifest.json | 14 +++++----- lakefile.toml | 6 ++-- 11 files changed, 33 insertions(+), 37 deletions(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 85dda90a89..100fecf654 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -12,7 +12,7 @@ ### Area access # Each area maintainer has access to parts that pertain them. They get automatically asked for # reviewing new PRs that touch those areas. -/Cslib/Algorithms/ @fmontesi @sorrachai +/Cslib/Algorithms/ @fmontesi @sorrachai @chenson2018 /Cslib/Foundations/Logic/ @arademaker @fmontesi @chenson2018 /Cslib/Logics/ @arademaker @fmontesi @chenson2018 /Cslib/Languages/LambdaCalculus/ @chenson2018 @fmontesi diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml index 5b0ce8b541..d5ca8cefab 100644 --- a/.github/workflows/lean_action_ci.yml +++ b/.github/workflows/lean_action_ci.yml @@ -22,10 +22,10 @@ jobs: with: build-args: "--wfail --iofail" test-args: "--wfail --iofail" - - name: "lake exe mk_all --check --module" + - name: "lake exe mk_all --check" run: | set -e - lake exe mk_all --check --module + lake exe mk_all --check #- name: "lake shake" # run: | # set -e diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a2f8f88415..8096bea23a 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -126,7 +126,7 @@ CSLib uses a number of linters, mostly inherited from Batteries and Mathlib. The ## Imports There is a also a test that [Cslib.lean](/Cslib.lean) imports all files. You can ensure this by -running `lake exe mk_all --module` locally, which will make the required changes. +running `lake exe mk_all` locally, which will make the required changes. CSLib tests for minimized imports using `lake shake --add-public --keep-implied --keep-prefix`, which also comes with a `--fix` option. See `lake shake --help` for the special comment syntax used to preserve imports required for tactics or typeclasses. diff --git a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean index 6de2ca6e6e..bb9f9c8f1f 100644 --- a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean +++ b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean @@ -8,7 +8,7 @@ module public import Cslib.Algorithms.Lean.TimeM public import Mathlib.Data.Nat.Cast.Order.Ring -public import Mathlib.Data.Nat.Lattice +public import Mathlib.Order.Lattice.Nat public import Mathlib.Data.Nat.Log /-! diff --git a/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean b/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean index 41cb0180dc..17f1bb30f4 100644 --- a/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean +++ b/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean @@ -69,8 +69,8 @@ private lemma goodSelection_exists (ivs : InfVSet Vertex) : obtain ⟨v, h_v⟩ := Set.Infinite.nonempty ivs.inf let f u := color {v, u} obtain ⟨c, vs, h_inf, h_vs, h_col⟩ := infinite_pigeonhole_principle f <| - Set.Infinite.diff ivs.inf (finite_singleton v) - simp only [subset_diff] at h_vs + Set.Infinite.sdiff ivs.inf (finite_singleton v) + simp only [subset_sdiff] at h_vs let ivs' := InfVSet.mk vs h_inf use {vs := ivs', v := v, c := c} grind [GoodSelection] diff --git a/Cslib/Foundations/Data/OmegaSequence/Init.lean b/Cslib/Foundations/Data/OmegaSequence/Init.lean index 3c54d06ecf..3d6d712523 100644 --- a/Cslib/Foundations/Data/OmegaSequence/Init.lean +++ b/Cslib/Foundations/Data/OmegaSequence/Init.lean @@ -9,7 +9,7 @@ module public import Cslib.Foundations.Data.OmegaSequence.Defs public import Mathlib.Algebra.Order.Group.Nat public import Mathlib.Algebra.Order.Sub.Basic -public import Mathlib.Data.Nat.Lattice +public import Mathlib.Order.Lattice.Nat /-! # ω-sequences a.k.a. infinite sequences diff --git a/Cslib/MachineLearning/PACLearning/Defs.lean b/Cslib/MachineLearning/PACLearning/Defs.lean index e51ceff1fd..084079f4b7 100644 --- a/Cslib/MachineLearning/PACLearning/Defs.lean +++ b/Cslib/MachineLearning/PACLearning/Defs.lean @@ -517,7 +517,7 @@ theorem error_map_eq_hypothesisError (P : Measure α) (h c : Set α) rw [Measure.map_apply_of_aemeasurable hf.aemeasurable] · congr 1; ext x simp only [Set.mem_preimage, Set.mem_setOf_eq, symmDiff_def, sup_eq_union, - Set.mem_union, Set.mem_diff] + Set.mem_union, Set.mem_sdiff] by_cases hx : x ∈ h <;> by_cases hcx : x ∈ c <;> simp_all · convert (hh.prod (measurableSet_singleton false)).union (hh.compl.prod (measurableSet_singleton true)) using 1 diff --git a/Cslib/MachineLearning/PACLearning/VCDimension.lean b/Cslib/MachineLearning/PACLearning/VCDimension.lean index 3084b95629..8328f75447 100644 --- a/Cslib/MachineLearning/PACLearning/VCDimension.lean +++ b/Cslib/MachineLearning/PACLearning/VCDimension.lean @@ -59,12 +59,12 @@ theorem SetShatters.subset {C : ConceptClass α Bool} {W V : Set α} (hW : SetShatters C W) (hVW : V ⊆ W) : SetShatters C V := by intro V' hV'V obtain ⟨c, hc, hc_eq⟩ := hW (V' ∪ (W \ V)) - (union_subset (hV'V.trans hVW) diff_subset) + (union_subset (hV'V.trans hVW) sdiff_subset) refine ⟨c, hc, ?_⟩ rw [show V = W ∩ V from (inter_eq_self_of_subset_right hVW).symm, ← inter_assoc, hc_eq] ext x - simp only [mem_inter_iff, mem_union, mem_diff] + simp only [mem_inter_iff, mem_union, mem_sdiff] refine ⟨?_, fun h => ⟨Or.inl h, hV'V h⟩⟩ rintro ⟨h1 | ⟨_, h2⟩, h3⟩ · exact h1 diff --git a/CslibTests.lean b/CslibTests.lean index 12bc0e4611..3380bb5e17 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -1,15 +1,13 @@ -module -- shake: keep-all --deprecated_module: ignore - -public import CslibTests.Bisimulation -public import CslibTests.CCS -public import CslibTests.CLL -public import CslibTests.DFA -public import CslibTests.FreeMonad -public import CslibTests.GrindLint -public import CslibTests.HML -public import CslibTests.HasFresh -public import CslibTests.ImportWithMathlib -public import CslibTests.LTS -public import CslibTests.LambdaCalculus -public import CslibTests.MLL -public import CslibTests.Reduction +import CslibTests.Bisimulation +import CslibTests.CCS +import CslibTests.CLL +import CslibTests.DFA +import CslibTests.FreeMonad +import CslibTests.GrindLint +import CslibTests.HML +import CslibTests.HasFresh +import CslibTests.ImportWithMathlib +import CslibTests.LTS +import CslibTests.LambdaCalculus +import CslibTests.MLL +import CslibTests.Reduction diff --git a/lake-manifest.json b/lake-manifest.json index 99fff5ea9d..ac8a9ed2bb 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "rev": "8589236b8b8cc82492e3306df39c0fb308e0523c", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "inputRev": "8589236b8b8cc82492e3306df39c0fb308e0523c", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", @@ -48,7 +48,7 @@ "rev": "1537e3fc7e680d64e06fe5fb95c4c9edee7941c2", "name": "proofwidgets", "manifestFile": "lake-manifest.json", - "inputRev": "v0.0.101", + "inputRev": "main", "inherited": true, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/aesop", @@ -58,7 +58,7 @@ "rev": "7897ea6e5cfc6522d355083bdfa798377ab35e11", "name": "aesop", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "master", "inherited": true, "configFile": "lakefile.toml"}, {"url": "https://github.com/leanprover-community/quote4", @@ -68,17 +68,17 @@ "rev": "94346b7b49c36ae871639d1434232f057c193d60", "name": "Qq", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "master", "inherited": true, "configFile": "lakefile.toml"}, {"url": "https://github.com/leanprover-community/batteries", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "460b61adc7d183e43db2b99ac6c1dede9f7a76df", + "rev": "0bbac0a875ac0fd9366cb5bd4211da92d960ac84", "name": "batteries", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "main", "inherited": true, "configFile": "lakefile.toml"}, {"url": "https://github.com/leanprover/lean4-cli", diff --git a/lakefile.toml b/lakefile.toml index 79a2ff1a8b..0d8726a609 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,16 +18,14 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab" +rev = "8589236b8b8cc82492e3306df39c0fb308e0523c" [[lean_lib]] name = "Cslib" -globs = ["Cslib.*"] [[lean_lib]] name = "CslibTests" -globs = ["CslibTests.+"] -moreLeanArgs = ["-Dweak.linter.style.header=false"] +leanOptions = {weak.linter.style.header = false} [[lean_exe]] name = "checkInitImports" From d6c0b9034ba0cb5be11a3b37da05486c6faa60f2 Mon Sep 17 00:00:00 2001 From: Quang Dao Date: Sat, 13 Jun 2026 00:16:55 +0700 Subject: [PATCH 20/51] feat(Data/PFunctor): add free monad of a polynomial functor (#477) ## Summary - Port `PFunctor.FreeM` from [VCV-io](https://github.com/dtumad/VCV-io) (`ToMathlib/PFunctor/Free.lean`) to cslib. - The free monad on a polynomial functor extends the W-type construction with an extra `pure` constructor, yielding a lawful monad that is free over `P : PFunctor`. ### Main definitions - `PFunctor.FreeM`: inductive type with `pure` and `roll` constructors - `FreeM.lift` / `FreeM.liftA`: lifting from the base polynomial functor - `Monad` and `LawfulMonad` instances - `FreeM.inductionOn` / `FreeM.construct`: propositional and dependent eliminators - `FreeM.mapM`: canonical interpretation into any target monad, with `simp` lemmas for `bind`, `map`, `seq`, etc. ### Notes - The `MonadHom`-related definitions (`mapMHom`, `mapMHom'`) from the original VCV-io source are omitted since cslib does not have `MonadHom` infrastructure. These can be added later if cslib gains monad homomorphism support. - File placed at `Cslib/Foundations/Data/PFunctor/FreeM.lean` as a foundation for future polynomial functor work. - Builds cleanly with no linter warnings. Posted by Cursor assistant (model: claude-4.6-opus-high-thinking) on behalf of the user (Quang Dao) with approval. Made with [Cursor](https://cursor.com) --------- Co-authored-by: Cursor --- Cslib.lean | 1 + Cslib/Foundations/Control/Monad/Free.lean | 2 + Cslib/Foundations/Data/PFunctor/Free.lean | 377 ++++++++++++++++++++++ 3 files changed, 380 insertions(+) create mode 100644 Cslib/Foundations/Data/PFunctor/Free.lean diff --git a/Cslib.lean b/Cslib.lean index 3ec5b03f6c..1cc4d08bf8 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -64,6 +64,7 @@ public import Cslib.Foundations.Data.OmegaSequence.Flatten public import Cslib.Foundations.Data.OmegaSequence.InfOcc public import Cslib.Foundations.Data.OmegaSequence.Init public import Cslib.Foundations.Data.OmegaSequence.Temporal +public import Cslib.Foundations.Data.PFunctor.Free public import Cslib.Foundations.Data.RelatesInSteps public import Cslib.Foundations.Data.Relation public import Cslib.Foundations.Data.Set.Saturation diff --git a/Cslib/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean index 90b2fea4c0..84feaf54fa 100644 --- a/Cslib/Foundations/Control/Monad/Free.lean +++ b/Cslib/Foundations/Control/Monad/Free.lean @@ -39,6 +39,8 @@ This unique interpreter is `FreeM.liftM f` - `FreeM.liftM_unique`: Proof of the universal property For elimination and interpretation theory, see `Free/Fold.lean`. +For polynomial effect signatures with explicit operation shapes and positions, see +`Cslib.Foundations.Data.PFunctor.Free`. See the Haskell [freer-simple](https://hackage.haskell.org/package/freer-simple) library for the Haskell implementation that inspired this approach. diff --git a/Cslib/Foundations/Data/PFunctor/Free.lean b/Cslib/Foundations/Data/PFunctor/Free.lean new file mode 100644 index 0000000000..a29e974704 --- /dev/null +++ b/Cslib/Foundations/Data/PFunctor/Free.lean @@ -0,0 +1,377 @@ +/- +Copyright (c) 2026 Quang Dao. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Quang Dao +-/ + +module + +public import Cslib.Init +public import Mathlib.Data.PFunctor.Univariate.Basic + +/-! +# Free Monad of a Polynomial Functor + +We define the free monad on a **polynomial functor** (`PFunctor`), and prove some basic properties. + +The free monad `PFunctor.FreeM P` extends the W-type construction with an extra `pure` +constructor, yielding a monad that is free over the polynomial functor `P`. + +## Comparison with `Cslib.FreeM` + +`Cslib.FreeM F` (in `Cslib/Foundations/Control/Monad/Free.lean`) builds a free monad over an +arbitrary type constructor `F : Type u → Type v`, which need not be functorial. +Its `liftBind` constructor abstracts over the intermediate type `ι`: +``` +| liftBind {ι : Type u} (op : F ι) (cont : ι → FreeM F α) : FreeM F α +``` + +`PFunctor.FreeM P` instead takes a polynomial functor `P : PFunctor`, where the shapes +`P.A` and positions `P.B a` are given explicitly. +Its `liftBind` constructor uses the shape and continuation directly: +``` +| liftBind (a : P.A) (cont : P.B a → P.FreeM α) : P.FreeM α +``` + +When the effect signature is naturally polynomial (a fixed set of operations, each with a +known return type), `PFunctor.FreeM` avoids the universe bump that the abstract `ι` in +`Cslib.FreeM` introduces. +Concretely, `PFunctor.FreeM P` is a genuine endofunctor on a single universe: for a ground +`P`, `P.FreeM α : Type` whenever `α : Type`, whereas `Cslib.FreeM F α : Type 1` for +`F : Type → Type`, since `liftBind` stores the intermediate type `ι : Type`. + +This matters when a program must itself be a first-class value of the same kind, i.e. for +higher-order effects whose operations consume or return computations of the same monad +(schedulers, exception handlers, staged interpreters, higher-order oracles). +Such an effect's response type can be another `P.FreeM` computation, staying in one universe: +``` +def coin : PFunctor.{0,0} := ⟨Bool, fun b => if b then Bool else Nat⟩ +-- a `coin`-program is itself `Type 0`, so it can be another effect's response type: +def scheduler : PFunctor.{0,0} := ⟨Unit, fun _ => coin.FreeM Bool⟩ -- `Type 0` +``` +With the abstract `ι`, the analogous program lives in `Type 1`, so an effect `Type → Type` +cannot return it; bumping the effect to `Type 1 → Type 1` pushes its programs to `Type 2`, +and so on without bound. + +This construction is ported from the [VCV-io](https://github.com/dtumad/VCV-io) library. + +## Main Definitions + +- `PFunctor.FreeM`: The free monad on a polynomial functor. +- `PFunctor.FreeM.lift`: Lift a shape of the base polynomial functor into the free monad. +- `PFunctor.FreeM.liftObj`: Lift an object of the base polynomial functor into the free monad. +- `PFunctor.FreeM.liftM`: Interpret `FreeM P` into any other monad. +-/ + +@[expose] public section + +universe u v uA uB + +namespace PFunctor + +-- Disable generation of unneeded lemmas which the simpNF linter would complain about. +set_option genInjectivity false in +set_option genSizeOfSpec false in +/-- The free monad on a polynomial functor. +This extends `WType` with an extra `pure` constructor. -/ +inductive FreeM (P : PFunctor.{uA, uB}) : Type v → Type (max uA uB v) + /-- A leaf node wrapping a pure value. -/ + | protected pure {α} (a : α) : P.FreeM α + /-- Invoke the operation `a : P.A` with continuation `cont : P.B a → P.FreeM α`. -/ + | liftBind {α} (a : P.A) (cont : P.B a → P.FreeM α) : P.FreeM α +deriving Inhabited + +namespace FreeM + +variable {P : PFunctor.{uA, uB}} {α β γ : Type*} + +instance : Pure (P.FreeM) where pure := .pure + +@[simp] +theorem pure_eq_pure : (FreeM.pure : α → P.FreeM α) = pure := rfl + +/-- Lift a shape of the base polynomial functor into the free monad. -/ +def lift (a : P.A) : P.FreeM (P.B a) := FreeM.liftBind a pure + +@[simp] lemma lift_ne_pure (a : P.A) (y : P.B a) : + (lift a : P.FreeM (P.B a)) ≠ pure y := by simp [lift] + +@[simp] lemma pure_ne_lift (a : P.A) (y : P.B a) : + pure y ≠ (lift a : P.FreeM (P.B a)) := by simp [lift] + +/-- Bind operation for the `FreeM` monad. + +The builtin `>>=` notation should be preferred when `α` and `β` are in the same universe. -/ +protected def bind : P.FreeM α → (α → P.FreeM β) → P.FreeM β + | FreeM.pure a, f => f a + | FreeM.liftBind a cont, f => FreeM.liftBind a (fun u ↦ FreeM.bind (cont u) f) + +instance : Bind (P.FreeM) where bind := .bind + +/-- Note that this lemma does not always apply, as it is universe-constrained by `Bind.bind`. -/ +@[simp] +theorem bind_eq_bind {α β : Type v} : + (FreeM.bind : P.FreeM α → _ → P.FreeM β) = Bind.bind := rfl + +/-- Map a function over a `FreeM` computation. + +The builtin `<$>` notation should be preferred when `α` and `β` are in the same universe. -/ +def map (f : α → β) : P.FreeM α → P.FreeM β + | .pure a => .pure (f a) + | .liftBind a cont => .liftBind a fun u => FreeM.map f (cont u) + +instance : Functor (P.FreeM) where + map := .map + +/-- Note that this lemma does not always apply, as it is universe-constrained by `Functor.map`. -/ +@[simp] +theorem map_eq_map {α β : Type v} : + FreeM.map (P := P) (α := α) (β := β) = Functor.map := rfl + +@[simp] +lemma liftBind_eq (a : P.A) (cont : P.B a → P.FreeM α) : + FreeM.liftBind a cont = (FreeM.lift a).bind cont := rfl + +/-- Lift an object of the base polynomial functor into the free monad. + +This lifts the shape `x.1` with `lift` and relabels the responses with `x.2`. We use the +universe-polymorphic `FreeM.map` rather than `<$>`, since the response type `P.B x.1` and the +target `α` need not lie in the same universe. -/ +abbrev liftObj (x : P.Obj α) : P.FreeM α := (lift x.1).map x.2 + +instance : MonadLift P (P.FreeM) where + monadLift x := FreeM.liftObj x + +@[simp] lemma liftObj_ne_pure (x : P.Obj α) (y : α) : + (liftObj x : P.FreeM α) ≠ pure y := by simp [liftObj, lift, map, -liftBind_eq] + +@[simp] lemma pure_ne_liftObj (x : P.Obj α) (y : α) : + pure y ≠ (liftObj x : P.FreeM α) := by simp [liftObj, lift, map, -liftBind_eq] + +lemma monadLift_eq_liftObj (x : P.Obj α) : (x : P.FreeM α) = FreeM.liftObj x := rfl + +set_option linter.unusedVariables false in +/-- An override for the default induction principle that is in simp-normal form. + +Note that when `α` and `P.B a` are in the same universe, this simplifies slightly further. -/ +@[induction_eliminator] +protected theorem induction {motive : P.FreeM α → Prop} + (pure : ∀ a, motive (pure a)) + (lift_bind : ∀ (a : P.A) (cont : P.B a → P.FreeM α) (ih : ∀ i, motive (cont i)), + motive ((FreeM.lift a).bind cont)) : ∀ x, motive x + | .pure a => pure a + | liftBind a cont => lift_bind a cont fun u => FreeM.induction pure lift_bind (cont u) + +protected theorem bind_assoc (x : P.FreeM α) (f : α → P.FreeM β) (g : β → P.FreeM γ) : + (x.bind f).bind g = x.bind (fun a => (f a).bind g) := by + induction x with + | pure a => rfl + | lift_bind a cont ih => simp [← liftBind_eq, FreeM.bind, ih] at * + +/-- `.pure a` followed by `bind` collapses immediately. -/ +@[simp] +lemma pure_bind (a : α) (f : α → P.FreeM β) : + (pure a : P.FreeM α).bind f = f a := rfl + +@[simp] +lemma bind_pure : ∀ x : P.FreeM α, x.bind pure = x + | .pure a => rfl + | .liftBind a cont => by + simp only [FreeM.bind]; congr 1; funext u; exact bind_pure (cont u) + +@[simp] +lemma bind_pure_comp (f : α → β) : ∀ x : P.FreeM α, x.bind (pure ∘ f) = map f x + | .pure a => rfl + | .liftBind a cont => by simp only [FreeM.bind, map, bind_pure_comp] + +@[simp] +lemma liftBind_bind (a : P.A) (cont : P.B a → P.FreeM β) (f : β → P.FreeM γ) : + ((FreeM.lift a).bind cont).bind f = (FreeM.lift a).bind (fun u ↦ (cont u).bind f) := by + simp only [lift] + exact FreeM.bind_assoc (FreeM.liftBind a pure) cont f + +@[simp] +lemma liftObj_bind (x : P.Obj α) (f : α → P.FreeM β) : + (FreeM.liftObj x).bind f = FreeM.liftBind x.1 (fun a ↦ f (x.2 a)) := rfl + +@[simp] lemma bind_eq_pure_iff (x : P.FreeM α) (f : α → P.FreeM β) (b : β) : + x.bind f = pure b ↔ ∃ a, x = pure a ∧ f a = pure b := by + cases x with + | pure a => exact ⟨fun h => ⟨a, rfl, h⟩, fun ⟨_, h, hf⟩ => by cases h; exact hf⟩ + | liftBind a cont => + constructor + · intro h + cases h + · rintro ⟨_, h, _⟩ + cases h + +@[simp] lemma pure_eq_bind_iff (x : P.FreeM α) (f : α → P.FreeM β) (b : β) : + pure b = x.bind f ↔ ∃ a, x = pure a ∧ pure b = f a := by + cases x with + | pure a => exact ⟨fun h => ⟨a, rfl, h⟩, fun ⟨_, h, hf⟩ => by cases h; exact hf⟩ + | liftBind a cont => + constructor + · intro h + cases h + · rintro ⟨_, h, _⟩ + cases h + +instance : Monad (P.FreeM) where + +@[simp] +theorem id_map : ∀ x : P.FreeM α, map id x = x + | .pure a => rfl + | .liftBind a cont => by + simp only [map] + congr 1 + funext u + exact id_map (cont u) + +theorem comp_map (h : β → γ) (g : α → β) : + ∀ x : P.FreeM α, map (h ∘ g) x = map h (map g x) + | .pure a => rfl + | .liftBind a cont => by + simp only [map] + congr 1 + funext u + exact comp_map h g (cont u) + +instance : LawfulMonad (P.FreeM) := LawfulMonad.mk' + (bind_pure_comp := bind_pure_comp) + (id_map := id_map) + (pure_bind := pure_bind) + (bind_assoc := FreeM.bind_assoc) + +@[simp] +lemma pure_inj (a b : α) : (pure a : P.FreeM α) = pure b ↔ a = b := by + constructor + · intro h + cases h + rfl + · rintro rfl; rfl + +lemma liftBind_inj (a a' : P.A) + (cont : P.B a → P.FreeM α) (cont' : P.B a' → P.FreeM α) : + FreeM.liftBind a cont = FreeM.liftBind a' cont' ↔ ∃ h : a = a', h ▸ cont = cont' := by + constructor + · intro h + cases h + exact ⟨rfl, rfl⟩ + · rintro ⟨rfl, rfl⟩ + rfl + +section liftM + +variable {m : Type uB → Type v} {α : Type uB} + +/-- Interpret a `FreeM P` computation into any monad `m` by providing an interpretation +`interp : (a : P.A) → m (P.B a)` for each operation. -/ +protected def liftM [Pure m] [Bind m] (interp : (a : P.A) → m (P.B a)) : P.FreeM α → m α + | .pure a => pure a + | .liftBind a cont => interp a >>= fun u ↦ (cont u).liftM interp + +variable [Monad m] (interp : (a : P.A) → m (P.B a)) + +@[simp] +lemma liftM_pure (a : α) : (Pure.pure a : P.FreeM α).liftM interp = Pure.pure a := rfl + +@[simp] +lemma liftM_lift_bind (a : P.A) (cont : P.B a → P.FreeM α) : + FreeM.liftM interp (FreeM.lift a >>= cont) = + (do let u ← interp a; (cont u).liftM interp) := by + dsimp only [FreeM.liftM, FreeM.bind, FreeM.lift] + rfl + +/-- +A predicate stating that `eval : P.FreeM α → m α` is an interpreter for the polynomial +effect handler `handler : (a : P.A) → m (P.B a)`. + +This means that `eval` is a monad morphism from the free monad `P.FreeM` to the +monad `m`, and that it extends the interpretation of individual operations given by +`handler`. +-/ +structure Interprets (handler : (a : P.A) → m (P.B a)) (eval : P.FreeM α → m α) : Prop where + apply_pure (a : α) : eval (.pure a) = pure a + apply_lift_bind (a : P.A) (cont : P.B a → P.FreeM α) : + eval ((FreeM.lift a).bind cont) = handler a >>= fun x => eval (cont x) + +theorem Interprets.eq {handler : (a : P.A) → m (P.B a)} {eval : P.FreeM α → m α} + (h : Interprets handler eval) : + eval = (·.liftM handler) := by + ext x + induction x with + | pure a => exact h.apply_pure a + | lift_bind a cont ih => + rw [h.apply_lift_bind] + conv_rhs => simp only [bind_eq_bind, liftM_lift_bind] + simp only [ih] + +theorem Interprets.liftM (handler : (a : P.A) → m (P.B a)) : + Interprets handler (·.liftM handler : P.FreeM α → _) where + apply_pure _ := rfl + apply_lift_bind _ _ := rfl + +/-- +The universal property of the free monad `P.FreeM`. + +That is, `liftM handler` is the unique interpreter that extends the effect handler `handler` to +interpret `P.FreeM` computations in a monad `m`. +-/ +theorem Interprets.iff (handler : (a : P.A) → m (P.B a)) (eval : P.FreeM α → m α) : + Interprets handler eval ↔ eval = (·.liftM handler) := + ⟨(·.eq), fun h => h ▸ Interprets.liftM _⟩ + +variable [LawfulMonad m] + +@[simp] +lemma liftM_bind {α β : Type uB} (x : P.FreeM α) (f : α → P.FreeM β) : + (x >>= f).liftM interp = (do let u ← x.liftM interp; (f u).liftM interp) := by + induction x with + | pure _ => simp only [liftM_pure, LawfulMonad.pure_bind] + | lift_bind a cont h => + simp_rw [bind_eq_bind] + rw [LawfulMonad.bind_assoc, liftM_lift_bind] + simp_rw [liftM_lift_bind, LawfulMonad.bind_assoc] + congr 1 + funext u + exact h u + +@[simp] +lemma liftM_map {α β : Type uB} (f : α → β) (x : P.FreeM α) : + (f <$> x).liftM interp = f <$> x.liftM interp := by + simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure] + +@[simp] +lemma liftM_seq {α β : Type uB} + (interp : (a : P.A) → m (P.B a)) (x : P.FreeM (α → β)) (y : P.FreeM α) : + (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := by + simp [seq_eq_bind_map] + +@[simp] +lemma liftM_seqLeft {α β : Type uB} + (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : + (x <* y).liftM interp = x.liftM interp <* y.liftM interp := by + simp [seqLeft_eq_bind] + +@[simp] +lemma liftM_seqRight {α β : Type uB} + (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : + (x *> y).liftM interp = x.liftM interp *> y.liftM interp := by + simp [seqRight_eq_bind] + +@[simp] +lemma liftM_lift (interp : (a : P.A) → m (P.B a)) (a : P.A) : + (FreeM.lift a).liftM interp = interp a := by + simpa [bind_pure] using + (liftM_lift_bind (interp := interp) (a := a) (cont := pure)) + +@[simp] +lemma liftM_liftObj (interp : (a : P.A) → m (P.B a)) (x : P.Obj α) : + (FreeM.liftObj x).liftM interp = x.2 <$> interp x.1 := by + simp [liftObj] + +end liftM + +end FreeM + +end PFunctor From ee5567b1616135b56bfee96b98eb5b4a8508fa25 Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Fri, 12 Jun 2026 22:28:52 -0400 Subject: [PATCH 21/51] chore: bump mathlib to 73b2611, fix breaking changes (#640) Bump `mathlib` dependency to [73b2611](https://github.com/leanprover-community/mathlib4/commit/73b2611ac34fe053446b21322ee51d19cb27b3e7): chore(Order/Defs/Unbundled): deprecate `def Symmetric` in favor of `class Std.Symm` (#38092) (2026-06-10) Previously at: [8589236](https://github.com/leanprover-community/mathlib4/commit/8589236b8b8cc82492e3306df39c0fb308e0523c): chore: move Data/Nat/Lattice to Order (#39990) (2026-06-09) Closes #639 Failure log from the validation run: [download](https://github.com/leanprover-community/downstream-reports/actions/runs/27427486135/artifacts/7596930467) _(link expires after 1 year)_ --- This PR bumps `mathlib` to an identified incompatible (first-known-bad) commit (`73b2611`) so you can reproduce and fix the incompatibility locally by checking out this branch. _Opened automatically by [downstream-reports/track-incompatibility](https://github.com/leanprover-community/downstream-reports) via [this workflow run](https://github.com/leanprover/cslib/actions/runs/27442101619)._ --------- Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Chris Henson --- Cslib/Foundations/Data/Relation.lean | 12 ++++-------- .../Untyped/FullBetaEtaConfluence.lean | 3 ++- lake-manifest.json | 6 +++--- lakefile.toml | 2 +- 4 files changed, 10 insertions(+), 13 deletions(-) diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean index 262ccbbd8c..dbd6574660 100644 --- a/Cslib/Foundations/Data/Relation.lean +++ b/Cslib/Foundations/Data/Relation.lean @@ -138,8 +138,6 @@ abbrev MJoin (r : α → α → Prop) := Join (ReflTransGen r) theorem MJoin.refl (a : α) : MJoin r a a := by use a -theorem MJoin.symm : Symmetric (MJoin r) := Relation.symmetric_join - theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by use b @@ -420,7 +418,7 @@ theorem Confluent.toChurchRosser (h : Confluent r) : ChurchRosser r := by induction h_eqv with | rel _ b => exists b; grind [ReflTransGen.single] | refl a => exists a - | symm a b _ ih => exact symmetric_join ih + | symm a b _ ih => exact symm ih | trans _ _ _ _ _ ih1 ih2 => obtain ⟨u, _, hbu⟩ := ih1 obtain ⟨v, hbv, _⟩ := ih2 @@ -681,10 +679,8 @@ abbrev StronglyConfluent (r : α → α → Prop) := def Commute (r₁ r₂ : α → α → Prop) := ∀ {x y₁ y₂}, ReflTransGen r₁ x y₁ → ReflTransGen r₂ x y₂ → ∃ z, ReflTransGen r₂ y₁ z ∧ ReflTransGen r₁ y₂ z -theorem Commute.symmetric : Symmetric (@Commute α) := by - intro r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ - obtain ⟨_, _, _⟩ := h x_y₂ x_y₁ - grind +instance : Std.Symm (@Commute α) where + symm r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ := by grind [h x_y₂ x_y₁] theorem Commute.toConfluent : Commute r r = Confluent r := rfl @@ -760,7 +756,7 @@ theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) ( induction ab generalizing c with | refl => exists c | @tail x y ax xy ih => - have h_comm : Commute (r₁ ⊔ r₂) (r₁ ⊔ r₂) := by apply_rules [join_left, symmetric] + have h_comm : Commute (r₁ ⊔ r₂) (r₁ ⊔ r₂) := by apply_rules [join_left, symm] obtain ⟨z, xz, cz⟩ := ih ac obtain ⟨w, yw, zw⟩ := h_comm (.single xy) xz exact ⟨w, yw, cz.trans zw⟩ diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean index 989142ac67..f2b3a27189 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean @@ -96,7 +96,8 @@ theorem confluent_beta_eta : Confluent (@FullBetaEta Var) := by apply join_confluent · exact confluence_beta · exact stronglyConfluent_eta.toConfluent - exact symmetric stronglyCommute_eta_beta.toCommute + apply symm + exact stronglyCommute_eta_beta.toCommute end LambdaCalculus.LocallyNameless.Untyped.Term diff --git a/lake-manifest.json b/lake-manifest.json index ac8a9ed2bb..919ac1cf23 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "8589236b8b8cc82492e3306df39c0fb308e0523c", + "rev": "73b2611ac34fe053446b21322ee51d19cb27b3e7", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "8589236b8b8cc82492e3306df39c0fb308e0523c", + "inputRev": "73b2611ac34fe053446b21322ee51d19cb27b3e7", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "0bbac0a875ac0fd9366cb5bd4211da92d960ac84", + "rev": "5dd219c775e402f818b42cd3997b5cf21017babf", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.toml b/lakefile.toml index 0d8726a609..33bb67166e 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "8589236b8b8cc82492e3306df39c0fb308e0523c" +rev = "73b2611ac34fe053446b21322ee51d19cb27b3e7" [[lean_lib]] name = "Cslib" From d5148c089cd075511b06070b944efcff2f2f7b2e Mon Sep 17 00:00:00 2001 From: Chris Henson <46805207+chenson2018@users.noreply.github.com> Date: Sat, 13 Jun 2026 01:21:16 -0400 Subject: [PATCH 22/51] chore: split the `Relation` module (#632) This was already at ~1000 lines and growing. I've split this without making any other changes with one exception: the `CoeDep` instances previously specific to `dom` and `cod` are generalized as this makes imports less awkward (and is also useful for another PR I will make soon). --- Cslib.lean | 6 +- Cslib/Computability/URM/Execution.lean | 2 +- Cslib/Foundations/Data/Relation.lean | 868 ------------------ Cslib/Foundations/Relation/Attr.lean | 86 ++ Cslib/Foundations/Relation/Confluence.lean | 402 ++++++++ Cslib/Foundations/Relation/Defs.lean | 135 +++ Cslib/Foundations/Relation/Domain.lean | 82 ++ Cslib/Foundations/Relation/Euclidean.lean | 266 ++++++ .../Semantics/LTS/Bisimulation.lean | 2 +- .../CombinatoryLogic/Confluence.lean | 1 + Cslib/Languages/CombinatoryLogic/Defs.lean | 3 +- .../LocallyNameless/Fsub/Reduction.lean | 2 +- .../LocallyNameless/Stlc/Safety.lean | 1 + .../LocallyNameless/Stlc/StrongNorm.lean | 1 - .../LocallyNameless/Untyped/FullBeta.lean | 2 +- .../Untyped/FullBetaConfluence.lean | 1 + .../LocallyNameless/Untyped/FullEta.lean | 2 +- .../Untyped/FullEtaConfluence.lean | 1 + .../LocallyNameless/Untyped/MultiSubst.lean | 1 - .../LocallyNameless/Untyped/StrongNorm.lean | 1 + Cslib/Logics/Modal/Basic.lean | 2 +- CslibTests/Reduction.lean | 2 +- 22 files changed, 990 insertions(+), 879 deletions(-) delete mode 100644 Cslib/Foundations/Data/Relation.lean create mode 100644 Cslib/Foundations/Relation/Attr.lean create mode 100644 Cslib/Foundations/Relation/Confluence.lean create mode 100644 Cslib/Foundations/Relation/Defs.lean create mode 100644 Cslib/Foundations/Relation/Domain.lean create mode 100644 Cslib/Foundations/Relation/Euclidean.lean diff --git a/Cslib.lean b/Cslib.lean index 1cc4d08bf8..5932e92075 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -66,12 +66,16 @@ public import Cslib.Foundations.Data.OmegaSequence.Init public import Cslib.Foundations.Data.OmegaSequence.Temporal public import Cslib.Foundations.Data.PFunctor.Free public import Cslib.Foundations.Data.RelatesInSteps -public import Cslib.Foundations.Data.Relation public import Cslib.Foundations.Data.Set.Saturation public import Cslib.Foundations.Data.StackTape public import Cslib.Foundations.Lint.Basic public import Cslib.Foundations.Logic.InferenceSystem public import Cslib.Foundations.Logic.LogicalEquivalence +public import Cslib.Foundations.Relation.Attr +public import Cslib.Foundations.Relation.Confluence +public import Cslib.Foundations.Relation.Defs +public import Cslib.Foundations.Relation.Domain +public import Cslib.Foundations.Relation.Euclidean public import Cslib.Foundations.Semantics.FLTS.Basic public import Cslib.Foundations.Semantics.FLTS.FLTSToLTS public import Cslib.Foundations.Semantics.FLTS.LTSToFLTS diff --git a/Cslib/Computability/URM/Execution.lean b/Cslib/Computability/URM/Execution.lean index 00526d3893..83e5c853e4 100644 --- a/Cslib/Computability/URM/Execution.lean +++ b/Cslib/Computability/URM/Execution.lean @@ -6,7 +6,7 @@ Authors: Jesse Alama module public import Cslib.Computability.URM.Defs -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Confluence public import Mathlib.Data.Part /-! # URM Execution Semantics diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean deleted file mode 100644 index dbd6574660..0000000000 --- a/Cslib/Foundations/Data/Relation.lean +++ /dev/null @@ -1,868 +0,0 @@ -/- -Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Fabrizio Montesi, Thomas Waring, Chris Henson --/ - -module - -public import Cslib.Init -public import Mathlib.Data.List.TFAE -public import Mathlib.Tactic.TFAE -public import Mathlib.Order.Comparable -public import Mathlib.Order.WellFounded -public import Mathlib.Order.BooleanAlgebra.Basic -public import Mathlib.Data.Fintype.EquivFin - -/-! # Relations - -## References - -* [*Term Rewriting and All That*][Baader1998] -* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018] - --/ - -@[expose] public section - -open Relator - -variable {α : Type*} {r r₁ r₂ : α → α → Prop} - -theorem WellFounded.ofTransGen (trans_wf : WellFounded (Relation.TransGen r)) : WellFounded r := by - grind [WellFounded.wellFounded_iff_has_min, Relation.TransGen] - -@[simp, grind =] -theorem WellFounded.iff_transGen : WellFounded (Relation.TransGen r) ↔ WellFounded r := - ⟨ofTransGen, transGen⟩ - -namespace Relation - -/-- The empty (heterogeneous) relation, which always returns `False`. -/ -@[nolint unusedArguments] -def emptyHRelation {α : Sort u} {β : Sort v} (_ : α) (_ : β) := False - -@[simp, grind =] -theorem emptyHRelation_emptyRelation : (emptyHRelation : α → α → Prop) = emptyRelation := rfl - -@[simp, grind =] -theorem emptyHrelation_apply (a : α) (b : β) : emptyHRelation a b ↔ False := .rfl - -section dom_cod - -variable {β : Type*} {r : α → β → Prop} - -/-- Domain of a relation. -/ -def dom (r : α → β → Prop) : Set α := {a | ∃ b, r a b} - -/-- Codomain of a relation, aka range. -/ -def cod (r : α → β → Prop) : Set β := {b | ∃ a, r a b} - -@[simp, grind =] lemma mem_dom : a ∈ dom r ↔ ∃ b, r a b := .rfl -@[simp, grind =] lemma mem_cod : b ∈ cod r ↔ ∃ a, r a b := .rfl - -@[gcongr] lemma dom_mono (h : r₁ ≤ r₂) : dom r₁ ⊆ dom r₂ := fun a ⟨b, hab⟩ => ⟨b, h a b hab⟩ -@[gcongr] lemma cod_mono (h : r₁ ≤ r₂) : cod r₁ ⊆ cod r₂ := fun b ⟨a, hab⟩ => ⟨a, h a b hab⟩ - -@[simp, grind =] -lemma dom_empty : dom (emptyHRelation : α → β → Prop) = ∅ := by grind - -@[simp, grind =] -lemma cod_empty : cod (emptyHRelation : α → β → Prop) = ∅ := by grind - -@[simp, grind =] -lemma dom_eq_empty_iff : dom r = ∅ ↔ r = emptyHRelation where - mp h := by - ext a b - simp - grind => have : a ∈ dom r; finish - mpr := by grind - -@[simp, grind =] -lemma cod_eq_empty_iff : cod r = ∅ ↔ r = emptyHRelation where - mp h := by - ext a b - simp - grind => have : b ∈ cod r; finish - mpr h := by grind - -@[simp] -lemma cod_inv : cod (fun a b => r b a) = dom r := rfl - -@[simp] -lemma dom_inv : dom (fun a b => r b a) = cod r := rfl - -end dom_cod - -instance : CoeDep (α → α → Prop) r (dom r → dom r → Prop) where - coe a b := r a b - -instance : CoeDep (α → α → Prop) r (cod r → cod r → Prop) where - coe a b := r a b - -theorem _root_.Std.Trichotomous.subsingleton_cod [Std.Trichotomous r] : - Subsingleton ((cod r)ᶜ : Set α) := by - constructor - rintro ⟨b₁, _⟩ ⟨b₂, _⟩ - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b₁ b₂ - grind - -theorem _root_.Std.Trichotomous.subsingleton_dom [Std.Trichotomous r] : - Subsingleton ((dom r)ᶜ : Set α) := by - constructor - rintro ⟨a₁, _⟩ ⟨a₂, _⟩ - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a₁ a₂ - grind - -attribute [scoped grind] ReflGen TransGen ReflTransGen EqvGen CompRel - -theorem ReflGen.to_eqvGen (h : ReflGen r a b) : EqvGen r a b := by - induction h <;> grind - -theorem TransGen.to_eqvGen (h : TransGen r a b) : EqvGen r a b := by - induction h <;> grind - -theorem ReflTransGen.to_eqvGen (h : ReflTransGen r a b) : EqvGen r a b := by - induction h <;> grind - -theorem SymmGen.to_eqvGen (h : SymmGen r a b) : EqvGen r a b := by - induction h <;> grind - -attribute [scoped grind →] ReflGen.to_eqvGen TransGen.to_eqvGen ReflTransGen.to_eqvGen - SymmGen.to_eqvGen - -/-- The join of the reflexive transitive closure. This is not named in Mathlib, but see - `#loogle Relation.Join (Relation.ReflTransGen ?r)` -/ -abbrev MJoin (r : α → α → Prop) := Join (ReflTransGen r) - -theorem MJoin.refl (a : α) : MJoin r a a := by - use a - -theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by - use b - -/-- The relation `r` 'up to' the relation `s`. -/ -def UpTo (r s : α → α → Prop) : α → α → Prop := Comp s (Comp r s) - -/-- A relation `r` is (right) Euclidean if `r a b` and `r a c` guarantee `r b c`. -/ -class RightEuclidean (r : α → α → Prop) where - rightEuclidean : r a b → r a c → r b c - -/-- A relation `r` is (left) Euclidean if `r a c` and `r b c` guarantee `r a b`. -/ -class LeftEuclidean (r : α → α → Prop) where - leftEuclidean {a b c} : r a c → r b c → r a b - -namespace RightEuclidean - -variable [RightEuclidean r] - -/-- A `RightEuclidean` relation is reflexive on its range -/ -theorem refl_cod (ab : r a b) : r b b := rightEuclidean ab ab - -theorem refl_cod' : b ∈ cod r → r b b := fun ⟨_, ab⟩ ↦ refl_cod ab - -/-- The converse of a `RightEuclidean` relation is `LeftEuclidean` -/ -theorem leftEuclidean_swap : LeftEuclidean (fun a b => r b a) where - leftEuclidean ca cb := rightEuclidean cb ca - -instance [Std.Refl r] : Std.Symm r where - symm a _ ab := rightEuclidean ab (refl a) - -theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where - trans a b c ab bc := by - have := Std.Trichotomous.trichotomous (r := r) a c - have cc := refl_cod bc - have (ca : r c a) := rightEuclidean ca cc - grind - -theorem antisymm_rightUnique [Std.Antisymm r] : Relator.RightUnique r := by - intros a b c ab ac - exact antisymm (rightEuclidean ab ac) (rightEuclidean ac ab) - -theorem rightUnique_antisymm (h : Relator.RightUnique r) : Std.Antisymm r where - antisymm _ _ ab ba := h ba (refl_cod ab) - -theorem rightUnique_trans (h : Relator.RightUnique r) : IsTrans α r where - trans a b c ab bc := by - have eq : c = b := h bc (refl_cod ab) - simpa [eq] - -theorem rightTotal_equiv (h : Relator.RightTotal r) : IsEquiv α r := by - have : Std.Refl r := ⟨fun a => refl_cod (h a).choose_spec⟩ - exact {toIsTrans := ⟨fun _ _ _ ab bc => rightEuclidean (symm ab) bc⟩} - -omit [RightEuclidean r] in -theorem leftTotal_rightUnique_trans (h₁ : LeftTotal r) (h₂ : RightUnique r) [IsTrans α r] : - RightEuclidean r where - rightEuclidean {a b c} ab ac := by - obtain ⟨d, dc⟩ := h₁ c - have : b = c := h₂ ab ac - have : d = c := h₂ (_root_.trans ac dc) ac - grind - -private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : - ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by - rintro ⟨a, b, c, _⟩ - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c - have := antisymm_rightUnique (r := r) - have := @refl_cod (r := r) - grind [Relator.RightUnique] - -theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by - classical - by_contra! h - apply three_contra (r := r) - have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3 - have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard - use a, b, c - -theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] : - Fintype.card α ≤ 2 := by - by_contra! h - apply three_contra (r := r) - have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h - use a, b, c - -theorem cod_subset_dom : cod r ⊆ dom r := fun b ⟨_, ab⟩ ↦ ⟨b, refl_cod ab⟩ - -instance : RightEuclidean (α := cod r) r where - rightEuclidean := rightEuclidean - -instance : RightEuclidean (α := dom r) r where - rightEuclidean := rightEuclidean - -theorem rightTotal_cod : Relator.RightTotal (α := cod r) (β := cod r) r := - fun ⟨_, _, h⟩ => ⟨_, refl_cod h⟩ - -theorem equiv_cod : IsEquiv (cod r) r := rightTotal_equiv rightTotal_cod - -end RightEuclidean - -namespace LeftEuclidean - -variable [LeftEuclidean r] - -/-- A `LeftEuclidean` relation is reflexive on its domain -/ -theorem refl_dom (ab : r a b) : r a a := leftEuclidean ab ab - -theorem refl_dom' : a ∈ dom r → r a a := fun ⟨_, ab⟩ ↦ refl_dom ab - -/-- The converse of a `LeftEuclidean` relation is `RightEuclidean` -/ -theorem rightEuclidean_swap : RightEuclidean (fun a b => r b a) where - rightEuclidean ab ac := leftEuclidean ac ab - -instance [Std.Refl r] : Std.Symm r where - symm _ b ab := leftEuclidean (refl b) ab - -theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where - trans a b c ab bc := by - have := Std.Trichotomous.trichotomous (r := r) a c - have aa := refl_dom ab - have (ca : r c a) := leftEuclidean aa ca - grind - -theorem antisymm_leftUnique [Std.Antisymm r] : Relator.LeftUnique r := by - intros a b c ac bc - exact antisymm (leftEuclidean ac bc) (leftEuclidean bc ac) - -theorem leftUnique_antisymm (h : Relator.LeftUnique r) : Std.Antisymm r where - antisymm _ _ ab ba := h ab (refl_dom ba) - -theorem leftUnique_trans (h : Relator.LeftUnique r) : IsTrans α r where - trans a b c ab bc := by - have eq : a = b := h ab (refl_dom bc) - simpa [eq] - -theorem leftTotal_equiv (h : Relator.LeftTotal r) : IsEquiv α r := by - have : Std.Refl r := ⟨fun a => refl_dom (h a).choose_spec⟩ - exact {toIsTrans := ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩} - -omit [LeftEuclidean r] in -theorem rightTotal_leftUnique_trans (h₁ : RightTotal r) (h₂ : LeftUnique r) [IsTrans α r] : - LeftEuclidean r where - leftEuclidean {a b c} ac bc := by - obtain ⟨d, da⟩ := h₁ a - have : a = b := h₂ ac bc - have : a = d := h₂ ac (_root_.trans da ac) - grind - -private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : - ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by - rintro ⟨a, b, c, _⟩ - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c - have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c - have := antisymm_leftUnique (r := r) - have := @refl_dom (r := r) - grind [Relator.LeftUnique] - -theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by - classical - by_contra! h - apply three_contra (r := r) - have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3 - have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard - use a, b, c - -theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] : - Fintype.card α ≤ 2 := by - by_contra! h - apply three_contra (r := r) - have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h - use a, b, c - -theorem dom_subset_cod : dom r ⊆ cod r := fun a ⟨_, ab⟩ ↦ ⟨a, refl_dom ab⟩ - -instance : LeftEuclidean (α := cod r) r where - leftEuclidean := leftEuclidean - -instance : LeftEuclidean (α := dom r) r where - leftEuclidean := leftEuclidean - -theorem leftTotal_dom : Relator.LeftTotal (α := dom r) (β := dom r) r := - fun ⟨_, _, h⟩ => ⟨_, refl_dom h⟩ - -theorem equiv_dom : IsEquiv (dom r) r := leftTotal_equiv leftTotal_dom - -end LeftEuclidean - -section euclidean_symm - -variable [Std.Symm r] - -open RightEuclidean LeftEuclidean in -private theorem symm_equivalents : [RightEuclidean r, LeftEuclidean r, IsTrans α r].TFAE := by - tfae_have 1 → 2 := fun _ => ⟨fun ac bc => rightEuclidean (symm ac) (symm bc)⟩ - tfae_have 2 → 3 := fun _ => ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩ - tfae_have 3 → 1 := fun _ => ⟨fun ab ac => _root_.trans (symm ab) ac⟩ - tfae_finish - -/-- For a symmetric relation, `LeftEuclidean` and `RightEuclidean` are equivalent. -/ -theorem symm_leftEuclidean_iff_rightEuclidean : LeftEuclidean r ↔ RightEuclidean r := - List.TFAE.out symm_equivalents 1 0 - -/-- For a symmetric relation, `LeftEuclidean` and transitivity are equivalent. -/ -theorem symm_leftEuclidean_iff_trans : LeftEuclidean r ↔ IsTrans α r := - List.TFAE.out symm_equivalents 1 2 - -/-- For a symmetric relation, `RightEuclidean` and transitivity are equivalent. -/ -theorem symm_rightEuclidean_iff_trans : RightEuclidean r ↔ IsTrans α r := - List.TFAE.out symm_equivalents 0 2 - -end euclidean_symm - -theorem leftEuclidean_rightEuclidean_dom_cod_eq [LeftEuclidean r] [RightEuclidean r] : - dom r = cod r := by - have : dom r ⊆ cod r := LeftEuclidean.dom_subset_cod - have : cod r ⊆ dom r := RightEuclidean.cod_subset_dom - grind - -theorem dom_cod_leftEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] : - LeftEuclidean r where - leftEuclidean {a b c} ac bc := by - have cb : r c b := equiv_dom.symm ⟨_, _, bc⟩ ⟨c, by grind⟩ bc - exact equiv_dom.trans ⟨_, _, ac⟩ ⟨_, _, cb⟩ ⟨_, by grind⟩ ac cb - -lemma dom_cod_rightEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] : - RightEuclidean r where - rightEuclidean {a b c} ab ac := by - have ba : r b a := equiv_dom.symm ⟨a, _, ab⟩ ⟨b, by grind⟩ ab - exact equiv_dom.trans ⟨_, _, ba⟩ ⟨_, _, ac⟩ ⟨c, by grind⟩ ba ac - -/-- A relation is both left and right Euclidean if and only if the relation is an equivalence on - coinciding domain and codomain. -/ -theorem leftEuclidean_rightEuclidean_iff_dom_cod : - LeftEuclidean r ∧ RightEuclidean r ↔ dom r = cod r ∧ IsEquiv (dom r) r where - mp := fun ⟨_, _⟩ ↦ ⟨leftEuclidean_rightEuclidean_dom_cod_eq, LeftEuclidean.equiv_dom⟩ - mpr := fun ⟨eq, _⟩ ↦ ⟨dom_cod_leftEuclidean eq, dom_cod_rightEuclidean eq⟩ - -/-- A relation has the diamond property when all reductions with a common origin are joinable -/ -abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c - -/-- A relation is confluent when its reflexive transitive closure has the diamond property. -/ -abbrev Confluent (r : α → α → Prop) := Diamond (ReflTransGen r) - -/-- A relation is semi-confluent when single and multiple steps with common origin - are multi-joinable. -/ -abbrev SemiConfluent (r : α → α → Prop) := - ∀ {x y₁ y₂}, ReflTransGen r x y₂ → r x y₁ → Join (ReflTransGen r) y₁ y₂ - -/-- A relation has the Church Rosser property when equivalence implies multi-joinability. -/ -abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join (ReflTransGen r) x y - -/-- Extending a multistep reduction by a single step preserves multi-joinability. -/ -lemma Diamond.extend (h : Diamond r) : - ReflTransGen r a b → r a c → Join (ReflTransGen r) b c := by - intros ab ac - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c, .single ac - case head a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h ac a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .head cd d_d'⟩ - -/-- The diamond property implies confluence. -/ -theorem Diamond.toConfluent (h : Diamond r) : Confluent r := by - intros a b c ab bc - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c - case head _ _ a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h.extend bc a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .trans cd d_d'⟩ - -theorem Confluent.toChurchRosser (h : Confluent r) : ChurchRosser r := by - intro x y h_eqv - induction h_eqv with - | rel _ b => exists b; grind [ReflTransGen.single] - | refl a => exists a - | symm a b _ ih => exact symm ih - | trans _ _ _ _ _ ih1 ih2 => - obtain ⟨u, _, hbu⟩ := ih1 - obtain ⟨v, hbv, _⟩ := ih2 - obtain ⟨w, _, _⟩ := h hbu hbv - exists w - grind [ReflTransGen.trans] - -theorem SemiConfluent.toConfluent (h : SemiConfluent r) : Confluent r := by - intro x y1 y2 h_xy1 h_xy2 - induction h_xy1 with - | refl => use y2 - | tail h_xz h_zy1 ih => - obtain ⟨u, h_zu, _⟩ := ih - obtain ⟨v, _, _⟩ := h h_zu h_zy1 - exists v - grind [ReflTransGen.trans] - -attribute [scoped grind →] Confluent.toChurchRosser SemiConfluent.toConfluent - -private theorem confluent_equivalents : [ChurchRosser r, SemiConfluent r, Confluent r].TFAE := by - grind [List.tfae_cons_cons, List.tfae_singleton] - -theorem SemiConfluent_iff_ChurchRosser : SemiConfluent r ↔ ChurchRosser r := - List.TFAE.out confluent_equivalents 1 0 - -theorem Confluent_iff_ChurchRosser : Confluent r ↔ ChurchRosser r := - List.TFAE.out confluent_equivalents 2 0 - -theorem Confluent_iff_SemiConfluent : Confluent r ↔ SemiConfluent r := - List.TFAE.out confluent_equivalents 2 1 - -theorem Confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) : Confluent r := by - intro a b c hab hac - exact ⟨x, h b, h c⟩ - -/-- An element is reducible with respect to a relation if there is a value it is related to. -/ -abbrev Reducible (r : α → α → Prop) (x : α) : Prop := ∃ y, r x y - -/-- A relation `r` is serial if every element is `Reducible`, i.e. `Relator.LeftTotal`. -/ -class Serial (r : α → α → Prop) where - serial : Relator.LeftTotal r - -@[scoped grind →] -lemma refl_serial (r : α → α → Prop) (h : Std.Refl r) : Relation.Serial r where - serial a := ⟨a, h.refl a⟩ - -instance [instRefl : Std.Refl r] : Relation.Serial r := refl_serial r instRefl - -/-- An element is normal if it is not reducible. -/ -abbrev Normal (r : α → α → Prop) (x : α) : Prop := ¬ Reducible r x - -theorem Normal_iff (r : α → α → Prop) (x : α) : Normal r x ↔ ∀ y, ¬ r x y := by - rw [Normal, not_exists] - -/-- An element is normalizable if it is related to a normal element. -/ -abbrev Normalizable (r : α → α → Prop) (x : α) : Prop := - ∃ n, ReflTransGen r x n ∧ Normal r n - -/-- A relation is normalizing when every element is normalizable. -/ -abbrev Normalizing (r : α → α → Prop) : Prop := - ∀ x, Normalizable r x - -/-- A multi-step from a normal form must be reflexive. -/ -@[grind =>] -theorem Normal.reflTransGen_eq (h : Normal r x) (xy : ReflTransGen r x y) : x = y := by - induction xy <;> grind - -/-- For a Church-Rosser relation, elements in an equivalence class must be multi-step related. -/ -theorem ChurchRosser.normal_eqvGen_reflTransGen (cr : ChurchRosser r) (norm : Normal r x) - (xy : EqvGen r y x) : ReflTransGen r y x := by - have ⟨_, _, _⟩ := cr xy - grind - -/-- For a Church-Rosser relation there is one normal form in each equivalence class. -/ -theorem ChurchRosser.normal_eq (cr : ChurchRosser r) (nx : Normal r x) (ny : Normal r y) - (xy : EqvGen r x y) : x = y := by - have ⟨z, _, _⟩ := cr xy - grind - -/-- A pair of subrelations lifts to transitivity on the relation. -/ -@[implicit_reducible] -def transLeftRight (s s' r : α → α → Prop) [IsTrans α r] (h : s ≤ r) (h' : s' ≤ r) : - Trans s s' r where - trans hab hbc := _root_.trans (h _ _ hab) (h' _ _ hbc) - -/-- A subrelation lifts to transitivity on the left of the relation. -/ -@[implicit_reducible] -def transLeft (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans s r r where - trans hab hbc := _root_.trans (h _ _ hab) hbc - -/-- A subrelation lifts to transitivity on the right of the relation. -/ -@[implicit_reducible] -def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r s r where - trans hab hbc := _root_.trans hab (h _ _ hbc) - -/-- Confluence implies that multi-step joinability is an equivalence. -/ -theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) : - Equivalence (Join (ReflTransGen r)) := by - apply equivalence_join - grind - -/-- An element `x` is `SN` (for strongly-normalising) for a relation `r` if it is accesible under -the inverse of `r`. -/ -abbrev SN (r : α → α → Prop) := Acc (fun a b => r b a) - -set_option linter.tacticAnalysis.verifyGrindOnly false in -lemma SN_iff_SN_of_rel (x : α) : SN r x ↔ ∀ y, r x y → SN r y := by grind only [Acc] - -lemma SN.intro : (h : ∀ y, r x y → SN r y) → SN r x := (SN_iff_SN_of_rel x).mpr - -lemma SN.of_rel (hx : SN r x) (h : r x y) : SN r y := Acc.inv hx h - -@[grind →] -lemma SN.of_rel_reflTransGen (hx : SN r x) (h : ReflTransGen r x y) : SN r y := by - induction h with - | refl => exact hx - | tail _ h ih => exact ih.of_rel h - -lemma SN.transGen (hx : SN r x) : SN (TransGen r) x := by - have eq : TransGen (Function.swap r) = (fun a b => TransGen r b a) := by - ext - exact transGen_swap - simpa [eq] using Acc.transGen hx - -lemma SN.of_le {r' : α → α → Prop} (hx : SN r x) (h : r' ≤ r) : SN r' x := by - refine Subrelation.accessible ?_ hx - exact subrelation_iff_le.mpr fun {x y} => h y x - -@[simp] -lemma SN.iff_transGen (x : α) : SN (TransGen r) x ↔ SN r x := - ⟨fun hx => hx.of_le <| fun _ _ => TransGen.single, transGen⟩ - -/-- `SN r x` is equivalent to the more elementary definition, that there is no infinite sequence -of reductions starting with `x`. -/ -theorem SN.iff_isEmpty_chain : - SN r x ↔ IsEmpty {f : ℕ → α | f 0 = x ∧ ∀ n, r (f n) (f (n + 1))} := - acc_iff_isEmpty_descending_chain - -lemma SN.onFun_of_image {r : β → β → Prop} {f : α → β} (hx : SN r (f x)) : - SN (Function.onFun r f) x := InvImage.accessible f hx - -lemma SN.of_normal (hx : Normal r x) : SN r x := SN.intro fun y hy => (hx ⟨y, hy⟩).elim - -/-- A relation is terminating when the inverse of its transitive closure is well-founded. - Note that this is also called Noetherian or strongly normalizing in the literature. -/ -abbrev Terminating (r : α → α → Prop) := WellFounded (fun a b => r b a) - -lemma Terminating.apply (hr : Terminating r) (x : α) : SN r x := WellFounded.apply hr x - -lemma Terminating.iff_forall_sn : Terminating r ↔ ∀ x, SN r x := - ⟨WellFounded.apply, WellFounded.intro⟩ - -theorem Terminating.toTransGen (ht : Terminating r) : Terminating (TransGen r) := by - simp_rw [iff_forall_sn, SN.iff_transGen] at ht ⊢ - exact ht - -theorem Terminating.ofTransGen : Terminating (TransGen r) → Terminating r := by - simp_rw [iff_forall_sn, SN.iff_transGen] - exact id - -theorem Terminating.iff_transGen : Terminating (TransGen r) ↔ Terminating r := by - simp_rw [iff_forall_sn, SN.iff_transGen] - -theorem Terminating.iff_isEmpty_chain : - Terminating r ↔ IsEmpty {f : ℕ → α // ∀ n, r (f n) (f (n + 1))} := - wellFounded_iff_isEmpty_descending_chain - -theorem Terminating.of_le {r' : α → α → Prop} (hr : Terminating r) (h : r' ≤ r) : - Terminating r' := by - rw [iff_forall_sn] at hr ⊢ - exact fun x => (hr x).of_le h - -lemma Terminating.subtype_sn (r : α → α → Prop) : - Terminating (α := {x // SN r x}) (fun a b => r a b) := - iff_forall_sn.mpr fun x => x.property.onFun_of_image - -theorem SN.isNormalizable (hx : SN r x) : Normalizable r x := by - -- restrict to the subtype where all elements are `SN`, so `flip r` is well-founded - obtain ⟨⟨y, hsn⟩, hred : ReflTransGen r x y, hnorm⟩ := - (Terminating.subtype_sn r).has_min - (s := Subtype.val ⁻¹' ({y | ReflTransGen r x y})) ⟨⟨x, hx⟩, ReflTransGen.refl⟩ - use y, hred - intro ⟨z, hyz⟩ - exact hnorm ⟨z, hsn.of_rel hyz⟩ (.tail hred hyz) hyz - -theorem Terminating.isNormalizing (hr : Terminating r) : Normalizing r := - fun x => (hr.apply x).isNormalizable - -theorem Terminating.isConfluent_iff_all_unique_Normal (ht : Terminating r) : - Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := by - have hn : Normalizing r := ht.isNormalizing - constructor - · intro hc a - apply existsUnique_of_exists_of_unique (hn a) - rintro n₁ n₂ ⟨hr₁, hn₁⟩ ⟨hr₂, hn₂⟩ - have hj : Join (ReflTransGen r) n₁ n₂ := hc hr₁ hr₂ - obtain ⟨m, h₁, h₂⟩ := hj - rw [Normal.reflTransGen_eq hn₁ h₁, Normal.reflTransGen_eq hn₂ h₂] - · intro h a b c hab hac - obtain ⟨na, ⟨han, hnnor⟩, H⟩ := h a - use na - obtain ⟨nb, hbnb, hnb⟩ := hn b - obtain ⟨nc, hcnc, hnc⟩ := hn c - have hanb : (ReflTransGen r) a nb := ReflTransGen.trans hab hbnb - have hanc : (ReflTransGen r) a nc := ReflTransGen.trans hac hcnc - have hnanb : nb = na := H nb ⟨hanb, hnb⟩ - have hnanc : nc = na := H nc ⟨hanc, hnc⟩ - rw [hnanb] at hbnb - rw [hnanc] at hcnc - exact ⟨hbnb, hcnc⟩ - -/-- A relation is convergent when it is both confluent and terminating. -/ -abbrev Convergent (r : α → α → Prop) := Confluent r ∧ Terminating r - -theorem Convergent.isTerminating (h : Convergent r) : Terminating r := h.right - -theorem Convergent.isConfluent (h : Convergent r) : Confluent r := h.left - -theorem Convergent.isNormalizing (h : Convergent r) : Normalizing r := h.isTerminating.isNormalizing - -theorem Convergent.unique_Normal (h : Convergent r) : - ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := - h.isTerminating.isConfluent_iff_all_unique_Normal.mp h.isConfluent - -/-- A relation is locally confluent when all reductions with a common origin are multi-joinable -/ -abbrev LocallyConfluent (r : α → α → Prop) := - ∀ {a b c : α}, r a b → r a c → Join (ReflTransGen r) b c - -theorem Confluent.toLocallyConfluent (h : Confluent r) : LocallyConfluent r := by - intro _ _ _ ab ac - exact h (.single ab) (.single ac) - -/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ -theorem LocallyConfluent.Terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : - Confluent r := by - intro x - induction x using ht.induction with - | h x ih => - intro y z xy xz - cases xy.cases_head with - | inl => exists z; grind - | inr h => - obtain ⟨y₁, x_y₁, y₁_y⟩ := h - cases xz.cases_head with - | inl => exists y; grind - | inr h => - obtain ⟨z₁, x_z₁, z₁_z⟩ := h - have ⟨u, z₁_u, y₁_u⟩ := hlc x_z₁ x_y₁ - have ⟨v, uv, yv⟩ : Join (ReflTransGen r) u y := by grind - have ⟨w, vw, zw⟩ : Join (ReflTransGen r) v z := by grind [ReflTransGen.trans] - exact ⟨w, .trans yv vw, zw⟩ - -/-- A relation is strongly confluent when single steps are reflexive- and multi-joinable. -/ -abbrev StronglyConfluent (r : α → α → Prop) := - ∀ {x y₁ y₂}, r x y₁ → r x y₂ → ∃ z, ReflGen r y₁ z ∧ ReflTransGen r y₂ z - -/-- Generalization of `Confluent` to two relations. -/ -def Commute (r₁ r₂ : α → α → Prop) := ∀ {x y₁ y₂}, - ReflTransGen r₁ x y₁ → ReflTransGen r₂ x y₂ → ∃ z, ReflTransGen r₂ y₁ z ∧ ReflTransGen r₁ y₂ z - -instance : Std.Symm (@Commute α) where - symm r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ := by grind [h x_y₂ x_y₁] - -theorem Commute.toConfluent : Commute r r = Confluent r := rfl - -/-- Generalization of `StronglyConfluent` to two relations. -/ -def StronglyCommute (r₁ r₂ : α → α → Prop) := - ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, ReflGen r₂ y₁ z ∧ ReflTransGen r₁ y₂ z - -theorem StronglyCommute.toStronglyConfluent : StronglyCommute r r = StronglyConfluent r := rfl - -/-- Generalization of `Diamond` to two relations. -/ -def DiamondCommute (r₁ r₂ : α → α → Prop) := - ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, r₂ y₁ z ∧ r₁ y₂ z - -theorem DiamondCommute.toDiamond : DiamondCommute r r = Diamond r := by rfl - -theorem StronglyCommute.extend (h : StronglyCommute r₁ r₂) (xy : ReflTransGen r₁ x y) - (xz : r₂ x z) : ∃ w, ReflGen r₂ y w ∧ ReflTransGen r₁ z w := by - induction xy with - | refl => exact ⟨z, .single xz, .refl⟩ - | @tail b c _ bc ih => - obtain ⟨w, bw, zw⟩ := ih - cases bw with - | refl => exact ⟨c, .refl, zw.trans (.single bc)⟩ - | single bw => cases h bc bw; grind [ReflTransGen.trans] - -theorem StronglyCommute.toCommute (h : StronglyCommute r₁ r₂) : Commute r₁ r₂ := by - intro x y₁ y₂ x_y₁ x_y₂ - induction x_y₂ with - | refl => exists y₁ - | @tail a b xa ab ih => - obtain ⟨z, y₁_z, y₂_z⟩ := ih - obtain ⟨w, zw, bw⟩ := h.extend y₂_z ab - exact ⟨w, y₁_z.trans zw.to_reflTransGen, bw⟩ - -theorem StronglyConfluent.toConfluent (h : StronglyConfluent r) : Confluent r := - StronglyCommute.toCommute h - -variable {r₁ r₂ : α → α → Prop} - -@[scoped grind <=] -theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := - Or.inl r₁_ab - -@[scoped grind <=] -theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := - Or.inr r₂_ab - -@[scoped grind <=] -theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := by - induction r₁_ab <;> grind - -@[scoped grind <=] -theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := by - induction r₂_ab <;> grind - -lemma Commute.join_left (c₁ : Commute r₁ r₃) (c₂ : Commute r₂ r₃) : Commute (r₁ ⊔ r₂) r₃ := by - intro x y z xy xz - induction xy with - | refl => grind - | @tail b c _ bc ih => - have ⟨w, bw, _⟩ := ih - cases bc with - | inl bc => - obtain ⟨_, _, _⟩ := c₁ (.single bc) bw - grind [ReflTransGen.trans] - | inr bc => - obtain ⟨_, _, _⟩ := c₂ (.single bc) bw - grind [ReflTransGen.trans] - -theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) (comm : Commute r₁ r₂) : - Confluent (r₁ ⊔ r₂) := by - intro a b c ab ac - induction ab generalizing c with - | refl => exists c - | @tail x y ax xy ih => - have h_comm : Commute (r₁ ⊔ r₂) (r₁ ⊔ r₂) := by apply_rules [join_left, symm] - obtain ⟨z, xz, cz⟩ := ih ac - obtain ⟨w, yw, zw⟩ := h_comm (.single xy) xz - exact ⟨w, yw, cz.trans zw⟩ - -/-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/ -theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) : - ReflTransGen r₁ = ReflTransGen r₂ := by - ext - exact ⟨ReflTransGen.mono @h₁, reflTransGen_closed @h₂⟩ - -lemma ReflGen.compRel_symm : ReflGen (SymmGen r) a b → ReflGen (SymmGen r) b a -| .refl => .refl -| .single (.inl h) => .single (.inr h) -| .single (.inr h) => .single (.inl h) - -@[simp, grind =] -theorem reflTransGen_compRel : ReflTransGen (SymmGen r) = EqvGen r := by - ext a b - constructor - · intro h - induction h with - | refl => exact .refl _ - | tail hab hbc ih => - cases hbc with - | inl h => exact ih.trans _ _ _ (.rel _ _ h) - | inr h => exact ih.trans _ _ _ (.symm _ _ (.rel _ _ h)) - · intro h - induction h with - | rel _ _ ih => exact .single (.inl ih) - | refl x => exact .refl - | symm x y eq ih => - rw [symmGen_swap] - exact reflTransGen_swap.mp ih - | trans _ _ _ _ _ ih₁ ih₂ => exact ih₁.trans ih₂ - -/-- `Relator.RightUnique` corresponds to deterministic reductions, which are confluent, as all -multi-reductions with a common origin start the same (this fact is -`Relation.ReflTransGen.total_of_right_unique`.) -/ -theorem RightUnique.toConfluent (hr : Relator.RightUnique r) : Confluent r := by - intro a b c ab ac - obtain (h | h) := ReflTransGen.total_of_right_unique hr ab ac - · use c - · use b - -public meta section - -open Lean Elab Meta Command Term - -/-- - This command adds notations for relations. This should not usually be called directly, but from - the `reduction_sys` attribute. - - As an example `reduction_notation foo "β"` will add the notations "⭢β" and "↠β". - - Note that the string used will afterwards be registered as a notation. This means that if you have - also used this as a constructor name, you will need quotes to access corresponding cases, e.g. «β» - in the above example. --/ -syntax attrKind "reduction_notation" ident (str)? : command -macro_rules - | `($kind:attrKind reduction_notation $rel $sym) => - `( - @[nolint docBlame] - $kind:attrKind notation3 t:39 " ⭢" $sym:str t':39 => $rel t t' - @[nolint docBlame] - $kind:attrKind notation3 t:39 " ↠" $sym:str t':39 => Relation.ReflTransGen $rel t t' - ) - | `($kind:attrKind reduction_notation $rel) => - `( - @[nolint docBlame] - $kind:attrKind notation3 t:39 " ⭢ " t':39 => $rel t t' - @[nolint docBlame] - $kind:attrKind notation3 t:39 " ↠ " t':39 => Relation.ReflTransGen $rel t t' - ) - - -/-- - This attribute calls the `reduction_notation` command for the annotated declaration, such as in: - - ``` - @[reduction_sys "ₙ", simp] - def PredReduction (a b : ℕ) : Prop := a = b + 1 - ``` --/ -syntax (name := reductionSys) "reduction_sys" (ppSpace str)? : attr - -initialize Lean.registerBuiltinAttribute { - name := `reductionSys - descr := "Register notation for a relation and its closures." - add := fun decl stx _ => MetaM.run' do - let currNamespace ← getCurrNamespace - match stx with - | `(attr | reduction_sys $sym) => - let mut sym := sym - unless sym.getString.endsWith " " do - sym := Syntax.mkStrLit (sym.getString ++ " ") - liftCommandElabM <| do - modifyScope ({ · with currNamespace }) - elabCommand (← `(scoped reduction_notation $(mkIdent decl) $sym)) - | `(attr | reduction_sys) => - liftCommandElabM <| do - modifyScope ({ · with currNamespace }) - elabCommand (← `(scoped reduction_notation $(mkIdent decl))) - | _ => throwError "invalid syntax for 'reduction_sys' attribute" -} - -end - -end Relation diff --git a/Cslib/Foundations/Relation/Attr.lean b/Cslib/Foundations/Relation/Attr.lean new file mode 100644 index 0000000000..0b2d037784 --- /dev/null +++ b/Cslib/Foundations/Relation/Attr.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Thomas Waring, Chris Henson +-/ + +module + +public import Cslib.Init +public import Lean.Elab.Command +public import Mathlib.Util.Notation3 +public import Mathlib.Logic.Relation + +/-! # Relations: Attributes + +This module defines the `reduction_sys` attribute used for creating relation notations. + +-/ + +public meta section + +namespace Relation + +open Lean Elab Meta Command Term + +/-- + This command adds notations for relations. This should not usually be called directly, but from + the `reduction_sys` attribute. + + As an example `reduction_notation foo "β"` will add the notations "⭢β" and "↠β". + + Note that the string used will afterwards be registered as a notation. This means that if you have + also used this as a constructor name, you will need quotes to access corresponding cases, e.g. «β» + in the above example. +-/ +syntax attrKind "reduction_notation" ident (str)? : command +macro_rules + | `($kind:attrKind reduction_notation $rel $sym) => + `( + @[nolint docBlame] + $kind:attrKind notation3 t:39 " ⭢" $sym:str t':39 => $rel t t' + @[nolint docBlame] + $kind:attrKind notation3 t:39 " ↠" $sym:str t':39 => Relation.ReflTransGen $rel t t' + ) + | `($kind:attrKind reduction_notation $rel) => + `( + @[nolint docBlame] + $kind:attrKind notation3 t:39 " ⭢ " t':39 => $rel t t' + @[nolint docBlame] + $kind:attrKind notation3 t:39 " ↠ " t':39 => Relation.ReflTransGen $rel t t' + ) + + +/-- + This attribute calls the `reduction_notation` command for the annotated declaration, such as in: + + ``` + @[reduction_sys "ₙ", simp] + def PredReduction (a b : ℕ) : Prop := a = b + 1 + ``` +-/ +syntax (name := reductionSys) "reduction_sys" (ppSpace str)? : attr + +initialize Lean.registerBuiltinAttribute { + name := `reductionSys + descr := "Register notation for a relation and its closures." + add := fun decl stx _ => MetaM.run' do + let currNamespace ← getCurrNamespace + match stx with + | `(attr | reduction_sys $sym) => + let mut sym := sym + unless sym.getString.endsWith " " do + sym := Syntax.mkStrLit (sym.getString ++ " ") + liftCommandElabM <| do + modifyScope ({ · with currNamespace }) + elabCommand (← `(scoped reduction_notation $(mkIdent decl) $sym)) + | `(attr | reduction_sys) => + liftCommandElabM <| do + modifyScope ({ · with currNamespace }) + elabCommand (← `(scoped reduction_notation $(mkIdent decl))) + | _ => throwError "invalid syntax for 'reduction_sys' attribute" +} + +end Relation + +end diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean new file mode 100644 index 0000000000..4b46aef4d9 --- /dev/null +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Thomas Waring, Chris Henson +-/ + +module + +public import Cslib.Foundations.Relation.Defs +public import Mathlib.Data.List.TFAE +public import Mathlib.Order.Comparable +public import Mathlib.Order.WellFounded + +/-! # Relations: Confluence and Termination + +This module proves some properties regarding confluence and termination that are used for both +lambda calculi and combinatory logic. Some notable theorems: + +* `Diamond.toConfluent`: the diamond property implies confluence +* `LocallyConfluent.Terminating_toConfluent`: Newman's lemma + +## References + +* [*Term Rewriting and All That*][Baader1998] + +-/ + +@[expose] public section + +variable {α : Type*} {r r₁ r₂ : α → α → Prop} + +theorem WellFounded.ofTransGen (trans_wf : WellFounded (Relation.TransGen r)) : WellFounded r := by + grind [WellFounded.wellFounded_iff_has_min, Relation.TransGen] + +@[simp, grind =] +theorem WellFounded.iff_transGen : WellFounded (Relation.TransGen r) ↔ WellFounded r := + ⟨ofTransGen, transGen⟩ + +namespace Relation + +attribute [scoped grind] ReflGen TransGen ReflTransGen EqvGen CompRel + +theorem ReflGen.to_eqvGen (h : ReflGen r a b) : EqvGen r a b := by + induction h <;> grind + +theorem TransGen.to_eqvGen (h : TransGen r a b) : EqvGen r a b := by + induction h <;> grind + +theorem ReflTransGen.to_eqvGen (h : ReflTransGen r a b) : EqvGen r a b := by + induction h <;> grind + +theorem SymmGen.to_eqvGen (h : SymmGen r a b) : EqvGen r a b := by + induction h <;> grind + +attribute [scoped grind →] ReflGen.to_eqvGen TransGen.to_eqvGen ReflTransGen.to_eqvGen + SymmGen.to_eqvGen + +theorem MJoin.refl (a : α) : MJoin r a a := by + use a + +theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by + use b + +/-- Extending a multistep reduction by a single step preserves multi-joinability. -/ +lemma Diamond.extend (h : Diamond r) : + ReflTransGen r a b → r a c → Join (ReflTransGen r) b c := by + intros ab ac + induction ab using ReflTransGen.head_induction_on generalizing c + case refl => exists c, .single ac + case head a'_c' _ ih => + obtain ⟨d, cd, c'_d⟩ := h ac a'_c' + obtain ⟨d', b_d', d_d'⟩ := ih c'_d + exact ⟨d', b_d', .head cd d_d'⟩ + +/-- The diamond property implies confluence. -/ +theorem Diamond.toConfluent (h : Diamond r) : Confluent r := by + intros a b c ab bc + induction ab using ReflTransGen.head_induction_on generalizing c + case refl => exists c + case head _ _ a'_c' _ ih => + obtain ⟨d, cd, c'_d⟩ := h.extend bc a'_c' + obtain ⟨d', b_d', d_d'⟩ := ih c'_d + exact ⟨d', b_d', .trans cd d_d'⟩ + +theorem Confluent.toChurchRosser (h : Confluent r) : ChurchRosser r := by + intro x y h_eqv + induction h_eqv with + | rel _ b => exists b; grind [ReflTransGen.single] + | refl a => exists a + | symm a b _ ih => exact symm ih + | trans _ _ _ _ _ ih1 ih2 => + obtain ⟨u, _, hbu⟩ := ih1 + obtain ⟨v, hbv, _⟩ := ih2 + obtain ⟨w, _, _⟩ := h hbu hbv + exists w + grind [ReflTransGen.trans] + +theorem SemiConfluent.toConfluent (h : SemiConfluent r) : Confluent r := by + intro x y1 y2 h_xy1 h_xy2 + induction h_xy1 with + | refl => use y2 + | tail h_xz h_zy1 ih => + obtain ⟨u, h_zu, _⟩ := ih + obtain ⟨v, _, _⟩ := h h_zu h_zy1 + exists v + grind [ReflTransGen.trans] + +attribute [scoped grind →] Confluent.toChurchRosser SemiConfluent.toConfluent + +private theorem confluent_equivalents : [ChurchRosser r, SemiConfluent r, Confluent r].TFAE := by + grind [List.tfae_cons_cons, List.tfae_singleton] + +theorem SemiConfluent_iff_ChurchRosser : SemiConfluent r ↔ ChurchRosser r := + List.TFAE.out confluent_equivalents 1 0 + +theorem Confluent_iff_ChurchRosser : Confluent r ↔ ChurchRosser r := + List.TFAE.out confluent_equivalents 2 0 + +theorem Confluent_iff_SemiConfluent : Confluent r ↔ SemiConfluent r := + List.TFAE.out confluent_equivalents 2 1 + +theorem Confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) : Confluent r := by + intro a b c hab hac + exact ⟨x, h b, h c⟩ + +theorem Normal_iff (r : α → α → Prop) (x : α) : Normal r x ↔ ∀ y, ¬ r x y := by + rw [Normal, not_exists] + +/-- A multi-step from a normal form must be reflexive. -/ +@[grind =>] +theorem Normal.reflTransGen_eq (h : Normal r x) (xy : ReflTransGen r x y) : x = y := by + induction xy <;> grind + +/-- For a Church-Rosser relation, elements in an equivalence class must be multi-step related. -/ +theorem ChurchRosser.normal_eqvGen_reflTransGen (cr : ChurchRosser r) (norm : Normal r x) + (xy : EqvGen r y x) : ReflTransGen r y x := by + have ⟨_, _, _⟩ := cr xy + grind + +/-- For a Church-Rosser relation there is one normal form in each equivalence class. -/ +theorem ChurchRosser.normal_eq (cr : ChurchRosser r) (nx : Normal r x) (ny : Normal r y) + (xy : EqvGen r x y) : x = y := by + have ⟨z, _, _⟩ := cr xy + grind + +/-- Confluence implies that multi-step joinability is an equivalence. -/ +theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) : + Equivalence (Join (ReflTransGen r)) := by + apply equivalence_join + grind + +set_option linter.tacticAnalysis.verifyGrindOnly false in +lemma SN_iff_SN_of_rel (x : α) : SN r x ↔ ∀ y, r x y → SN r y := by grind only [Acc] + +lemma SN.intro : (h : ∀ y, r x y → SN r y) → SN r x := (SN_iff_SN_of_rel x).mpr + +lemma SN.of_rel (hx : SN r x) (h : r x y) : SN r y := Acc.inv hx h + +@[grind →] +lemma SN.of_rel_reflTransGen (hx : SN r x) (h : ReflTransGen r x y) : SN r y := by + induction h with + | refl => exact hx + | tail _ h ih => exact ih.of_rel h + +lemma SN.transGen (hx : SN r x) : SN (TransGen r) x := by + have eq : TransGen (Function.swap r) = (fun a b => TransGen r b a) := by + ext + exact transGen_swap + simpa [eq] using Acc.transGen hx + +lemma SN.of_le {r' : α → α → Prop} (hx : SN r x) (h : r' ≤ r) : SN r' x := by + refine Subrelation.accessible ?_ hx + exact subrelation_iff_le.mpr fun {x y} => h y x + +@[simp] +lemma SN.iff_transGen (x : α) : SN (TransGen r) x ↔ SN r x := + ⟨fun hx => hx.of_le <| fun _ _ => TransGen.single, transGen⟩ + +/-- `SN r x` is equivalent to the more elementary definition, that there is no infinite sequence +of reductions starting with `x`. -/ +theorem SN.iff_isEmpty_chain : + SN r x ↔ IsEmpty {f : ℕ → α | f 0 = x ∧ ∀ n, r (f n) (f (n + 1))} := + acc_iff_isEmpty_descending_chain + +lemma SN.onFun_of_image {r : β → β → Prop} {f : α → β} (hx : SN r (f x)) : + SN (Function.onFun r f) x := InvImage.accessible f hx + +lemma SN.of_normal (hx : Normal r x) : SN r x := SN.intro fun y hy => (hx ⟨y, hy⟩).elim + +lemma Terminating.apply (hr : Terminating r) (x : α) : SN r x := WellFounded.apply hr x + +lemma Terminating.iff_forall_sn : Terminating r ↔ ∀ x, SN r x := + ⟨WellFounded.apply, WellFounded.intro⟩ + +theorem Terminating.toTransGen (ht : Terminating r) : Terminating (TransGen r) := by + simp_rw [iff_forall_sn, SN.iff_transGen] at ht ⊢ + exact ht + +theorem Terminating.ofTransGen : Terminating (TransGen r) → Terminating r := by + simp_rw [iff_forall_sn, SN.iff_transGen] + exact id + +theorem Terminating.iff_transGen : Terminating (TransGen r) ↔ Terminating r := by + simp_rw [iff_forall_sn, SN.iff_transGen] + +theorem Terminating.iff_isEmpty_chain : + Terminating r ↔ IsEmpty {f : ℕ → α // ∀ n, r (f n) (f (n + 1))} := + wellFounded_iff_isEmpty_descending_chain + +theorem Terminating.of_le {r' : α → α → Prop} (hr : Terminating r) (h : r' ≤ r) : + Terminating r' := by + rw [iff_forall_sn] at hr ⊢ + exact fun x => (hr x).of_le h + +lemma Terminating.subtype_sn (r : α → α → Prop) : + Terminating (α := {x // SN r x}) (fun a b => r a b) := + iff_forall_sn.mpr fun x => x.property.onFun_of_image + +theorem SN.isNormalizable (hx : SN r x) : Normalizable r x := by + -- restrict to the subtype where all elements are `SN`, so `flip r` is well-founded + obtain ⟨⟨y, hsn⟩, hred : ReflTransGen r x y, hnorm⟩ := + (Terminating.subtype_sn r).has_min + (s := Subtype.val ⁻¹' ({y | ReflTransGen r x y})) ⟨⟨x, hx⟩, ReflTransGen.refl⟩ + use y, hred + intro ⟨z, hyz⟩ + exact hnorm ⟨z, hsn.of_rel hyz⟩ (.tail hred hyz) hyz + +theorem Terminating.isNormalizing (hr : Terminating r) : Normalizing r := + fun x => (hr.apply x).isNormalizable + +theorem Terminating.isConfluent_iff_all_unique_Normal (ht : Terminating r) : + Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := by + have hn : Normalizing r := ht.isNormalizing + constructor + · intro hc a + apply existsUnique_of_exists_of_unique (hn a) + rintro n₁ n₂ ⟨hr₁, hn₁⟩ ⟨hr₂, hn₂⟩ + have hj : Join (ReflTransGen r) n₁ n₂ := hc hr₁ hr₂ + obtain ⟨m, h₁, h₂⟩ := hj + rw [Normal.reflTransGen_eq hn₁ h₁, Normal.reflTransGen_eq hn₂ h₂] + · intro h a b c hab hac + obtain ⟨na, ⟨han, hnnor⟩, H⟩ := h a + use na + obtain ⟨nb, hbnb, hnb⟩ := hn b + obtain ⟨nc, hcnc, hnc⟩ := hn c + have hanb : (ReflTransGen r) a nb := ReflTransGen.trans hab hbnb + have hanc : (ReflTransGen r) a nc := ReflTransGen.trans hac hcnc + have hnanb : nb = na := H nb ⟨hanb, hnb⟩ + have hnanc : nc = na := H nc ⟨hanc, hnc⟩ + rw [hnanb] at hbnb + rw [hnanc] at hcnc + exact ⟨hbnb, hcnc⟩ + +theorem Convergent.isTerminating (h : Convergent r) : Terminating r := h.right + +theorem Convergent.isConfluent (h : Convergent r) : Confluent r := h.left + +theorem Convergent.isNormalizing (h : Convergent r) : Normalizing r := h.isTerminating.isNormalizing + +theorem Convergent.unique_Normal (h : Convergent r) : + ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := + h.isTerminating.isConfluent_iff_all_unique_Normal.mp h.isConfluent + +theorem Confluent.toLocallyConfluent (h : Confluent r) : LocallyConfluent r := by + intro _ _ _ ab ac + exact h (.single ab) (.single ac) + +/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ +theorem LocallyConfluent.Terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : + Confluent r := by + intro x + induction x using ht.induction with + | h x ih => + intro y z xy xz + cases xy.cases_head with + | inl => exists z; grind + | inr h => + obtain ⟨y₁, x_y₁, y₁_y⟩ := h + cases xz.cases_head with + | inl => exists y; grind + | inr h => + obtain ⟨z₁, x_z₁, z₁_z⟩ := h + have ⟨u, z₁_u, y₁_u⟩ := hlc x_z₁ x_y₁ + have ⟨v, uv, yv⟩ : Join (ReflTransGen r) u y := by grind + have ⟨w, vw, zw⟩ : Join (ReflTransGen r) v z := by grind [ReflTransGen.trans] + exact ⟨w, .trans yv vw, zw⟩ + +instance : Std.Symm (@Commute α) where + symm r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ := by grind [h x_y₂ x_y₁] + +theorem Commute.toConfluent : Commute r r = Confluent r := rfl + +theorem StronglyCommute.toStronglyConfluent : StronglyCommute r r = StronglyConfluent r := rfl + +theorem DiamondCommute.toDiamond : DiamondCommute r r = Diamond r := by rfl + +theorem StronglyCommute.extend (h : StronglyCommute r₁ r₂) (xy : ReflTransGen r₁ x y) + (xz : r₂ x z) : ∃ w, ReflGen r₂ y w ∧ ReflTransGen r₁ z w := by + induction xy with + | refl => exact ⟨z, .single xz, .refl⟩ + | @tail b c _ bc ih => + obtain ⟨w, bw, zw⟩ := ih + cases bw with + | refl => exact ⟨c, .refl, zw.trans (.single bc)⟩ + | single bw => cases h bc bw; grind [ReflTransGen.trans] + +theorem StronglyCommute.toCommute (h : StronglyCommute r₁ r₂) : Commute r₁ r₂ := by + intro x y₁ y₂ x_y₁ x_y₂ + induction x_y₂ with + | refl => exists y₁ + | @tail a b xa ab ih => + obtain ⟨z, y₁_z, y₂_z⟩ := ih + obtain ⟨w, zw, bw⟩ := h.extend y₂_z ab + exact ⟨w, y₁_z.trans zw.to_reflTransGen, bw⟩ + +theorem StronglyConfluent.toConfluent (h : StronglyConfluent r) : Confluent r := + StronglyCommute.toCommute h + +variable {r₁ r₂ : α → α → Prop} + +@[scoped grind <=] +theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := + Or.inl r₁_ab + +@[scoped grind <=] +theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := + Or.inr r₂_ab + +@[scoped grind <=] +theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := by + induction r₁_ab <;> grind + +@[scoped grind <=] +theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := by + induction r₂_ab <;> grind + +lemma Commute.join_left (c₁ : Commute r₁ r₃) (c₂ : Commute r₂ r₃) : Commute (r₁ ⊔ r₂) r₃ := by + intro x y z xy xz + induction xy with + | refl => grind + | @tail b c _ bc ih => + have ⟨w, bw, _⟩ := ih + cases bc with + | inl bc => + obtain ⟨_, _, _⟩ := c₁ (.single bc) bw + grind [ReflTransGen.trans] + | inr bc => + obtain ⟨_, _, _⟩ := c₂ (.single bc) bw + grind [ReflTransGen.trans] + +theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) (comm : Commute r₁ r₂) : + Confluent (r₁ ⊔ r₂) := by + intro a b c ab ac + induction ab generalizing c with + | refl => exists c + | @tail x y ax xy ih => + have h_comm : Commute (r₁ ⊔ r₂) (r₁ ⊔ r₂) := by apply_rules [join_left, symm] + obtain ⟨z, xz, cz⟩ := ih ac + obtain ⟨w, yw, zw⟩ := h_comm (.single xy) xz + exact ⟨w, yw, cz.trans zw⟩ + +/-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/ +theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) : + ReflTransGen r₁ = ReflTransGen r₂ := by + ext + exact ⟨ReflTransGen.mono @h₁, reflTransGen_closed @h₂⟩ + +lemma ReflGen.compRel_symm : ReflGen (SymmGen r) a b → ReflGen (SymmGen r) b a +| .refl => .refl +| .single (.inl h) => .single (.inr h) +| .single (.inr h) => .single (.inl h) + +@[simp, grind =] +theorem reflTransGen_compRel : ReflTransGen (SymmGen r) = EqvGen r := by + ext a b + constructor + · intro h + induction h with + | refl => exact .refl _ + | tail hab hbc ih => + cases hbc with + | inl h => exact ih.trans _ _ _ (.rel _ _ h) + | inr h => exact ih.trans _ _ _ (.symm _ _ (.rel _ _ h)) + · intro h + induction h with + | rel _ _ ih => exact .single (.inl ih) + | refl x => exact .refl + | symm x y eq ih => + rw [symmGen_swap] + exact reflTransGen_swap.mp ih + | trans _ _ _ _ _ ih₁ ih₂ => exact ih₁.trans ih₂ + +/-- `Relator.RightUnique` corresponds to deterministic reductions, which are confluent, as all +multi-reductions with a common origin start the same (this fact is +`Relation.ReflTransGen.total_of_right_unique`.) -/ +theorem RightUnique.toConfluent (hr : Relator.RightUnique r) : Confluent r := by + intro a b c ab ac + obtain (h | h) := ReflTransGen.total_of_right_unique hr ab ac + · use c + · use b + +end Relation diff --git a/Cslib/Foundations/Relation/Defs.lean b/Cslib/Foundations/Relation/Defs.lean new file mode 100644 index 0000000000..6aecd445c2 --- /dev/null +++ b/Cslib/Foundations/Relation/Defs.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Thomas Waring, Chris Henson +-/ + +module + +public import Cslib.Init +public import Mathlib.Data.Set.CoeSort +public import Mathlib.Logic.Relation +public import Mathlib.Order.Basic + +/-! # Relations: Definitions + +## References + +* [*Term Rewriting and All That*][Baader1998] +* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018] + +-/ + +@[expose] public section + +namespace Relation + +@[nolint defsWithUnderscore] +instance (r : α → α → Prop) (s : Set α) : CoeDep (α → α → Prop) r (s → s → Prop) where + coe a b := r a b + +/-- The empty (heterogeneous) relation, which always returns `False`. -/ +@[nolint unusedArguments] +def emptyHRelation {α : Sort u} {β : Sort v} (_ : α) (_ : β) := False + +/-- Domain of a relation. -/ +def dom (r : α → β → Prop) : Set α := {a | ∃ b, r a b} + +/-- Codomain of a relation, aka range. -/ +def cod (r : α → β → Prop) : Set β := {b | ∃ a, r a b} + +/-- The join of the reflexive transitive closure. This is not named in Mathlib, but see + `#loogle Relation.Join (Relation.ReflTransGen ?r)` -/ +abbrev MJoin (r : α → α → Prop) := Join (ReflTransGen r) + +/-- The relation `r` 'up to' the relation `s`. -/ +def UpTo (r s : α → α → Prop) : α → α → Prop := Comp s (Comp r s) + +/-- A relation `r` is (right) Euclidean if `r a b` and `r a c` guarantee `r b c`. -/ +class RightEuclidean (r : α → α → Prop) where + rightEuclidean : r a b → r a c → r b c + +/-- A relation `r` is (left) Euclidean if `r a c` and `r b c` guarantee `r a b`. -/ +class LeftEuclidean (r : α → α → Prop) where + leftEuclidean {a b c} : r a c → r b c → r a b + +/-- A relation has the diamond property when all reductions with a common origin are joinable -/ +abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c + +/-- A relation is confluent when its reflexive transitive closure has the diamond property. -/ +abbrev Confluent (r : α → α → Prop) := Diamond (ReflTransGen r) + +/-- A relation is semi-confluent when single and multiple steps with common origin + are multi-joinable. -/ +abbrev SemiConfluent (r : α → α → Prop) := + ∀ {x y₁ y₂}, ReflTransGen r x y₂ → r x y₁ → Join (ReflTransGen r) y₁ y₂ + +/-- A relation has the Church Rosser property when equivalence implies multi-joinability. -/ +abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join (ReflTransGen r) x y + +/-- An element is reducible with respect to a relation if there is a value it is related to. -/ +abbrev Reducible (r : α → α → Prop) (x : α) : Prop := ∃ y, r x y + +/-- A relation `r` is serial if every element is `Reducible`, i.e. `Relator.LeftTotal`. -/ +class Serial (r : α → α → Prop) where + serial : Relator.LeftTotal r + +/-- An element is normal if it is not reducible. -/ +abbrev Normal (r : α → α → Prop) (x : α) : Prop := ¬ Reducible r x + +/-- An element is normalizable if it is related to a normal element. -/ +abbrev Normalizable (r : α → α → Prop) (x : α) : Prop := + ∃ n, ReflTransGen r x n ∧ Normal r n + +/-- A relation is normalizing when every element is normalizable. -/ +abbrev Normalizing (r : α → α → Prop) : Prop := + ∀ x, Normalizable r x + +/-- An element `x` is `SN` (for strongly-normalising) for a relation `r` if it is accesible under +the inverse of `r`. -/ +abbrev SN (r : α → α → Prop) := Acc (fun a b => r b a) + +/-- A relation is terminating when the inverse of its transitive closure is well-founded. + Note that this is also called Noetherian or strongly normalizing in the literature. -/ +abbrev Terminating (r : α → α → Prop) := WellFounded (fun a b => r b a) + +/-- A relation is convergent when it is both confluent and terminating. -/ +abbrev Convergent (r : α → α → Prop) := Confluent r ∧ Terminating r + +/-- A relation is locally confluent when all reductions with a common origin are multi-joinable -/ +abbrev LocallyConfluent (r : α → α → Prop) := + ∀ {a b c : α}, r a b → r a c → Join (ReflTransGen r) b c + +/-- A relation is strongly confluent when single steps are reflexive- and multi-joinable. -/ +abbrev StronglyConfluent (r : α → α → Prop) := + ∀ {x y₁ y₂}, r x y₁ → r x y₂ → ∃ z, ReflGen r y₁ z ∧ ReflTransGen r y₂ z + +/-- Generalization of `Confluent` to two relations. -/ +def Commute (r₁ r₂ : α → α → Prop) := ∀ {x y₁ y₂}, + ReflTransGen r₁ x y₁ → ReflTransGen r₂ x y₂ → ∃ z, ReflTransGen r₂ y₁ z ∧ ReflTransGen r₁ y₂ z + +/-- Generalization of `StronglyConfluent` to two relations. -/ +def StronglyCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, ReflGen r₂ y₁ z ∧ ReflTransGen r₁ y₂ z + +/-- Generalization of `Diamond` to two relations. -/ +def DiamondCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, r₂ y₁ z ∧ r₁ y₂ z + +/-- A pair of subrelations lifts to transitivity on the relation. -/ +@[implicit_reducible] +def transLeftRight (s s' r : α → α → Prop) [IsTrans α r] (h : s ≤ r) (h' : s' ≤ r) : + Trans s s' r where + trans hab hbc := _root_.trans (h _ _ hab) (h' _ _ hbc) + +/-- A subrelation lifts to transitivity on the left of the relation. -/ +@[implicit_reducible] +def transLeft (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans s r r where + trans hab hbc := _root_.trans (h _ _ hab) hbc + +/-- A subrelation lifts to transitivity on the right of the relation. -/ +@[implicit_reducible] +def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r s r where + trans hab hbc := _root_.trans hab (h _ _ hbc) + +end Relation diff --git a/Cslib/Foundations/Relation/Domain.lean b/Cslib/Foundations/Relation/Domain.lean new file mode 100644 index 0000000000..50dc2818f4 --- /dev/null +++ b/Cslib/Foundations/Relation/Domain.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Thomas Waring, Chris Henson +-/ + +module + +public import Cslib.Foundations.Relation.Defs +public import Mathlib.Data.Set.Basic + +/-! # Relations: Domain and Codomain + +This module proves basic properties of the domain and codomain of relations. + +## References + +* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018] + +-/ + +@[expose] public section + +namespace Relation + +@[simp, grind =] +theorem emptyHRelation_emptyRelation : (emptyHRelation : α → α → Prop) = emptyRelation := rfl + +@[simp, grind =] +theorem emptyHrelation_apply (a : α) (b : β) : emptyHRelation a b ↔ False := .rfl + +variable {β : Type*} {r : α → β → Prop} + +@[simp, grind =] lemma mem_dom : a ∈ dom r ↔ ∃ b, r a b := .rfl +@[simp, grind =] lemma mem_cod : b ∈ cod r ↔ ∃ a, r a b := .rfl + +@[gcongr] lemma dom_mono (h : r₁ ≤ r₂) : dom r₁ ⊆ dom r₂ := fun a ⟨b, hab⟩ => ⟨b, h a b hab⟩ +@[gcongr] lemma cod_mono (h : r₁ ≤ r₂) : cod r₁ ⊆ cod r₂ := fun b ⟨a, hab⟩ => ⟨a, h a b hab⟩ + +@[simp, grind =] +lemma dom_empty : dom (emptyHRelation : α → β → Prop) = ∅ := by grind + +@[simp, grind =] +lemma cod_empty : cod (emptyHRelation : α → β → Prop) = ∅ := by grind + +@[simp, grind =] +lemma dom_eq_empty_iff : dom r = ∅ ↔ r = emptyHRelation where + mp h := by + ext a b + simp + grind => have : a ∈ dom r; finish + mpr := by grind + +@[simp, grind =] +lemma cod_eq_empty_iff : cod r = ∅ ↔ r = emptyHRelation where + mp h := by + ext a b + simp + grind => have : b ∈ cod r; finish + mpr h := by grind + +@[simp] +lemma cod_inv : cod (fun a b => r b a) = dom r := rfl + +@[simp] +lemma dom_inv : dom (fun a b => r b a) = cod r := rfl + +theorem _root_.Std.Trichotomous.subsingleton_cod (r : α → α → Prop) [Std.Trichotomous r] : + Subsingleton ((cod r)ᶜ : Set α) := by + constructor + rintro ⟨b₁, _⟩ ⟨b₂, _⟩ + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b₁ b₂ + grind + +theorem _root_.Std.Trichotomous.subsingleton_dom (r : α → α → Prop) [Std.Trichotomous r] : + Subsingleton ((dom r)ᶜ : Set α) := by + constructor + rintro ⟨a₁, _⟩ ⟨a₂, _⟩ + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a₁ a₂ + grind + +end Relation diff --git a/Cslib/Foundations/Relation/Euclidean.lean b/Cslib/Foundations/Relation/Euclidean.lean new file mode 100644 index 0000000000..edd93659e0 --- /dev/null +++ b/Cslib/Foundations/Relation/Euclidean.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2025 Fabrizio Montesi and Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Thomas Waring, Chris Henson +-/ + +module + +public import Cslib.Foundations.Relation.Domain +public import Mathlib.Data.Fintype.EquivFin +public import Mathlib.Tactic.TFAE + +/-! # Relations: Euclidean Relations + +This module proves basic properties about left and right Euclidean relations, which are use +in modal logic. + +TODO: develop an attribute to dualize theorems to the converse of a relation + +## References + +* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018] + +-/ + +@[expose] public section + +open Relator + +namespace Relation + +variable {α : Type*} {r : α → α → Prop} + +@[scoped grind →] +lemma refl_serial (r : α → α → Prop) (h : Std.Refl r) : Serial r where + serial a := ⟨a, h.refl a⟩ + +instance [instRefl : Std.Refl r] : Serial r := refl_serial r instRefl + +namespace RightEuclidean + +variable [RightEuclidean r] + +/-- A `RightEuclidean` relation is reflexive on its range -/ +theorem refl_cod (ab : r a b) : r b b := rightEuclidean ab ab + +theorem refl_cod' : b ∈ cod r → r b b := fun ⟨_, ab⟩ ↦ refl_cod ab + +/-- The converse of a `RightEuclidean` relation is `LeftEuclidean` -/ +theorem leftEuclidean_swap : LeftEuclidean (fun a b => r b a) where + leftEuclidean ca cb := rightEuclidean cb ca + +instance [Std.Refl r] : Std.Symm r where + symm a _ ab := rightEuclidean ab (refl a) + +theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where + trans a b c ab bc := by + have := Std.Trichotomous.trichotomous (r := r) a c + have cc := refl_cod bc + have (ca : r c a) := rightEuclidean ca cc + grind + +theorem antisymm_rightUnique [Std.Antisymm r] : Relator.RightUnique r := by + intros a b c ab ac + exact antisymm (rightEuclidean ab ac) (rightEuclidean ac ab) + +theorem rightUnique_antisymm (h : Relator.RightUnique r) : Std.Antisymm r where + antisymm _ _ ab ba := h ba (refl_cod ab) + +theorem rightUnique_trans (h : Relator.RightUnique r) : IsTrans α r where + trans a b c ab bc := by + have eq : c = b := h bc (refl_cod ab) + simpa [eq] + +theorem rightTotal_equiv (h : Relator.RightTotal r) : IsEquiv α r := by + have : Std.Refl r := ⟨fun a => refl_cod (h a).choose_spec⟩ + exact {toIsTrans := ⟨fun _ _ _ ab bc => rightEuclidean (symm ab) bc⟩} + +omit [RightEuclidean r] in +theorem leftTotal_rightUnique_trans (h₁ : LeftTotal r) (h₂ : RightUnique r) [IsTrans α r] : + RightEuclidean r where + rightEuclidean {a b c} ab ac := by + obtain ⟨d, dc⟩ := h₁ c + have : b = c := h₂ ab ac + have : d = c := h₂ (_root_.trans ac dc) ac + grind + +private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : + ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by + rintro ⟨a, b, c, _⟩ + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c + have := antisymm_rightUnique (r := r) + have := @refl_cod (r := r) + grind [Relator.RightUnique] + +theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by + classical + by_contra! h + apply three_contra (r := r) + have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3 + have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard + use a, b, c + +theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] : + Fintype.card α ≤ 2 := by + by_contra! h + apply three_contra (r := r) + have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h + use a, b, c + +theorem cod_subset_dom : cod r ⊆ dom r := fun b ⟨_, ab⟩ ↦ ⟨b, refl_cod ab⟩ + +instance : RightEuclidean (α := cod r) r where + rightEuclidean := rightEuclidean + +instance : RightEuclidean (α := dom r) r where + rightEuclidean := rightEuclidean + +theorem rightTotal_cod : Relator.RightTotal (α := cod r) (β := cod r) r := + fun ⟨_, _, h⟩ => ⟨_, refl_cod h⟩ + +theorem equiv_cod : IsEquiv (cod r) r := rightTotal_equiv rightTotal_cod + +end RightEuclidean + +namespace LeftEuclidean + +variable [LeftEuclidean r] + +/-- A `LeftEuclidean` relation is reflexive on its domain -/ +theorem refl_dom (ab : r a b) : r a a := leftEuclidean ab ab + +theorem refl_dom' : a ∈ dom r → r a a := fun ⟨_, ab⟩ ↦ refl_dom ab + +/-- The converse of a `LeftEuclidean` relation is `RightEuclidean` -/ +theorem rightEuclidean_swap : RightEuclidean (fun a b => r b a) where + rightEuclidean ab ac := leftEuclidean ac ab + +instance [Std.Refl r] : Std.Symm r where + symm _ b ab := leftEuclidean (refl b) ab + +theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where + trans a b c ab bc := by + have := Std.Trichotomous.trichotomous (r := r) a c + have aa := refl_dom ab + have (ca : r c a) := leftEuclidean aa ca + grind + +theorem antisymm_leftUnique [Std.Antisymm r] : Relator.LeftUnique r := by + intros a b c ac bc + exact antisymm (leftEuclidean ac bc) (leftEuclidean bc ac) + +theorem leftUnique_antisymm (h : Relator.LeftUnique r) : Std.Antisymm r where + antisymm _ _ ab ba := h ab (refl_dom ba) + +theorem leftUnique_trans (h : Relator.LeftUnique r) : IsTrans α r where + trans a b c ab bc := by + have eq : a = b := h ab (refl_dom bc) + simpa [eq] + +theorem leftTotal_equiv (h : Relator.LeftTotal r) : IsEquiv α r := by + have : Std.Refl r := ⟨fun a => refl_dom (h a).choose_spec⟩ + exact {toIsTrans := ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩} + +omit [LeftEuclidean r] in +theorem rightTotal_leftUnique_trans (h₁ : RightTotal r) (h₂ : LeftUnique r) [IsTrans α r] : + LeftEuclidean r where + leftEuclidean {a b c} ac bc := by + obtain ⟨d, da⟩ := h₁ a + have : a = b := h₂ ac bc + have : a = d := h₂ ac (_root_.trans da ac) + grind + +private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : + ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by + rintro ⟨a, b, c, _⟩ + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c + have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c + have := antisymm_leftUnique (r := r) + have := @refl_dom (r := r) + grind [Relator.LeftUnique] + +theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by + classical + by_contra! h + apply three_contra (r := r) + have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3 + have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard + use a, b, c + +theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] : + Fintype.card α ≤ 2 := by + by_contra! h + apply three_contra (r := r) + have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h + use a, b, c + +theorem dom_subset_cod : dom r ⊆ cod r := fun a ⟨_, ab⟩ ↦ ⟨a, refl_dom ab⟩ + +instance : LeftEuclidean (α := cod r) r where + leftEuclidean := leftEuclidean + +instance : LeftEuclidean (α := dom r) r where + leftEuclidean := leftEuclidean + +theorem leftTotal_dom : Relator.LeftTotal (α := dom r) (β := dom r) r := + fun ⟨_, _, h⟩ => ⟨_, refl_dom h⟩ + +theorem equiv_dom : IsEquiv (dom r) r := leftTotal_equiv leftTotal_dom + +end LeftEuclidean + +section euclidean_symm + +variable [Std.Symm r] + +open RightEuclidean LeftEuclidean in +private theorem symm_equivalents : [RightEuclidean r, LeftEuclidean r, IsTrans α r].TFAE := by + tfae_have 1 → 2 := fun _ => ⟨fun ac bc => rightEuclidean (symm ac) (symm bc)⟩ + tfae_have 2 → 3 := fun _ => ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩ + tfae_have 3 → 1 := fun _ => ⟨fun ab ac => _root_.trans (symm ab) ac⟩ + tfae_finish + +/-- For a symmetric relation, `LeftEuclidean` and `RightEuclidean` are equivalent. -/ +theorem symm_leftEuclidean_iff_rightEuclidean : LeftEuclidean r ↔ RightEuclidean r := + List.TFAE.out symm_equivalents 1 0 + +/-- For a symmetric relation, `LeftEuclidean` and transitivity are equivalent. -/ +theorem symm_leftEuclidean_iff_trans : LeftEuclidean r ↔ IsTrans α r := + List.TFAE.out symm_equivalents 1 2 + +/-- For a symmetric relation, `RightEuclidean` and transitivity are equivalent. -/ +theorem symm_rightEuclidean_iff_trans : RightEuclidean r ↔ IsTrans α r := + List.TFAE.out symm_equivalents 0 2 + +end euclidean_symm + +theorem leftEuclidean_rightEuclidean_dom_cod_eq [LeftEuclidean r] [RightEuclidean r] : + dom r = cod r := by + have : dom r ⊆ cod r := LeftEuclidean.dom_subset_cod + have : cod r ⊆ dom r := RightEuclidean.cod_subset_dom + grind + +theorem dom_cod_leftEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] : + LeftEuclidean r where + leftEuclidean {a b c} ac bc := by + have cb : r c b := equiv_dom.symm ⟨_, _, bc⟩ ⟨c, by grind⟩ bc + exact equiv_dom.trans ⟨_, _, ac⟩ ⟨_, _, cb⟩ ⟨_, by grind⟩ ac cb + +lemma dom_cod_rightEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] : + RightEuclidean r where + rightEuclidean {a b c} ab ac := by + have ba : r b a := equiv_dom.symm ⟨a, _, ab⟩ ⟨b, by grind⟩ ab + exact equiv_dom.trans ⟨_, _, ba⟩ ⟨_, _, ac⟩ ⟨c, by grind⟩ ba ac + +/-- A relation is both left and right Euclidean if and only if the relation is an equivalence on + coinciding domain and codomain. -/ +theorem leftEuclidean_rightEuclidean_iff_dom_cod : + LeftEuclidean r ∧ RightEuclidean r ↔ dom r = cod r ∧ IsEquiv (dom r) r where + mp := fun ⟨_, _⟩ ↦ ⟨leftEuclidean_rightEuclidean_dom_cod_eq, LeftEuclidean.equiv_dom⟩ + mpr := fun ⟨eq, _⟩ ↦ ⟨dom_cod_leftEuclidean eq, dom_cod_rightEuclidean eq⟩ + +end Relation diff --git a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean index a33aad0780..03726febb9 100644 --- a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean @@ -6,7 +6,7 @@ Authors: Fabrizio Montesi, Thomas Waring module -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Domain public import Cslib.Foundations.Semantics.LTS.Simulation public import Cslib.Foundations.Semantics.LTS.TraceEq diff --git a/Cslib/Languages/CombinatoryLogic/Confluence.lean b/Cslib/Languages/CombinatoryLogic/Confluence.lean index 6a0d20022a..be73d02c19 100644 --- a/Cslib/Languages/CombinatoryLogic/Confluence.lean +++ b/Cslib/Languages/CombinatoryLogic/Confluence.lean @@ -7,6 +7,7 @@ Authors: Thomas Waring module public import Cslib.Languages.CombinatoryLogic.Defs +public import Cslib.Foundations.Relation.Confluence /-! # SKI reduction is confluent diff --git a/Cslib/Languages/CombinatoryLogic/Defs.lean b/Cslib/Languages/CombinatoryLogic/Defs.lean index a82459aadf..7d028d2834 100644 --- a/Cslib/Languages/CombinatoryLogic/Defs.lean +++ b/Cslib/Languages/CombinatoryLogic/Defs.lean @@ -6,7 +6,8 @@ Authors: Thomas Waring module -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Attr +public import Cslib.Foundations.Relation.Defs public meta import Mathlib.Tactic.ToDual /-! diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean index b9969aa49a..d38bc67c3a 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean @@ -6,7 +6,7 @@ Authors: Chris Henson module -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Attr public import Cslib.Languages.LambdaCalculus.LocallyNameless.Fsub.Opening /-! # λ-calculus diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Safety.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Safety.lean index 972a2ed112..609e129a6e 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Safety.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Safety.lean @@ -8,6 +8,7 @@ module public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.Basic public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta +public import Cslib.Foundations.Relation.Confluence /-! # λ-calculus diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean index 8496ba8b9e..783ec90fff 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean @@ -7,7 +7,6 @@ Authors: David Wegmann module public import Cslib.Foundations.Data.HasFresh -public import Cslib.Foundations.Data.Relation public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.Basic public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.StrongNorm diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean index f23f6c5083..8cdb1ddb08 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean @@ -6,7 +6,7 @@ Authors: Chris Henson module -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Attr public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Properties public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Congruence diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean index 84d5865c95..8ec9372911 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean @@ -7,6 +7,7 @@ Authors: Chris Henson module public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta +public import Cslib.Foundations.Relation.Confluence /-! # β-confluence for the λ-calculus -/ diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean index ee2ee01d1c..ce99952950 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean @@ -6,7 +6,7 @@ Authors: Maximiliano Onofre Martínez module -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Attr public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Properties public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Congruence diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean index 500febbb76..f8f109edac 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean @@ -7,6 +7,7 @@ Authors: Maximiliano Onofre Martínez module public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullEta +public import Cslib.Foundations.Relation.Confluence /-! # η-confluence for the λ-calculus diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean index 4cf0657415..1ae7265830 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean @@ -7,7 +7,6 @@ Authors: David Wegmann module -public import Cslib.Foundations.Data.Relation public import Cslib.Foundations.Data.HasFresh public import Cslib.Foundations.Syntax.HasSubstitution public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.Basic diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean index 6a0163c97a..66dd185ff0 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean @@ -9,6 +9,7 @@ module public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.MultiApp public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.LcAt +public import Cslib.Foundations.Relation.Confluence /-! Strong normalization (termination) for full beta-reduction of untyped lambda calculus. -/ diff --git a/Cslib/Logics/Modal/Basic.lean b/Cslib/Logics/Modal/Basic.lean index ee6a6a16e2..fda217a1c1 100644 --- a/Cslib/Logics/Modal/Basic.lean +++ b/Cslib/Logics/Modal/Basic.lean @@ -10,7 +10,7 @@ public import Cslib.Init public import Cslib.Foundations.Logic.InferenceSystem public import Mathlib.Data.Set.Basic public import Mathlib.Order.Defs.Unbundled -public import Cslib.Foundations.Data.Relation +public import Cslib.Foundations.Relation.Euclidean public import Mathlib.Logic.Nonempty /-! # Modal Logic diff --git a/CslibTests/Reduction.lean b/CslibTests/Reduction.lean index 297830d36d..fdd55a97a1 100644 --- a/CslibTests/Reduction.lean +++ b/CslibTests/Reduction.lean @@ -1,4 +1,4 @@ -import Cslib.Foundations.Data.Relation +import Cslib.Foundations.Relation.Attr namespace CslibTests From 6311ef1e0d3545fc50a167d21fc2322456de75db Mon Sep 17 00:00:00 2001 From: Chris Henson <46805207+chenson2018@users.noreply.github.com> Date: Sat, 13 Jun 2026 02:45:50 -0400 Subject: [PATCH 23/51] doc: add wikidata attribute for Church-Rosser theorems (#626) See [this thread](https://leanprover.zulipchat.com/#narrow/channel/113488-general/topic/Wikipedia.20Day.202026.20Talk/with/582363210) for context. --- .../LocallyNameless/Untyped/FullBetaConfluence.lean | 1 + .../LocallyNameless/Untyped/FullBetaEtaConfluence.lean | 1 + .../LocallyNameless/Untyped/FullEtaConfluence.lean | 1 + 3 files changed, 3 insertions(+) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean index 8ec9372911..0ae59ca2fc 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean @@ -203,6 +203,7 @@ theorem para_confluence : Confluent (@Parallel Var) := para_diamond.toConfluent /-- β-reduction is confluent. -/ +@[wikidata Q1308502] theorem confluence_beta : Confluent (@FullBeta Var) := by have eq : ReflTransGen (@Parallel Var) = ReflTransGen (@FullBeta Var) := by ext diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean index f2b3a27189..2412f2c109 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean @@ -92,6 +92,7 @@ lemma stronglyCommute_eta_beta : StronglyCommute (@FullEta Var) FullBeta := by open Commute in /-- βη-reduction is confluent. -/ +@[wikidata Q1308502] theorem confluent_beta_eta : Confluent (@FullBetaEta Var) := by apply join_confluent · exact confluence_beta diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean index f8f109edac..4defb563e1 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean @@ -34,6 +34,7 @@ open Relation variable [HasFresh Var] [DecidableEq Var] open FullEta in +@[wikidata Q1308502] lemma stronglyConfluent_eta : StronglyConfluent (@FullEta Var) := by intro _ y z h₁ h₂ suffices ∃ w, ReflGen FullEta y w ∧ ReflGen FullEta z w by grind From 87c249dac6d87c09469e9655be6cb737d58ca1d0 Mon Sep 17 00:00:00 2001 From: thomaskwaring <51426330+thomaskwaring@users.noreply.github.com> Date: Sat, 13 Jun 2026 11:18:11 +0200 Subject: [PATCH 24/51] chore(LTS): add API for TraceEq and relatives (#617) Follow-up to cslib#613 adding API & simplifying arguments related to trace equivalence. --- - [ ] depends on: cslib#613 --------- Co-authored-by: twwar --- Cslib/Foundations/Semantics/LTS/Basic.lean | 63 +++++++- .../Semantics/LTS/Bisimulation.lean | 53 +++---- .../Foundations/Semantics/LTS/Execution.lean | 7 - .../Foundations/Semantics/LTS/Simulation.lean | 21 +-- Cslib/Foundations/Semantics/LTS/TraceEq.lean | 148 +++++++++++------- 5 files changed, 177 insertions(+), 115 deletions(-) diff --git a/Cslib/Foundations/Semantics/LTS/Basic.lean b/Cslib/Foundations/Semantics/LTS/Basic.lean index 0f56865026..508636adb9 100644 --- a/Cslib/Foundations/Semantics/LTS/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/Basic.lean @@ -78,13 +78,22 @@ Definition of a multistep transition. rule. This makes working with lists of labels more convenient, because we follow the same construction. It is also similar to what is done in the `SimpleGraph` library in mathlib.) -/ -@[scoped grind] +@[scoped grind, mk_iff] inductive MTr (lts : LTS State Label) : State → List Label → State → Prop where | refl {s : State} : lts.MTr s [] s | stepL {s1 : State} {μ : Label} {s2 : State} {μs : List Label} {s3 : State} : lts.Tr s1 μ s2 → lts.MTr s2 μs s3 → lts.MTr s1 (μ :: μs) s3 +/-- In any zero-steps multistep transition, the origin and the derivative are the same. -/ +@[scoped grind .] +theorem MTr.nil_eq (h : lts.MTr s1 [] s2) : s1 = s2 := by + cases h + rfl + +@[simp] theorem MTr.nil_iff (s1 s2 : State) : lts.MTr s1 [] s2 ↔ s1 = s2 := + ⟨nil_eq lts, fun h => h ▸ MTr.refl⟩ + /-- Any transition is also a multistep transition. -/ @[scoped grind →] theorem MTr.single {s1 : State} {μ : Label} {s2 : State} : @@ -94,6 +103,16 @@ theorem MTr.single {s1 : State} {μ : Label} {s2 : State} : · exact h · apply MTr.refl +/-- A multistep transition along `μ :: μs` is a transition labelled by `μ` plus a multistep +transition labelled by `μs`. -/ +theorem MTr.cons_iff {lts : LTS State Label} : + lts.MTr s1 (μ :: μs) s2 ↔ ∃ s, lts.Tr s1 μ s ∧ lts.MTr s μs s2 := by + constructor + · rintro (_ | ⟨htr, hmtr⟩) + exact ⟨_, htr, hmtr⟩ + · intro ⟨s, htr, hmtr⟩ + exact .stepL htr hmtr + /-- Any multistep transition can be extended by adding a transition. -/ theorem MTr.stepR {s1 : State} {μs : List Label} {s2 : State} {μ : Label} {s3 : State} : lts.MTr s1 μs s2 → lts.Tr s2 μ s3 → lts.MTr s1 (μs ++ [μ]) s3 := by @@ -128,11 +147,28 @@ theorem MTr.single_invert (s1 : State) (μ : Label) (s2 : State) : cases hmtr exact htr -/-- In any zero-steps multistep transition, the origin and the derivative are the same. -/ -@[scoped grind .] -theorem MTr.nil_eq (h : lts.MTr s1 [] s2) : s1 = s2 := by - cases h - rfl +/-- A 1-sized multistep transition is exactly a single transision with the given label. -/ +@[simp] theorem MTr.singleton_iff (s1 : State) (μ : Label) (s2 : State) : + lts.MTr s1 [μ] s2 ↔ lts.Tr s1 μ s2 := ⟨MTr.single_invert lts s1 μ s2, MTr.single lts⟩ + +/-- A multistep transition over a concatenation can be split into two multistep transitions. -/ +theorem MTr.split {lts : LTS State Label} (h : lts.MTr s1 (μs ++ μs') s2) : + ∃ s, lts.MTr s1 μs s ∧ lts.MTr s μs' s2 := by + induction μs generalizing s1 s2 with + | nil => use s1, .refl, h + | cons μ μs ih => + rw [List.cons_append] at h + cases h + case stepL s htr hmtr => + obtain ⟨s', hmtr', hmtr''⟩ := ih hmtr + use s', .stepL htr hmtr', hmtr'' + +/-- Multistep-transitions over `μs ++ μs'` are exactly multistep transitions over `μs` and `μs'` +with a common end & start state (respectively). -/ +theorem MTr.append_iff : lts.MTr s1 (μs ++ μs') s2 ↔ ∃ s, lts.MTr s1 μs s ∧ lts.MTr s μs' s2 := by + refine ⟨MTr.split, ?_⟩ + intro ⟨_, h, h'⟩ + exact h.comp lts h' /-- A state `s1` can reach a state `s2` if there exists a multistep transition from `s1` to `s2`. -/ @@ -167,6 +203,21 @@ class Deterministic (lts : LTS State Label) where deterministic (s1 : State) (μ : Label) (s2 s3 : State) : lts.Tr s1 μ s2 → lts.Tr s1 μ s3 → s2 = s3 +theorem Deterministic.eq_of_tr {lts : LTS State Label} [lts.Deterministic] + (htr : lts.Tr s1 μ s2) (htr' : lts.Tr s1 μ s2') : s2 = s2' := + Deterministic.deterministic s1 μ s2 s2' htr htr' + +/-- In a deterministic lts, multistep transitions with a given start state and trace reach a unique +end state. -/ +theorem Deterministic.eq_of_mTr {lts : LTS State Label} [lts.Deterministic] + (hmtr : lts.MTr s1 μs s2) (hmtr' : lts.MTr s1 μs s2') : s2 = s2' := by + induction μs generalizing s1 s2 s2' with + | nil => grind + | cons μ μs ih => + rcases hmtr with (_ | ⟨htr, hmtr⟩); rcases hmtr' with (_ | ⟨htr', hmtr'⟩) + rw [eq_of_tr htr htr'] at hmtr + exact ih hmtr hmtr' + /-- The `μ`-image of a state `s` is the set of all `μ`-derivatives of `s`. -/ @[scoped grind =] def image (s : State) (μ : Label) : Set State := { s' : State | lts.Tr s μ s' } diff --git a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean index 03726febb9..d49a11a04b 100644 --- a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean @@ -9,6 +9,7 @@ module public import Cslib.Foundations.Relation.Domain public import Cslib.Foundations.Semantics.LTS.Simulation public import Cslib.Foundations.Semantics.LTS.TraceEq +public import Mathlib.Tactic.TFAE /-! # Bisimulation and Bisimilarity @@ -183,6 +184,10 @@ instance : IsEquiv State (HomBisimilarity lts) where symm _ _ := Bisimilarity.symm trans _ _ _ := Bisimilarity.trans +/-- Bisimulation implies simulation equivalence. -/ +theorem IsBisimulation.simulationEquiv (h : IsBisimulation lts₁ lts₂ r) (hrel : r s₁ s₂) : + s₁ ≤≥[lts₁,lts₂] s₂ := ⟨⟨r, hrel, h.isSimulation⟩, flip r, hrel, h.inv.isSimulation⟩ + /-- The union of two bisimulations is a bisimulation. -/ @[scoped grind .] theorem IsBisimulation.sup (hrb : IsBisimulation lts₁ lts₂ r) (hsb : IsBisimulation lts₁ lts₂ s) : @@ -302,8 +307,7 @@ theorem IsBisimulationUpTo.isBisimulation (h : IsBisimulationUpTo lts₁ lts₂ /-- If two states are related by a bisimulation, they can mimic each other's multi-step transitions. -/ -theorem IsBisimulation.bisim_trace - (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : +theorem IsBisimulation.bisim_trace (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : ∀ μs s₁', lts₁.MTr s₁ μs s₁' → ∃ s₂', lts₂.MTr s₂ μs s₂' ∧ r s₁' s₂' := hb.isSimulation.sim_trace hr @@ -311,21 +315,8 @@ theorem IsBisimulation.bisim_trace /-- Any bisimulation implies trace equivalence. -/ @[scoped grind =>] -theorem IsBisimulation.traceEq - (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : - s₁ ~tr[lts₁,lts₂] s₂ := by - ext μs - constructor - case mp => - intro h - obtain ⟨s₁', h⟩ := h - obtain ⟨s₂', hmtr⟩ := IsBisimulation.bisim_trace hb hr μs s₁' h - use s₂', hmtr.1 - case mpr => - intro h - obtain ⟨s₂', h⟩ := h - obtain ⟨s₁', hmtr⟩ := IsBisimulation.bisim_trace hb.inv hr μs s₂' h - use s₁', hmtr.1 +theorem IsBisimulation.traceEq (hb : IsBisimulation lts₁ lts₂ r) (hr : r s₁ s₂) : + s₁ ~tr[lts₁,lts₂] s₂ := (hb.simulationEquiv hr).traceEq /-- Bisimilarity is included in trace equivalence. -/ @[scoped grind .] @@ -412,30 +403,30 @@ theorem IsBisimulation.deterministic_traceEq_isBisimulation [lts₁.Deterministic] [lts₂.Deterministic] : (IsBisimulation lts₁ lts₂ (TraceEq lts₁ lts₂)) := by rw [IsBisimulation.isSimulation_iff, TraceEq.flip_eq] - exact ⟨TraceEq.deterministic_isSimulation, TraceEq.deterministic_isSimulation⟩ + exact ⟨Deterministic.isSimulation_traceEq, Deterministic.isSimulation_traceEq⟩ /-- In deterministic LTSs, trace equivalence implies bisimilarity. -/ theorem Bisimilarity.deterministic_traceEq_bisim {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} [lts₁.Deterministic] [lts₂.Deterministic] (h : s₁ ~tr[lts₁,lts₂] s₂) : (s₁ ~[lts₁,lts₂] s₂) := by - exists TraceEq lts₁ lts₂ - constructor - case left => - exact h - case right => - apply IsBisimulation.deterministic_traceEq_isBisimulation + use TraceEq lts₁ lts₂, h, IsBisimulation.deterministic_traceEq_isBisimulation + +/-- In a deterministic lts, bisimilarity, trace equivalence, and simulation equivalence are +equivalent to one-another. -/ +theorem Deterministic.bisim_tfae {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} + [lts₁.Deterministic] [lts₂.Deterministic] (s₁ : State₁) (s₂ : State₂) : + [s₁ ~[lts₁,lts₂] s₂, s₁ ~tr[lts₁,lts₂] s₂, s₁ ≤≥[lts₁,lts₂] s₂].TFAE := by + tfae_have 2 ↔ 3 := Deterministic.traceEq_iff_simulationEquiv s₁ s₂ + tfae_have 1 → 2 := Bisimilarity.le_traceEq s₁ s₂ + tfae_have 2 → 1 := Bisimilarity.deterministic_traceEq_bisim + tfae_finish /-- In deterministic LTSs, bisimilarity and trace equivalence coincide. -/ theorem Bisimilarity.deterministic_bisim_eq_traceEq {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} [lts₁.Deterministic] [lts₂.Deterministic] : Bisimilarity lts₁ lts₂ = TraceEq lts₁ lts₂ := by - funext s₁ s₂ - simp only [eq_iff_iff] - constructor - case mp => - apply Bisimilarity.le_traceEq - case mpr => - apply Bisimilarity.deterministic_traceEq_bisim + ext s₁ s₂ + exact (Deterministic.bisim_tfae s₁ s₂).out 0 1 /-- Homogeneous bisimilarity can also be characterized through symmetric simulations. -/ theorem HomBisimilarity.symm_simulation : diff --git a/Cslib/Foundations/Semantics/LTS/Execution.lean b/Cslib/Foundations/Semantics/LTS/Execution.lean index ac51c2a1c8..51ced513d3 100644 --- a/Cslib/Foundations/Semantics/LTS/Execution.lean +++ b/Cslib/Foundations/Semantics/LTS/Execution.lean @@ -131,11 +131,4 @@ theorem Execution.split simp [Execution] grind -/-- A multistep transition over a concatenation can be split into two multistep transitions. -/ -theorem MTr.split {lts : LTS State Label} {s0 : State} {μs1 μs2 : List Label} {s2 : State} - (h : lts.MTr s0 (μs1 ++ μs2) s2) : ∃ s1, lts.MTr s0 μs1 s1 ∧ lts.MTr s1 μs2 s2 := by - obtain ⟨ss, h_ss⟩ := Execution.of_mTr h - have := Execution.split h_ss μs1.length - grind - end Cslib.LTS diff --git a/Cslib/Foundations/Semantics/LTS/Simulation.lean b/Cslib/Foundations/Semantics/LTS/Simulation.lean index 25d8ed75dc..aca8ca9fb9 100644 --- a/Cslib/Foundations/Semantics/LTS/Simulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Simulation.lean @@ -89,31 +89,18 @@ theorem IsSimulation.comp (r2 : State₂ → State₃ → Prop) (h1 : IsSimulation lts₁ lts₂ r1) (h2 : IsSimulation lts₂ lts₃ r2) : IsSimulation lts₁ lts₃ (Relation.Comp r1 r2) := by - simp_all only [IsSimulation] intro s₁ s2 hrc μ s₁' htr rcases hrc with ⟨sb, hr1, hr2⟩ - specialize h1 s₁ sb hr1 μ - specialize h2 sb s2 hr2 μ - have h1' := h1 s₁' htr - obtain ⟨s₁'', h1'tr, h1'⟩ := h1' - have h2' := h2 s₁'' h1'tr - obtain ⟨s2'', h2'tr, h2'⟩ := h2' - exists s2'' - constructor - · exact h2'tr - · exists s₁'' + obtain ⟨s₁'', h1'tr, h1'⟩ := h1 s₁ sb hr1 μ s₁' htr + obtain ⟨s2'', h2'tr, h2'⟩ := h2 sb s2 hr2 μ s₁'' h1'tr + use s2'', h2'tr, s₁'', h1', h2' /-- Similarity is transitive. -/ theorem Similarity.trans (h1 : s₁ ≤[lts₁,lts₂] s2) (h2 : s2 ≤[lts₂,lts₃] s₃) : s₁ ≤[lts₁,lts₃] s₃ := by obtain ⟨r1, hr1, hr1s⟩ := h1 obtain ⟨r2, hr2, hr2s⟩ := h2 - exists Relation.Comp r1 r2 - constructor - case left => - exists s2 - case right => - apply IsSimulation.comp r1 r2 hr1s hr2s + use! Relation.Comp r1 r2, s2, hr1, hr2, IsSimulation.comp r1 r2 hr1s hr2s theorem IsSimulation.sup (hr : IsSimulation lts₁ lts₂ r) (hs : IsSimulation lts₁ lts₂ s) : IsSimulation lts₁ lts₂ (r ⊔ s) := by diff --git a/Cslib/Foundations/Semantics/LTS/TraceEq.lean b/Cslib/Foundations/Semantics/LTS/TraceEq.lean index 6a5a6792b5..45782b67a1 100644 --- a/Cslib/Foundations/Semantics/LTS/TraceEq.lean +++ b/Cslib/Foundations/Semantics/LTS/TraceEq.lean @@ -26,7 +26,8 @@ Definitions and results on trace equivalence for `LTS`s. ## Main statements - `TraceEq.eqv`: trace equivalence is an equivalence relation (see `Equivalence`). -- `TraceEq.deterministic_sim`: in any deterministic `LTS`, trace equivalence is a simulation. +- `Deterministic.isSimulation_traceEq`: in any deterministic `LTS`, trace equivalence is a + simulation. -/ @@ -34,14 +35,63 @@ Definitions and results on trace equivalence for `LTS`s. namespace Cslib.LTS +open Deterministic + /-- The traces of a state `s` is the set of all lists of labels `μs` such that there is a multi-step transition labelled by `μs` originating from `s`. -/ def traces (lts : LTS State Label) (s : State) := { μs : List Label | ∃ s', lts.MTr s μs s' } +/-- Definition of `LTS.traces` for general label sequences, ... -/ +theorem mem_traces_iff {lts : LTS State Label} (μs : List Label) : + μs ∈ lts.traces s ↔ ∃ s', lts.MTr s μs s' := Iff.rfl + +/-- ... singleton sequences, ... -/ +theorem mem_traces_singleton_iff {lts : LTS State Label} (μ : Label) : + [μ] ∈ lts.traces s ↔ ∃ s', lts.Tr s μ s' := by + simp_rw [mem_traces_iff, MTr.singleton_iff lts s μ] + +/-- ... and sequences extended with a single transition. -/ +theorem mem_traces_cons_iff {lts : LTS State Label} (μ : Label) (μs : List Label) : + (μ :: μs) ∈ lts.traces s ↔ ∃ s', lts.Tr s μ s' ∧ μs ∈ lts.traces s' := by + simp_rw [mem_traces_iff, MTr.cons_iff] + grind + /-- If there is a multi-step transition from `s` labelled by `μs`, then `μs` is in the traces of `s`. -/ theorem traces_in {lts : LTS State Label} (h : lts.MTr s μs s') : μs ∈ lts.traces s := by exists s' +/-- In a deterministic lts, a state's traces are determined by any of its predecessors. -/ +theorem Deterministic.traces_of_tr {lts : LTS State Label} [lts.Deterministic] + (h : lts.Tr s μ s') : lts.traces s' = {μs | μ :: μs ∈ lts.traces s} := by + ext μs + constructor + · intro ⟨s'', hmtr⟩ + use s'', MTr.stepL h hmtr + · intro ⟨s'', hmtr⟩ + rcases hmtr with (_ | ⟨htr, hmtr⟩) + rw [←deterministic _ _ _ _ h htr] at hmtr + exact ⟨s'', hmtr⟩ + +/-- In a deterministic lts, a state's traces are determined by any of its multi-step predecessors. +-/ +theorem Deterministic.traces_of_mTr {lts : LTS State Label} [lts.Deterministic] + (h : lts.MTr s μs s') : lts.traces s' = {μs' | μs ++ μs' ∈ lts.traces s} := by + ext μs' + constructor + · intro ⟨s'', hmtr⟩ + use s'', h.comp _ hmtr + · intro ⟨s'', hmtr⟩ + obtain ⟨smid, hmid, hmid'⟩ := hmtr.split + rw [Deterministic.eq_of_mTr h hmid] + use s'', hmid' + +/-- If `s₁` is simulated by `s₂` all of `s₁`'s traces are also traces of `s₂`. -/ +theorem IsSimulation.traces_subset (hr : IsSimulation lts₁ lts₂ r) (hrel : r s₁ s₂) : + lts₁.traces s₁ ⊆ lts₂.traces s₂ := by + intro μs ⟨s₁', h₁⟩ + obtain ⟨s₂', h₂, _⟩ := hr.sim_trace hrel μs s₁' h₁ + exact ⟨s₂', h₂⟩ + /-- Two states are trace equivalent if they have the same set of traces. -/ def TraceEq (lts₁ : LTS State₁ Label) (lts₂ : LTS State₂ Label) (s₁ : State₁) (s₂ : State₂) := @@ -62,24 +112,19 @@ abbrev HomTraceEq (lts : LTS State Label) := TraceEq lts lts scoped notation s:max " ~tr[" lts "] " s':max => HomTraceEq lts s s' /-- Homogeneous trace equivalence is reflexive. -/ -theorem HomTraceEq.refl (s : State) : s ~tr[lts] s := by - simp only [TraceEq] - -/-- Trace equivalence is symmetric. -/ -theorem TraceEq.symm (h : s₁ ~tr[lts₁,lts₂] s₂) : s₂ ~tr[lts₂,lts₁] s₁ := by - simp only [TraceEq] at h - simp only [TraceEq] - rw [h] +@[refl] theorem HomTraceEq.refl (s : State) : s ~tr[lts] s := rfl @[simp] theorem TraceEq.flip_eq : flip (TraceEq lts₁ lts₂) = TraceEq lts₂ lts₁ := by ext s₁ s₂ - grind [flip, TraceEq.symm] + grind [flip, TraceEq] + +/-- Trace equivalence is symmetric. -/ +theorem TraceEq.symm (h : s₁ ~tr[lts₁,lts₂] s₂) : s₂ ~tr[lts₂,lts₁] s₁ := by + rwa [←flip_eq] /-- Trace equivalence is transitive. -/ theorem TraceEq.trans (h1 : s₁ ~tr[lts₁,lts₂] s₂) (h2 : s₂ ~tr[lts₂,lts₃] s₃) : - s₁ ~tr[lts₁,lts₃] s₃ := by - simp only [TraceEq] at * - rw [h1, h2] + s₁ ~tr[lts₁,lts₃] s₃ := Eq.trans h1 h2 /-- Homogeneous trace equivalence is an equivalence relation. -/ theorem HomTraceEq.eqv : Equivalence (· ~tr[lts] ·) where @@ -91,50 +136,45 @@ theorem HomTraceEq.eqv : Equivalence (· ~tr[lts] ·) where instance : Trans (TraceEq lts₁ lts₂) (TraceEq lts₂ lts₃) (TraceEq lts₁ lts₃) where trans := TraceEq.trans +/-- For trace-equivalent states, any multistep transition of one can be mimiced by the other. -/ +theorem TraceEq.exists_mTr_of_mTr {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} + (h : s₁ ~tr[lts₁,lts₂] s₂) (htr : lts₁.MTr s₁ μs s₁') : ∃ s₂', lts₂.MTr s₂ μs s₂' := by + rw [←mem_traces_iff, ←h] + exact ⟨s₁', htr⟩ + +/-- For trace-equivalent states, any single-step transition of one can be mimiced by the other. -/ +theorem TraceEq.exists_tr_of_tr {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} + (h : s₁ ~tr[lts₁,lts₂] s₂) (htr : lts₁.Tr s₁ μ s₁') : ∃ s₂', lts₂.Tr s₂ μ s₂' := by + rw [←mem_traces_singleton_iff, ←h, mem_traces_singleton_iff] + exact ⟨s₁', htr⟩ + +/-- For deterministic lts's, trace equivalence is preseved by respective transitions with the same +label. -/ +theorem TraceEq.traceEq_of_tr_of_tr {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} + [hdet₁ : lts₁.Deterministic] [hdet₂ : lts₂.Deterministic] (h : s₁ ~tr[lts₁,lts₂] s₂) + (htr₁ : lts₁.Tr s₁ μ s₁') (htr₂ : lts₂.Tr s₂ μ s₂') : s₁' ~tr[lts₁,lts₂] s₂' := by + rw [TraceEq] at h + simp_rw [TraceEq, Deterministic.traces_of_tr htr₁, Deterministic.traces_of_tr htr₂, h] + /-- In deterministic LTSs, trace equivalence is a simulation. -/ -theorem TraceEq.deterministic_isSimulation {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} +theorem Deterministic.isSimulation_traceEq {lts₁ : LTS State₁ Label} {lts₂ : LTS State₂ Label} [hdet₁ : lts₁.Deterministic] [hdet₂ : lts₂.Deterministic] : IsSimulation lts₁ lts₂ (TraceEq lts₁ lts₂) := by intro s₁ s₂ h μ s₁' htr1 - have hmtr1 := MTr.single lts₁ htr1 - have hin := traces_in hmtr1 - rw [h] at hin - obtain ⟨s₂', hmtr2⟩ := hin - exists s₂' - constructor - · apply MTr.single_invert lts₂ _ _ _ hmtr2 - · simp only [TraceEq, traces] - funext μs' - simp only [eq_iff_iff] - simp only [setOf] - constructor - case mp => - intro hmtr1' - obtain ⟨s₁'', hmtr1'⟩ := hmtr1' - have hmtr1comp := MTr.comp lts₁ hmtr1 hmtr1' - have hin := traces_in hmtr1comp - rw [h] at hin - obtain ⟨s', hmtr2'⟩ := hin - cases hmtr2' - case stepL s₂'' htr2 hmtr2' => - exists s' - have htr2' := MTr.single_invert lts₂ _ _ _ hmtr2 - have hdets₂ := hdet₂.deterministic s₂ μ s₂' s₂'' htr2' htr2 - rw [hdets₂] - exact hmtr2' - case mpr => - intro hmtr2' - obtain ⟨s₂'', hmtr2'⟩ := hmtr2' - have hmtr2comp := MTr.comp lts₂ hmtr2 hmtr2' - have hin := traces_in hmtr2comp - rw [← h] at hin - obtain ⟨s', hmtr1'⟩ := hin - cases hmtr1' - case stepL s₁'' htr1 hmtr1' => - exists s' - have htr1' := MTr.single_invert lts₁ _ _ _ hmtr1 - have hdets₁ := hdet₁.deterministic s₁ μ s₁' s₁'' htr1' htr1 - rw [hdets₁] - exact hmtr1' + obtain ⟨s₂', htr2⟩ := h.exists_tr_of_tr htr1 + use s₂', htr2, h.traceEq_of_tr_of_tr htr1 htr2 + +/-- Simulation equivalence implies trace equivalence. -/ +theorem SimulationEquiv.traceEq (h : s₁ ≤≥[lts₁,lts₂] s₂) : s₁ ~tr[lts₁,lts₂] s₂ := by + obtain ⟨⟨_, h, hr⟩, _, h', hr'⟩ := h + exact (hr.traces_subset h).antisymm (hr'.traces_subset h') + +/-- Simulation equivalence and trace equivalence are equivalence for detemrinistic lts's. -/ +theorem Deterministic.traceEq_iff_simulationEquiv {lts₁ : LTS State₁ Label} + {lts₂ : LTS State₂ Label} [hdet₁ : lts₁.Deterministic] [hdet₂ : lts₂.Deterministic] + (s₁ : State₁) (s₂ : State₂) : (s₁ ~tr[lts₁,lts₂] s₂) ↔ s₁ ≤≥[lts₁,lts₂] s₂ := + ⟨fun h => + ⟨⟨_, h, Deterministic.isSimulation_traceEq⟩, _, h.symm, Deterministic.isSimulation_traceEq⟩, + SimulationEquiv.traceEq⟩ end Cslib.LTS From 8ea71c8df91acd63285515a04da952b23b78d266 Mon Sep 17 00:00:00 2001 From: Garmelon Date: Mon, 15 Jun 2026 17:28:29 +0200 Subject: [PATCH 25/51] chore: bump toolchain to v4.31.0 (#651) --- lake-manifest.json | 20 ++++++++++---------- lakefile.toml | 2 +- lean-toolchain | 2 +- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/lake-manifest.json b/lake-manifest.json index 919ac1cf23..03ce69cd2f 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "73b2611ac34fe053446b21322ee51d19cb27b3e7", + "rev": "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "73b2611ac34fe053446b21322ee51d19cb27b3e7", + "inputRev": "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "744117af710b1c0400cd297c9ce91f8d0ad3a347", + "rev": "63045536fe95024e6c18fc7b48e03f506701c5bc", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "99c763c8a96d3d44fb4994e96eaa51ca4568449d", + "rev": "5c7542ed018c78194f1e2b903eaf6a792b74c03d", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "1537e3fc7e680d64e06fe5fb95c4c9edee7941c2", + "rev": "24b0d9dc081c5423f8eec7e866c441e5184f29d9", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "7897ea6e5cfc6522d355083bdfa798377ab35e11", + "rev": "e3cb2f741431ce31bf73549fb52316a57368b06f", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "94346b7b49c36ae871639d1434232f057c193d60", + "rev": "f46324995fca5f0483b742e4eb4daec7f4ee50d2", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "5dd219c775e402f818b42cd3997b5cf21017babf", + "rev": "fa08db58b30eb033edcdab331bba000827f9f785", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "baf3e62fbb3502305076ca077e004aea78157c63", + "rev": "92564e5770e4d09f2d86dfbf8ada1e9c715b384c", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "v4.31.0", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 33bb67166e..7149fcc85e 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "73b2611ac34fe053446b21322ee51d19cb27b3e7" +rev = "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index e6a8c3c1fa..18640c8b06 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.31.0-rc2 +leanprover/lean4:v4.31.0 From 70c5bf5874a1a511b32ad1ae605c07a13345d071 Mon Sep 17 00:00:00 2001 From: thomaskwaring <51426330+thomaskwaring@users.noreply.github.com> Date: Tue, 16 Jun 2026 08:40:07 +0200 Subject: [PATCH 26/51] refactor(Logics/Propositional): classical and intuitionistic inference systems (#536) We amend the definitions of `IsClassical` and `IsIntuitionistic` in `Logics.Propositional.Defs` to refer to an inference system, rather than a theory. This makes inhabitation of these typeclasses independent of the chosen axiomatisation, so, for instance, we can define `instance instIsIntuitionisticOfIsClassical [IsClassical Atom T] : IsIntuitionistic Atom T`, which before was impossible. We describe some common alternative axiom systems for classical logic, and introduce some derived rules. --------- Co-authored-by: twwar --- Cslib.lean | 1 + Cslib/Logics/Propositional/Defs.lean | 71 +++++------- .../Propositional/NaturalDeduction/Basic.lean | 2 +- .../NaturalDeduction/Theory.lean | 101 ++++++++++++++++++ 4 files changed, 132 insertions(+), 43 deletions(-) create mode 100644 Cslib/Logics/Propositional/NaturalDeduction/Theory.lean diff --git a/Cslib.lean b/Cslib.lean index 5932e92075..6e70be7b9d 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -147,6 +147,7 @@ public import Cslib.Logics.Modal.Denotation public import Cslib.Logics.Modal.LogicalEquivalence public import Cslib.Logics.Propositional.Defs public import Cslib.Logics.Propositional.NaturalDeduction.Basic +public import Cslib.Logics.Propositional.NaturalDeduction.Theory public import Cslib.MachineLearning.PACLearning.Defs public import Cslib.MachineLearning.PACLearning.VCDimension public import Cslib.MachineLearning.PACLearning.VersionSpace diff --git a/Cslib/Logics/Propositional/Defs.lean b/Cslib/Logics/Propositional/Defs.lean index fa3caf53e2..e9c603d91b 100644 --- a/Cslib/Logics/Propositional/Defs.lean +++ b/Cslib/Logics/Propositional/Defs.lean @@ -6,7 +6,7 @@ Authors: Thomas Waring module -public import Cslib.Init +public import Cslib.Foundations.Logic.InferenceSystem public import Mathlib.Data.FunLike.Basic public import Mathlib.Data.Set.Image public import Mathlib.Order.TypeTags @@ -99,56 +99,43 @@ instance : Functor Theory where map f := Set.image (f <$> ·) /-- The empty theory corresponds to minimal propositional logic. -/ -abbrev MPL : Theory (Atom) := ∅ +abbrev MPL (Atom : Type u) : Theory (Atom) := ∅ /-- Intuitionistic propositional logic adds the principle of explosion (ex falso quodlibet). -/ -abbrev IPL [Bot Atom] : Theory Atom := - Set.range (⊥ → ·) - -/-- Classical logic further adds double negation elimination. -/ -abbrev CPL [Bot Atom] : Theory Atom := - Set.range (fun (A : Proposition Atom) ↦ ¬¬A → A) - -/-- A theory is intuitionistic if it validates ex falso quodlibet. -/ -@[scoped grind] -class IsIntuitionistic [Bot Atom] (T : Theory Atom) where - efq (A : Proposition Atom) : (⊥ → A) ∈ T - -omit [DecidableEq Atom] in -@[scoped grind =] -theorem isIntuitionisticIff [Bot Atom] (T : Theory Atom) : IsIntuitionistic T ↔ IPL ⊆ T := by grind - -/-- A theory is classical if it validates double-negation elimination. -/ -@[scoped grind] -class IsClassical [Bot Atom] (T : Theory Atom) where - dne (A : Proposition Atom) : (¬¬A → A) ∈ T +abbrev IPL (Atom : Type u) [Bot Atom] : Theory Atom := {⊥ → A | A : Proposition Atom} omit [DecidableEq Atom] in -@[scoped grind =] -theorem isClassicalIff [Bot Atom] (T : Theory Atom) : IsClassical T ↔ CPL ⊆ T := by grind +lemma efq_mem_ipl [Bot Atom] (A : Proposition Atom) : (⊥ → A) ∈ IPL Atom := ⟨A, rfl⟩ -instance instIsIntuitionisticIPL [Bot Atom] : IsIntuitionistic (Atom := Atom) IPL where - efq A := Set.mem_range.mpr ⟨A, rfl⟩ - -instance instIsClassicalCPL [Bot Atom] : IsClassical (Atom := Atom) CPL where - dne A := Set.mem_range.mpr ⟨A, rfl⟩ +/-- Attach a bottom element to a theory `T`, and the principle of explosion for that bottom. -/ +@[reducible] +def intuitionisticCompletion (T : Theory Atom) : Theory (WithBot Atom) := + (WithBot.some <$> T) ∪ IPL (WithBot Atom) -omit [DecidableEq Atom] in -@[scoped grind →] -theorem instIsIntuitionisticExtention [Bot Atom] {T T' : Theory Atom} [IsIntuitionistic T] - (h : T ⊆ T') : IsIntuitionistic T' := by grind +/-- Classical logic further adds double negation elimination. -/ +abbrev CPL (Atom : Type u) [Bot Atom] : Theory Atom := {¬¬A → A | A : Proposition Atom} omit [DecidableEq Atom] in -@[scoped grind →] -theorem instIsClassicalExtention [Bot Atom] {T T' : Theory Atom} [IsClassical T] (h : T ⊆ T') : - IsClassical T' := by grind +lemma dne_mem_cpl [Bot Atom] (A : Proposition Atom) : (¬¬A → A) ∈ CPL Atom := ⟨A, rfl⟩ -/-- Attach a bottom element to a theory `T`, and the principle of explosion for that bottom. -/ -@[reducible] -def intuitionisticCompletion (T : Theory Atom) : Theory (WithBot Atom) := - (WithBot.some <$> T) ∪ IPL +open InferenceSystem -instance instIsIntuitionisticIntuitionisticCompletion (T : Theory Atom) : - IsIntuitionistic T.intuitionisticCompletion := by grind +/-- An inference system is intuitionistic if it derives ex falso quodlibet. TODO: this should be +generalised outside the `PL` scope, once we have typeclasses to express that a type possesses an +implication connective. -/ +@[scoped grind] +class IsIntuitionistic (Atom : Type u) [Bot Atom] (S : Type*) + [InferenceSystem S (Proposition Atom)] where + /-- The principle of explosion (ex falso quolibet). -/ + efq (A : Proposition Atom) : S⇓(⊥ → A) + +/-- An inference system is classical if it validates double-negation elimination. TODO: this should +be generalised outside the `PL` scope, once we have typeclasses to express that a type possesses an +implication connective. -/ +@[scoped grind] +class IsClassical (Atom : Type u) [Bot Atom] (S : Type*) + [InferenceSystem S (Proposition Atom)] where + /-- Double-negation elimination. -/ + dne (A : Proposition Atom) : S⇓(¬¬A → A) end Cslib.Logic.PL.Theory diff --git a/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean b/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean index b1a8947e20..560ecb69e2 100644 --- a/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean +++ b/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean @@ -156,7 +156,7 @@ theorem Theory.equiv_iff {A B : Proposition Atom} : exact ⟨D, E⟩ /-- Minimally equivalent propositions. -/ -abbrev Equiv : Proposition Atom → Proposition Atom → Prop := MPL.Equiv +abbrev Equiv : Proposition Atom → Proposition Atom → Prop := (MPL Atom).Equiv @[inherit_doc] scoped infix:29 " ≡ " => Equiv diff --git a/Cslib/Logics/Propositional/NaturalDeduction/Theory.lean b/Cslib/Logics/Propositional/NaturalDeduction/Theory.lean new file mode 100644 index 0000000000..8cdaa806df --- /dev/null +++ b/Cslib/Logics/Propositional/NaturalDeduction/Theory.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2025 Thomas Waring. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Thomas Waring +-/ +module + +public import Cslib.Logics.Propositional.NaturalDeduction.Basic + +/-! # Results on propositional theories + +In this file we prove the expected results that `IPL Atom` is an intuitionistic theory, and +`CPL Atom` is a classical theory. We provide derived rules for common intuitionistic and classical +proof patterns. +-/ + +@[expose] public section + +universe u + +namespace Cslib.Logic.PL + +open Proposition Theory InferenceSystem DerivableIn Derivation IsIntuitionistic IsClassical + +variable {Atom : Type u} [DecidableEq Atom] [Bot Atom] {T : Theory Atom} + +namespace Theory + +instance instIsIntuitionisticIPL : IsIntuitionistic Atom (IPL Atom) where + efq A := ax (efq_mem_ipl A) + +/-- Derivation of efq in an arbitrary context. -/ +def IsIntuitionistic.efqCtx [IsIntuitionistic Atom T] (Γ : Ctx Atom) (A : Proposition Atom) + : T⇓(Γ ⊢ ⊥ → A) := (efq A : T⇓(⊥ → A)).weakCtx (Finset.empty_subset Γ) + +/-- Efq as a derived rule. -/ +def IsIntuitionistic.efqRule [IsIntuitionistic Atom T] (Γ : Ctx Atom) (A : Proposition Atom) + (D : T⇓(Γ ⊢ ⊥)) : T⇓(Γ ⊢ A) := + implE (A := ⊥) (efqCtx Γ A) D + +/-- Prove any proposition from contradictory hypotheses. -/ +def IsIntuitionistic.contra [IsIntuitionistic Atom T] {Γ : Ctx Atom} (A B : Proposition Atom) + (hΓ : A ∈ Γ) (hΓ' : (¬A) ∈ Γ) : T⇓(Γ ⊢ B) := + efqRule Γ B <| implE (ass hΓ') (ass hΓ) + +instance instIsClassicalCPL : IsClassical Atom (CPL Atom) where + dne A := ax (dne_mem_cpl A) + +/-- Proof by contradiction as a derived rule. -/ +def IsClassical.byContra [IsClassical Atom T] {Γ : Ctx Atom} {A : Proposition Atom} + (D : T⇓(insert (¬ A) Γ ⊢ ⊥)) : T⇓(Γ ⊢ A) := + implE (A := ¬¬A) ((dne A : T⇓(¬¬A → A)) |>.weakCtx <| Finset.empty_subset ..) D.implI + +instance instIsIntuitionisticOfIsClassical [IsClassical Atom T] : IsIntuitionistic Atom T where + efq A := implI _ <| byContra <| ass (by grind) + +/-- Law of excluded middle in a classical theory. -/ +def IsClassical.lem [IsClassical Atom T] (A : Proposition Atom) : T⇓(A ∨ ¬ A) := by + apply byContra + apply implE (ass <| Finset.mem_insert_self ..) + apply orI₂; apply implI + apply implE (A := A ∨ ¬ A) (ass <| by grind) + exact orI₁ <| ass <| Finset.mem_insert_self .. + +/-- Pierce's law in a classical theory. -/ +def IsClassical.pierce [IsClassical Atom T] (A B : Proposition Atom) : T⇓(((A → B) → A) → A) := by + apply implI; apply byContra + apply implE (ass <| Finset.mem_insert_self ..) + apply implE (A := A → B) (ass <| by grind); apply implI + apply contra A B <;> grind + +/-- The axiom system consisting of instances of LEM. -/ +def LEM (Atom : Type u) [Bot Atom] : Theory Atom := {A ∨ ¬ A | A : Proposition Atom} + +omit [DecidableEq Atom] in +lemma lem_mem_lem (A : Proposition Atom) : (A ∨ ¬ A) ∈ LEM Atom := ⟨A, rfl⟩ + +/-- The axiom system consisting of instances of Pierce's law. -/ +def Pierce (Atom : Type u) : Theory Atom := + {((A → B) → A) → A | (A : Proposition Atom) (B : Proposition Atom)} + +omit [DecidableEq Atom] [Bot Atom] in +lemma pierce_mem_pierce (A B : Proposition Atom) : (((A → B) → A) → A) ∈ Pierce Atom := ⟨A, B, rfl⟩ + +instance instIsClassicalLEM : IsClassical Atom (LEM Atom ∪ IPL Atom : Theory Atom) where + dne A := by + apply implI + apply orE (ax <| Set.mem_union_left _ <| lem_mem_lem A) + · exact ass (Finset.mem_insert_self A _) + · apply implE (A := ⊥) (ax <| Set.mem_union_right _ (efq_mem_ipl A)) + apply implE (A := ¬ A) <;> exact ass (by grind) + +instance instIsClassicalPierce : IsClassical Atom (Pierce Atom ∪ IPL Atom : Theory Atom) where + dne A := by + apply implI + apply implE (A := (A → ⊥) → A) (ax <| Set.mem_union_left _ <| pierce_mem_pierce A ⊥) + apply implI + apply implE (A := ⊥) (ax <| Set.mem_union_right _ (efq_mem_ipl A)) + apply implE (A := ¬ A) <;> exact ass (by grind) + +end Cslib.Logic.PL.Theory From c2197aca422e341b78650acb69b5441b30139d21 Mon Sep 17 00:00:00 2001 From: Ching-Tsun Chou Date: Fri, 19 Jun 2026 02:12:12 -0700 Subject: [PATCH 27/51] feat(FLP): show that asynchronous distributed consensus is possible when there is no fault (#619) This PR presents an asynchronous distributed consensus algorithm and proves that it achieves consensus when there is no fault. This result is not needed for proving the FLP impossibility result, but is included to show that the notion of an algorithm defined in `Algorithm.lean` is not vacuous, in the sense that it does allow a working asynchronous consensus algorithm when there is no fault. Zulip discussion: https://leanprover.zulipchat.com/#narrow/channel/513188-CSLib/topic/Impossibility.20of.20distributed.20consensus/with/592462001 --- Cslib.lean | 1 + .../Distributed/FLP/Consensus.lean | 15 ++ Cslib/Computability/Distributed/FLP/README.md | 7 +- .../Distributed/FLP/ZeroConsensus.lean | 171 ++++++++++++++++++ Cslib/Foundations/Semantics/LTS/Basic.lean | 16 ++ 5 files changed, 209 insertions(+), 1 deletion(-) create mode 100644 Cslib/Computability/Distributed/FLP/ZeroConsensus.lean diff --git a/Cslib.lean b/Cslib.lean index 6e70be7b9d..6e69fa398c 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -24,6 +24,7 @@ public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.NA.Total public import Cslib.Computability.Distributed.FLP.Algorithm public import Cslib.Computability.Distributed.FLP.Consensus +public import Cslib.Computability.Distributed.FLP.ZeroConsensus public import Cslib.Computability.Languages.Congruences.BuchiCongruence public import Cslib.Computability.Languages.Congruences.RightCongruence public import Cslib.Computability.Languages.ExampleEventuallyZero diff --git a/Cslib/Computability/Distributed/FLP/Consensus.lean b/Cslib/Computability/Distributed/FLP/Consensus.lean index b7209ed905..e83ee2aab0 100644 --- a/Cslib/Computability/Distributed/FLP/Consensus.lean +++ b/Cslib/Computability/Distributed/FLP/Consensus.lean @@ -100,6 +100,21 @@ def Algorithm.Consensus [Fintype P] (a : Algorithm P M S) (f : ℕ) : Prop := variable {a : Algorithm P M S} {inp : P → Bool} +/-- Specialize the definition of `Algorithm.AdmissibleRun` to the case of zero fault. -/ +theorem AdmissibleRun.fault_zero [Fintype P] + {xs : ωSequence (Action P M)} {ss : ωSequence (State P M S)} : + a.AdmissibleRun inp 0 ss xs ↔ + ss 0 = a.start inp ∧ a.lts.OmegaExecution ss xs ∧ ∀ p, ProcFair p ss xs := by + constructor + · rintro ⟨_, _, _, hf⟩ + suffices ∀ p, ¬ ProcFaulty p ss xs by grind [FairRun, not_procFaulty_and_procFair] + simp (disch := toFinite_tac) [numProcFaulty, ncard_eq_zero, Set.ext_iff] at hf + assumption + · rintro ⟨hi, hr, _⟩ + use hi, hr, by grind [FairRun] + have : ∀ p, ¬ ProcFaulty p ss xs := by grind [not_procFaulty_and_procFair] + simpa (disch := toFinite_tac) [numProcFaulty, ncard_eq_zero, Set.ext_iff] + /-- If an infinite execution is admissible with up tp `f` faulty processes, then it is also admissible with with up tp `f' ≥ f` faulty processes. -/ theorem AdmissibleRun.fault_mono [Fintype P] {f f' : ℕ} diff --git a/Cslib/Computability/Distributed/FLP/README.md b/Cslib/Computability/Distributed/FLP/README.md index 7bc8e7bd36..309a8325a9 100644 --- a/Cslib/Computability/Distributed/FLP/README.md +++ b/Cslib/Computability/Distributed/FLP/README.md @@ -32,11 +32,16 @@ consensus is impossible in the presence of even a single crash fault. which doesn't contain any fault but never reaches a consensus, which then implies that there cannot be a consensus algorithm that can tolerate even a single fault. +8. `ZeroConsensus.lean` presents a simple distributed consensus algorithm and proves that it achieves + consensus if there is no fault. This file is not needed for proving the impossibility result, but is + included to show that the notion of an algorithm defined in `Algorithm.lean` is not vacuous, in the + sense that it allows a working consensus algorithm when there is no fault. + Files #1 and #2 contains materials common to both [FLP1985] and [Volzer2004]. File #3 provides proof details that are either completely omitted (in the case of `PseudoConsensus.of_consensus`) or only hinted at (in the case of `OnePseudoConsensus.fair_nonUniform`) in [Volzer2004]. -The remaining files follow the development in [Volzer2004] fairly closely, +The remaining files (except #8) follow the development in [Volzer2004] fairly closely, as is explained further in each file. ## References diff --git a/Cslib/Computability/Distributed/FLP/ZeroConsensus.lean b/Cslib/Computability/Distributed/FLP/ZeroConsensus.lean new file mode 100644 index 0000000000..96d885a876 --- /dev/null +++ b/Cslib/Computability/Distributed/FLP/ZeroConsensus.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Computability.Distributed.FLP.Consensus +public import Cslib.Foundations.Data.OmegaSequence.Temporal + +/-! # Asynchronous distributed consensus in the absence of faults + +This file presents an asynchronous distributed consensus algorithm and proves that it does achieve +consensus when there is no fault. Assume that there are `n` processes numbered 0, 1, ..., `n - 1`. +The algorithm works as follows: +(1) Process 0 receives its input value and sends that value to all processes (including itself). + All other processes ignore their inputs upon receiving them. +(2) Upon receiving the value sent by process 0 in the previpus step, every process (including + process 0) decides on that value. +Clearly, if there is no fault and all messages are eventually delivered, every process will +eventually decide on the same value, namely, the input value at process 0. + +The contents of this file are not needed for proving the FLP impossibility result, but do show +that the notion of an `Algorithm` is not vacuous, in the sense that it allows a working +asynchronous consensus algorithm when there is no fault. +-/ + +@[expose] public section + +namespace Cslib.FLP.ZeroFaultAlg + +open Set Sum Option Multiset ωSequence + +/-- The payload of a message is of type `Bool ⊕ Bool`, where `inl b` denotes an input value `b` +ane `inr b` denotes a value `b` sent by process 0 to all processes (including itself). -/ +abbrev M := Bool + +/-- The local state of a process is trivial. -/ +abbrev S := Unit + +variable {n : ℕ} (npos : 0 < n) + +/-- `alg` is the asynchronous distributed consensus algorithm described above. -/ +def alg : Algorithm (Fin n) M S where + init _ := () + next _ _ := () + send m _ := match m.msg with + | inl b => + if m.dest = ⟨0, npos⟩ then Multiset.map (fun p ↦ ⟨p, inr b⟩) Finset.univ.val else 0 + | inr _ => 0 + out m _ := match m.msg with + | inl _ => none + | inr b => some b + +/-- `Inv` is an invariant for `alg`. -/ +def Inv (inp : Fin n → Bool) (s : State (Fin n) M S) : Prop := + (∀ m, m ∈ s.msgs → m.msg = inl (inp m.dest) ∨ m.msg = inr (inp ⟨0, npos⟩)) ∧ + (∀ p, (s.proc p).out = none ∨ (s.proc p).out = some (inp ⟨0, npos⟩)) + +/-- `Inv` is true at any initial state. -/ +theorem inv_start (inp : Fin n → Bool) : + Inv npos inp ((alg npos).start inp) := by + simp [alg, Inv, Algorithm.start] + +/-- What happens when an `inl` message is received. -/ +theorem inv_tr_left (inp : Fin n → Bool) {s t : State (Fin n) M S} {m : Message (Fin n) M} + (hs : Inv npos inp s) (htr : (alg npos).lts.Tr s (some m) t) (hm : m.msg.isLeft) : + t.msgs = s.msgs.erase m + + ( if m.dest = ⟨0, npos⟩ then Multiset.map (fun p ↦ ⟨p, inr (inp ⟨0, npos⟩)⟩) Finset.univ.val + else 0 ) ∧ + ∀ p, (t.proc p).out = (s.proc p).out := by + simp only [alg] at htr + split_ands <;> grind [Inv, Algorithm.lts, Algorithm.recvMsg] + +/-- What happens when an `inr` message is received. -/ +theorem inv_tr_right (inp : Fin n → Bool) {s t : State (Fin n) M S} {m : Message (Fin n) M} + (hs : Inv npos inp s) (htr : (alg npos).lts.Tr s (some m) t) (hm : m.msg.isRight) : + t.msgs = s.msgs.erase m ∧ (t.proc m.dest).out = some (inp ⟨0, npos⟩) ∧ + ∀ p, p ≠ m.dest → (t.proc p).out = (s.proc p).out := by + simp only [alg] at htr + grind [Inv, Algorithm.lts, Algorithm.recvMsg] + +/-- The truth of `Inv` is preserved by every transition of `alg`. -/ +theorem trInv_inv (inp : Fin n → Bool) : (alg npos).lts.TrInv (Inv npos inp) := by + intro s x t htr hs + rcases eq_none_or_eq_some x with _ | ⟨m, rfl⟩ + · grind [Algorithm.lts] + · have h1 : m.msg = inl (inp m.dest) ∨ m.msg = inr (inp ⟨0, npos⟩) := by + grind [Inv, Algorithm.lts] + rcases h1 + · have := inv_tr_left npos inp hs htr + grind [Inv, erase_le, mem_of_le, Multiset.mem_map] + · have := inv_tr_right npos inp hs htr + grind [Inv, erase_le, mem_of_le] + +/-- `Inv` is true in all reachable state of `alg`. -/ +theorem reachable_inv (inp : Fin n → Bool) {s : State (Fin n) M S} + (hr : (alg npos).Reachable inp s) : Inv npos inp s := by + obtain ⟨xs, _⟩ := hr + have := LTS.mtrInv_of_trInv <| trInv_inv npos inp + grind [LTS.MTrInv, inv_start npos inp] + +/-- `alg` satisfies the `SafeConsensus` property. -/ +theorem safeConsensus : (alg npos).SafeConsensus := by + intro inp s hr + grind [reachable_inv npos inp hr, Inv, State.Agreed, State.Decided] + +/-- `Inv` is true at every state in an admissible run of `alg`. -/ +theorem always_inv (inp : Fin n → Bool) + {ss : ωSequence (State (Fin n) M S)} {xs : ωSequence (Action (Fin n) M)} + (ha : (alg npos).AdmissibleRun inp 0 ss xs) (k : ℕ) : Inv npos inp (ss k) := by + apply reachable_inv + apply Algorithm.reachable_stable <| Algorithm.reachable_start + use xs.extract 0 k + grind [AdmissibleRun.fault_zero, LTS.OmegaExecution.extract_mTr] + +/-- The message carrying the input value for process 0 is enabled in the initial state. -/ +theorem init_left (inp : Fin n → Bool) + {ss : ωSequence (State (Fin n) M S)} {xs : ωSequence (Action (Fin n) M)} + (ha : (alg npos).AdmissibleRun inp 0 ss xs) : + ss 0 ∈ {s | ⟨⟨0, npos⟩, inl (inp ⟨0, npos⟩)⟩ ∈ s.msgs} := by + obtain ⟨hi, _, _⟩ := AdmissibleRun.fault_zero.mp ha + simp [hi, Algorithm.start] + +/-- Whenever the message carrying the input value for process 0 is enabled in a state, +a message carrying that value is eventually sent to every process `p` by process 0. -/ +theorem left_leadsTo_right (inp : Fin n → Bool) + {ss : ωSequence (State (Fin n) M S)} {xs : ωSequence (Action (Fin n) M)} + (ha : (alg npos).AdmissibleRun inp 0 ss xs) (p : Fin n) : + ss.LeadsTo {s | ⟨⟨0, npos⟩, inl (inp ⟨0, npos⟩)⟩ ∈ s.msgs} + {s | ⟨p, inr (inp ⟨0, npos⟩)⟩ ∈ s.msgs} := by + let m : Message (Fin n) M := ⟨⟨0, npos⟩, inl (inp ⟨0, npos⟩)⟩ + intro k _ + have : m ∈ (ss k).msgs := by grind + obtain ⟨_, _, hf⟩ := AdmissibleRun.fault_zero.mp ha + obtain ⟨j, _, _⟩ : ∃ j, k ≤ j ∧ xs j = some m := by grind [hf ⟨0, npos⟩, ProcFair] + use j + 1 + have hj := always_inv npos inp ha j + have htr : (alg npos).lts.Tr (ss j) (some m) (ss (j + 1)) := by grind [LTS.OmegaExecution] + have h1 : k ≤ j + 1 := by grind + simp [h1, m, inv_tr_left npos inp hj htr rfl] + +/-- Whenever a message carrying a value sent by process 0 is enabled at a process `p`, +`p` eventually decides on that value. -/ +theorem right_leadsTo_out (inp : Fin n → Bool) + {ss : ωSequence (State (Fin n) M S)} {xs : ωSequence (Action (Fin n) M)} + (ha : (alg npos).AdmissibleRun inp 0 ss xs) (p : Fin n) : + ss.LeadsTo {s | ⟨p, inr (inp ⟨0, npos⟩)⟩ ∈ s.msgs} + {s | (s.proc p).out = some (inp ⟨0, npos⟩)} := by + let m : Message (Fin n) M := ⟨p, inr (inp ⟨0, npos⟩)⟩ + intro k _ + have : m ∈ (ss k).msgs := by grind + obtain ⟨_, _, hf⟩ := AdmissibleRun.fault_zero.mp ha + obtain ⟨j, _, _⟩ : ∃ j, k ≤ j ∧ xs j = some m := by grind [hf p, ProcFair] + use j + 1 + have hj := always_inv npos inp ha j + have htr : (alg npos).lts.Tr (ss j) (some m) (ss (j + 1)) := by grind [LTS.OmegaExecution] + grind [inv_tr_right npos inp hj htr] + +/-- `alg` is a correct asynchronous distributed consensus algorithm when there is no fault. -/ +theorem consensus_zero : (alg npos).Consensus 0 := by + use safeConsensus npos + intro inp ss xs ha p + right + have hlt1 := left_leadsTo_right npos inp ha p + have hlt2 := right_leadsTo_out npos inp ha p + have := leadsTo_trans hlt1 hlt2 0 <| init_left npos inp ha + grind + +end Cslib.FLP.ZeroFaultAlg diff --git a/Cslib/Foundations/Semantics/LTS/Basic.lean b/Cslib/Foundations/Semantics/LTS/Basic.lean index 508636adb9..d9e53a5906 100644 --- a/Cslib/Foundations/Semantics/LTS/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/Basic.lean @@ -170,6 +170,22 @@ theorem MTr.append_iff : lts.MTr s1 (μs ++ μs') s2 ↔ ∃ s, lts.MTr s1 μs s intro ⟨_, h, h'⟩ exact h.comp lts h' +/-- Single-step invariant. -/ +@[scoped grind =] +def TrInv (p : State → Prop) : Prop := + ∀ s1 μ s2, lts.Tr s1 μ s2 → p s1 → p s2 + +/-- Multistep invariant. -/ +@[scoped grind =] +def MTrInv (p : State → Prop) : Prop := + ∀ s1 μs s2, lts.MTr s1 μs s2 → p s1 → p s2 + +/-- Any single-step invariant is also a multistep invariant. -/ +theorem mtrInv_of_trInv {lts : LTS State Label} {p : State → Prop} + (htr : lts.TrInv p) : lts.MTrInv p := by + intro s1 μs s2 h + induction h <;> grind + /-- A state `s1` can reach a state `s2` if there exists a multistep transition from `s1` to `s2`. -/ @[scoped grind =] From 1dbda5335e3fc06c414b84ca885a35d4c6d4ab7c Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Fri, 19 Jun 2026 12:11:07 +0200 Subject: [PATCH 28/51] feat(Automata, LTS, TM): Introduce LTS.SMTr and LTS.mapLabel, generalise TM tapes to arbitrary universes, fix EpsilonNA, and introduce their single-accept transformation (#625) This PR: - Fixes a bug in the formulation of EpsilonNA by adopting a new saturated multistep transition LTS.SMTr for LTS, which correctly invokes tau-closure for empty strings. - Introduces a `mapLabel` operation for LTS and its properties. - Introduces a new transformation `toSingleAccept` for EpsilonNA.FinAcc, which transforms the automaton into an equivalent one that has a single accept state with no outgoing transitions. - Generalises TM tapes/symbols to arbitrary universes. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> Co-authored-by: Chris Henson --- Cslib.lean | 4 +- .../Automata/EpsilonNA/Basic.lean | 4 +- .../Automata/EpsilonNA/ToNA.lean | 53 ++-- .../Automata/EpsilonNA/ToSingleAccept.lean | 277 ++++++++++++++++++ .../SingleTape/Deterministic.lean} | 7 +- Cslib/Foundations/Data/BiTape.lean | 17 +- Cslib/Foundations/Data/StackTape.lean | 30 +- Cslib/Foundations/Semantics/LTS/Basic.lean | 1 + Cslib/Foundations/Semantics/LTS/HasTau.lean | 140 +++++++-- Cslib/Foundations/Semantics/LTS/MapLabel.lean | 41 +++ .../Foundations/Semantics/LTS/Simulation.lean | 6 +- CslibTests/GrindLint.lean | 3 + 12 files changed, 488 insertions(+), 95 deletions(-) create mode 100644 Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean rename Cslib/Computability/Machines/{SingleTapeTuring/Basic.lean => Turing/SingleTape/Deterministic.lean} (99%) create mode 100644 Cslib/Foundations/Semantics/LTS/MapLabel.lean diff --git a/Cslib.lean b/Cslib.lean index 6e69fa398c..901c6c5e10 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -11,6 +11,7 @@ public import Cslib.Computability.Automata.DA.Prod public import Cslib.Computability.Automata.DA.ToNA public import Cslib.Computability.Automata.EpsilonNA.Basic public import Cslib.Computability.Automata.EpsilonNA.ToNA +public import Cslib.Computability.Automata.EpsilonNA.ToSingleAccept public import Cslib.Computability.Automata.NA.Basic public import Cslib.Computability.Automata.NA.BuchiEquiv public import Cslib.Computability.Automata.NA.BuchiInter @@ -33,7 +34,7 @@ public import Cslib.Computability.Languages.MyhillNerode public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage -public import Cslib.Computability.Machines.SingleTapeTuring.Basic +public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable public import Cslib.Computability.URM.Defs @@ -87,6 +88,7 @@ public import Cslib.Foundations.Semantics.LTS.Divergence public import Cslib.Foundations.Semantics.LTS.Execution public import Cslib.Foundations.Semantics.LTS.HasTau public import Cslib.Foundations.Semantics.LTS.LTSCat.Basic +public import Cslib.Foundations.Semantics.LTS.MapLabel public import Cslib.Foundations.Semantics.LTS.Notation public import Cslib.Foundations.Semantics.LTS.OmegaExecution public import Cslib.Foundations.Semantics.LTS.Relation diff --git a/Cslib/Computability/Automata/EpsilonNA/Basic.lean b/Cslib/Computability/Automata/EpsilonNA/Basic.lean index e001d98c24..b68fdd86db 100644 --- a/Cslib/Computability/Automata/EpsilonNA/Basic.lean +++ b/Cslib/Computability/Automata/EpsilonNA/Basic.lean @@ -46,9 +46,7 @@ namespace FinAcc that trace from the start state. -/ @[scoped grind =] instance : Acceptor (FinAcc State Symbol) Symbol where - Accepts (a : FinAcc State Symbol) (xs : List Symbol) := - ∃ s ∈ a.εClosure a.start, ∃ s' ∈ a.accept, - a.saturate.MTr s (xs.map (some ·)) s' + Accepts a xs := ∃ s ∈ a.start, ∃ s' ∈ a.accept, a.SMTr s (xs.map some) s' end FinAcc diff --git a/Cslib/Computability/Automata/EpsilonNA/ToNA.lean b/Cslib/Computability/Automata/EpsilonNA/ToNA.lean index d0299dc920..184c99e963 100644 --- a/Cslib/Computability/Automata/EpsilonNA/ToNA.lean +++ b/Cslib/Computability/Automata/EpsilonNA/ToNA.lean @@ -7,32 +7,13 @@ Authors: Fabrizio Montesi module public import Cslib.Computability.Automata.EpsilonNA.Basic +public import Cslib.Foundations.Semantics.LTS.MapLabel /-! # Translation of εNA into NA -/ @[expose] public section -namespace Cslib - -/-- Converts an `LTS` with Option labels into an `LTS` on the carried label type, by removing all -ε-transitions. -/ -@[local grind =] -def LTS.noε (lts : LTS State (Option Label)) : LTS State Label where - Tr s μ s' := lts.Tr s (some μ) s' - -@[local grind .] -private lemma LTS.noε_saturate_tr - {lts : LTS State (Option Label)} {h : μ = some μ'} : - lts.saturate.Tr s μ s' ↔ lts.saturate.noε.Tr s μ' s' := by - grind - -@[scoped grind =] -lemma LTS.noε_saturate_mTr {lts : LTS State (Option Label)} : - lts.saturate.MTr s (μs.map some) = lts.saturate.noε.MTr s μs := by - ext s' - induction μs generalizing s <;> grind [<= LTS.MTr.stepL] - -namespace Automata.εNA.FinAcc +namespace Cslib.Automata.εNA.FinAcc variable {State Symbol : Type*} @@ -41,21 +22,23 @@ variable {State Symbol : Type*} def toNAFinAcc (a : εNA.FinAcc State Symbol) : NA.FinAcc State Symbol where start := a.εClosure a.start accept := a.accept - Tr := a.saturate.noε.Tr + toLTS := a.saturate.mapLabel Option.some open Acceptor in -open scoped NA.FinAcc in +open scoped NA.FinAcc LTS LTS.MTr LTS.STr LTS.SMTr in /-- Correctness of `toNAFinAcc`. -/ -@[scoped grind _=_] -theorem toNAFinAcc_language_eq {ena : εNA.FinAcc State Symbol} : - language ena.toNAFinAcc = language ena := by +@[scoped grind =] +theorem toNAFinAcc_language_eq {a : εNA.FinAcc State Symbol} : + language a.toNAFinAcc = language a := by ext xs - have : ∀ s s', ena.saturate.MTr s (xs.map some) s' = ena.saturate.noε.MTr s xs s' := by - simp [LTS.noε_saturate_mTr] - #adaptation_note - /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/ - grind [Accepts] - -end Automata.εNA.FinAcc - -end Cslib + constructor <;> intro ⟨s, hs, s', hs', h⟩ + · have ⟨sStart, h_sStart, hs⟩ : ∃ i ∈ a.start, s ∈ a.saturate.image i HasTau.τ := by + simpa [toNAFinAcc, LTS.τClosure, LTS.setImage] using hs + use sStart, h_sStart, s', hs' + have h_start := (LTS.sTr_τSTr_iff a.toLTS).mp hs + exact LTS.SMTr.comp (LTS.sMTr_τSTr_iff.mp h_start) (by grind) + · cases xs with + | nil => cases h with | τ tau => exact ⟨s', LTS.tr_setImage hs tau, by grind⟩ + | cons x xs => exact ⟨s, by grind [Set.mem_of_mem_of_subset]⟩ + +end Cslib.Automata.εNA.FinAcc diff --git a/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean b/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean new file mode 100644 index 0000000000..91df5a24f6 --- /dev/null +++ b/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean @@ -0,0 +1,277 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Computability.Automata.EpsilonNA.Basic + +/-! # Translation of εNA into εNA with a single accept state + +Defines the transformation `toSingleAccept` for `εNA.FinAcc` and proves correctness +results in terms of language equivalence and correspondences between the two transition systems. + +Note for future work: we could formulate a stronger transformation, whereby also the set of accept +states becomes a singleton. +-/ + +@[expose] public section + +namespace Cslib.Automata.εNA.FinAcc + +variable {State Symbol : Type*} + +/-- Any `εNA.FinAcc` can be converted into an `εNA.FinAcc` with a single accept state `none`. +The original states are wrapped in `some`, and all original accept states have ε-transitions to +`none`. -/ +@[local grind] +def toSingleAccept (a : εNA.FinAcc State Symbol) : εNA.FinAcc (Option State) Symbol where + start := some '' a.start + accept := {none} + Tr + | some s, x, some s' => a.Tr s x s' + | some s, none, none => s ∈ a.accept + | _, _, _ => False + +@[scoped grind =] +theorem toSingleAccept_accept_def {a : εNA.FinAcc State Symbol} : + a.toSingleAccept.accept = {none} := rfl + +open Acceptor in +@[scoped grind .] +theorem toSingleAccept_accepts_mTr_iff {a : εNA.FinAcc State Symbol} : + Accepts a.toSingleAccept xs ↔ + ∃ s ∈ a.toSingleAccept.start, a.toSingleAccept.SMTr s (xs.map Option.some) none := by + grind [Accepts] + +open scoped LTS LTS.MTr LTS.STr LTS.SMTr + +@[scoped grind →] +theorem toSingleAccept_tr_antiDerivative_isSome {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.Tr os x os') : os.isSome := by + cases os with grind + +theorem toSingleAccept_tr_tr {a : εNA.FinAcc State Symbol} : + a.toSingleAccept.Tr (some s) x (some s') ↔ a.Tr s x s' := by + simp [toSingleAccept] + +scoped grind_pattern toSingleAccept_tr_tr => a.toSingleAccept.Tr (some s) x (some s') + +@[scoped grind →] +theorem toSingleAccept_tr_none_accept {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.Tr os x none) : ∃ s, os = some s ∧ s ∈ a.accept := by + grind + +@[scoped grind ⇒] +theorem toSingleAccept_not_tr_none {a : εNA.FinAcc State Symbol} : + ¬a.toSingleAccept.Tr none x os := by + grind + +@[scoped grind →] +theorem toSingleAccept_mTr_antiDerivative_isSome {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.MTr os x (some s')) : os.isSome := by + generalize hos' : some s' = os' at h + induction h <;> grind + +@[scoped grind =] +theorem toSingleAccept_mTr_mTr {a : εNA.FinAcc State Symbol} : + a.toSingleAccept.MTr (some s) xs (some s') ↔ a.MTr s xs s' := by + induction xs generalizing s + case nil => grind + case cons x xs ih => + apply Iff.intro <;> intro h + case mp => + cases h with + | stepL => grind + case mpr => + cases h + case stepL sb htr hmtr => + apply LTS.MTr.stepL (s2 := some sb) <;> grind + +@[scoped grind →] +theorem toSingleAccept_τSTr_antiDerivative_none {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.τSTr none os) : os = none := by + generalize hnone : none = os' at h + induction h using Relation.ReflTransGen.head_induction_on + case refl => rfl + case head _ _ h₁ h₂ ih => grind [toSingleAccept_tr_antiDerivative_isSome h₁] + +@[scoped grind →] +theorem toSingleAccept_τSTr_antiDerivative_isSome {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.τSTr os (some s')) : os.isSome := by + induction h using Relation.ReflTransGen.head_induction_on + case refl => exact Option.isSome_some + case head _ _ h₁ h₂ ih => exact toSingleAccept_tr_antiDerivative_isSome h₁ + +@[scoped grind =] +theorem toSingleAccept_τSTr_τSTr {a : εNA.FinAcc State Symbol} + : a.toSingleAccept.τSTr (some s) (some s') ↔ a.τSTr s s' := by + apply Iff.intro + · generalize hos' : some s' = os' + intro h + induction h generalizing s' with + | refl => + cases hos' + exact LTS.τSTr.refl + | tail hτstr htr ih => + subst hos' + obtain ⟨_, rfl⟩ := Option.isSome_iff_exists.mp <| toSingleAccept_tr_antiDerivative_isSome htr + refine .trans (ih rfl) (.single htr) + · intro h + cases h with + | refl => exact LTS.τSTr.refl + | tail hτstr htr => exact .trans (.lift some (fun _ _ => id) hτstr) (.single htr) + +@[scoped grind →] +theorem toSingleAccept_τSTr_none_accept {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.τSTr (some s) none) : ∃ s' ∈ a.accept, a.τSTr s s' := by + generalize hos' : none = os' at h + induction h + case refl => simp at hos' + case tail osb os' h₁ h₂ ih => + subst hos' + have ⟨sb, hosb, hsb⟩ := toSingleAccept_tr_none_accept h₂ + subst hosb + exact ⟨sb, hsb, toSingleAccept_τSTr_τSTr.mp h₁⟩ + +@[scoped grind →] +theorem toSingleAccept_sTr_antiDerivative_isSome {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.STr os x (some s')) : os.isSome := by + generalize hos' : some s' = os' + cases h <;> grind + +@[scoped grind =] +theorem toSingleAccept_sTr_sTr {a : εNA.FinAcc State Symbol} + : a.toSingleAccept.STr (some s) x (some s') ↔ a.STr s x s' := by + generalize hos' : some s' = os' + apply Iff.intro <;> intro h + case mp => + induction h + case refl => grind only [Option.some_inj, LTS.STr.refl] + case tr osb₁ x osb₂ os' h₁ h₂ h₃ => + have ⟨sb₂, hosb₂⟩ : ∃ sb₂, osb₂ = some sb₂ := by grind + have ⟨sb₁, hosb₁⟩ : ∃ sb₁, osb₁ = some sb₁ := by grind + grind [LTS.STr.tr (s2 := sb₁) (s3 := sb₂)] + case mpr => + induction h + case refl => grind only [LTS.STr.refl] + case tr sb₁ x sb₂ s' h₁ h₂ h₃ => + apply LTS.STr.tr (s2 := some sb₁) (s3 := some sb₂) + (toSingleAccept_τSTr_τSTr.mpr h₁) + (toSingleAccept_tr_tr.mpr h₂) + (hos' ▸ toSingleAccept_τSTr_τSTr.mpr h₃) + +@[scoped grind →] +theorem toSingleAccept_sTr_none_accept {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.STr (some s) x none) : ∃ s' ∈ a.accept, a.STr s x s' := by + cases h + case tr osb₁ osb₂ h₁ h₂ h₃ => + have ⟨sb₁, hosb₁⟩ : ∃ sb₁, osb₁ = some sb₁ := by grind + rw [hosb₁] at h₂ + cases hosb₂ : osb₂ + case none => + rw [hosb₂] at h₂ + have h₂' := toSingleAccept_tr_none_accept h₂ + rcases h₂' with ⟨s', hs', hs'a⟩ + exists s'; apply And.intro hs'a + rw [hs'] at h₂ + have hx : x = none := by grind + rw [hx] + rw [hosb₁, hs'] at h₁ + cases h₁ + case refl => + apply LTS.STr.refl + case tail osb htrb htr => + have ⟨sb, hosb⟩ : ∃ sb, osb = some sb := by + grind only [toSingleAccept_tr_antiDerivative_isSome htr, Option.isSome_iff_exists] + rw [hosb] at htr + apply toSingleAccept_tr_tr.mp at htr + rw [hosb] at htrb + apply toSingleAccept_τSTr_τSTr.mp at htrb + apply LTS.STr.tr htrb htr LTS.τSTr.refl + case some sb₂ => + rw [hosb₁] at h₁ + rw [hosb₂] at h₂ h₃ + have ⟨s', hs', hsb₂⟩ := toSingleAccept_τSTr_none_accept h₃ + exists s'; apply And.intro hs' + apply LTS.STr.tr + (toSingleAccept_τSTr_τSTr.mp h₁) + (toSingleAccept_tr_tr.mp h₂) + hsb₂ + +@[scoped grind →] +theorem toSingleAccept_sTr_none_none {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.STr none x os) : x = none ∧ os = none := by + cases h + case refl => trivial + case tr osb₁ osb₂ h₁ h₂ h₃ => + have : osb₁ = none := toSingleAccept_τSTr_antiDerivative_none h₁ + grind + +@[scoped grind →] +theorem toSingleAccept_sMTr_antiDerivative_isSome {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.SMTr os xs (some s')) : os.isSome := by + generalize hos' : some s' = os' at h + induction h <;> grind [= Option.isSome_iff_exists] + +@[scoped grind =] +theorem toSingleAccept_sMTr_sMTr {a : εNA.FinAcc State Symbol} + : a.toSingleAccept.SMTr (some s) x (some s') ↔ a.SMTr s x s' := by + generalize hos : some s = os, hos' : some s' = os' + apply Iff.intro <;> intro h + case mp => + induction h generalizing s + case τ => grind [LTS.SMTr.τ] + case stepL os x osb xs os' h₁ h₂ ih => + have ⟨sb, hosb⟩ : ∃ sb, osb = some sb := by grind [Option.isSome_iff_exists] + grind [LTS.SMTr.stepL (s2 := sb)] + case mpr => + induction h generalizing os + case τ => grind [LTS.SMTr.τ] + case stepL s x sb xs s' h₁ h₂ ih => grind [LTS.SMTr.stepL (s2 := some sb)] + +@[scoped grind →] +theorem toSingleAccept_sMTr_none_accept {a : εNA.FinAcc State Symbol} + (h : a.toSingleAccept.SMTr (some s) (List.map some xs) none) : + ∃ s' ∈ a.accept, a.SMTr s (List.map some xs) s' := by + induction xs generalizing s + case nil => + rcases h with ⟨h⟩ + have ⟨s', hs', h'⟩ := toSingleAccept_sTr_none_accept h + exact ⟨s', hs', LTS.SMTr.τ h'⟩ + case cons x xs ih => + cases h + case stepL osb hstr hsmtr => + cases hosb : osb + case none => + subst hosb + have ⟨s', hs', hstr'⟩ := toSingleAccept_sTr_none_accept hstr + refine ⟨s', hs', LTS.SMTr.stepL hstr' ?_⟩ + have hxs : xs = [] := by cases xs with grind [cases LTS.SMTr] + grind + case some sb => + subst hosb + have ⟨s', hs', ih'⟩ := ih hsmtr + exact ⟨s', hs', LTS.SMTr.stepL (toSingleAccept_sTr_sTr.mp hstr) ih'⟩ + +open Acceptor in +/-- `toSingleAccept` preserves the language of the input automaton. -/ +@[scoped grind =] +theorem toSingleAccept_language_eq {a : εNA.FinAcc State Symbol} : + language a.toSingleAccept = language a := by + ext xs + apply Iff.intro <;> intro h + case mp => + rcases h with ⟨os, hos, os', hos', hsmtr⟩ + rcases hos with ⟨s, hs₁, hs₂⟩ + exists s + grind + case mpr => + rcases h with ⟨s, hs, s', hs', hsmtr⟩ + refine ⟨s, by grind, none, by grind, ?_⟩ + rw [show xs.map some = xs.map some ++ [] by simp] + exact LTS.SMTr.comp (toSingleAccept_sMTr_sMTr.mpr hsmtr) <| LTS.SMTr.τ (LTS.STr.single hs') + +end Cslib.Automata.εNA.FinAcc diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/Turing/SingleTape/Deterministic.lean similarity index 99% rename from Cslib/Computability/Machines/SingleTapeTuring/Basic.lean rename to Cslib/Computability/Machines/Turing/SingleTape/Deterministic.lean index debad7d43f..79c4ae530a 100644 --- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/Turing/SingleTape/Deterministic.lean @@ -62,11 +62,12 @@ We also provide ways of constructing polynomial-runtime TMs @[expose] public section -open Cslib Relation +open Relation -namespace Turing +namespace Cslib.Turing open BiTape StackTape +open _root_.Turing variable {Symbol : Type} @@ -503,4 +504,4 @@ end PolyTimeComputable end SingleTapeTM -end Turing +end Cslib.Turing diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean index e61272d57d..8c57a4c114 100644 --- a/Cslib/Foundations/Data/BiTape.lean +++ b/Cslib/Foundations/Data/BiTape.lean @@ -38,13 +38,13 @@ will not collide. @[expose] public section -namespace Turing +namespace Cslib.Turing /-- A structure for bidirectionally-infinite Turing machine tapes that eventually take on blank `none` values -/ -structure BiTape (Symbol : Type) where +structure BiTape (Symbol : Type*) where /-- The symbol currently under the tape head -/ head : Option Symbol /-- The contents to the left of the head -/ @@ -54,7 +54,7 @@ structure BiTape (Symbol : Type) where namespace BiTape -variable {Symbol : Type} +variable {Symbol : Type*} /-- The empty `BiTape` -/ def nil : BiTape Symbol := ⟨none, ∅, ∅⟩ @@ -92,6 +92,8 @@ Move the head right by shifting the right StackTape under the head. def moveRight (t : BiTape Symbol) : BiTape Symbol := ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩ +open _root_.Turing + /-- Move the head to the left or right, shifting the tape underneath it. -/ @@ -102,7 +104,7 @@ def move (t : BiTape Symbol) : Dir → BiTape Symbol /-- Optionally perform a `move`, or do nothing if `none`. -/ -def optionMove : BiTape Symbol → Option Dir → BiTape Symbol +def optionMove : BiTape Symbol → Option Turing.Dir → BiTape Symbol | t, none => t | t, some d => t.move d @@ -125,10 +127,9 @@ def write (t : BiTape Symbol) (a : Option Symbol) : BiTape Symbol := { t with he The space used by a `BiTape` is the number of symbols between and including the head, and leftmost and rightmost non-blank symbols on the `BiTape`. -/ -@[scoped grind] def spaceUsed (t : BiTape Symbol) : ℕ := 1 + t.left.length + t.right.length -@[simp, grind =] +@[simp] lemma spaceUsed_write (t : BiTape Symbol) (a : Option Symbol) : (t.write a).spaceUsed = t.spaceUsed := by rfl @@ -138,11 +139,11 @@ lemma spaceUsed_mk₁ (l : List Symbol) : | nil => simp [mk₁, spaceUsed, nil, StackTape.length_nil] | cons h t => simp [mk₁, spaceUsed, StackTape.length_nil, StackTape.length_mapSome]; omega -lemma spaceUsed_move (t : BiTape Symbol) (d : Dir) : +lemma spaceUsed_move (t : BiTape Symbol) (d : Turing.Dir) : (t.move d).spaceUsed ≤ t.spaceUsed + 1 := by cases d <;> grind [moveLeft, moveRight, move, spaceUsed, StackTape.length_tail_le, StackTape.length_cons_le] end BiTape -end Turing +end Cslib.Turing diff --git a/Cslib/Foundations/Data/StackTape.lean b/Cslib/Foundations/Data/StackTape.lean index a252582b02..2cd556ecf7 100644 --- a/Cslib/Foundations/Data/StackTape.lean +++ b/Cslib/Foundations/Data/StackTape.lean @@ -38,7 +38,7 @@ advantages and disadvantages. @[expose] public section -namespace Turing +namespace Cslib.Turing /-- An infinite tape representation using a list of `Option` values, @@ -46,7 +46,7 @@ where the list is eventually `none`. Represented as a `List (Option Symbol)` that does not end with `none`. -/ -structure StackTape (Symbol : Type) where +structure StackTape (Symbol : Type*) where /-- The underlying list representation -/ toList : List (Option Symbol) /-- @@ -59,10 +59,9 @@ attribute [scoped grind! .] StackTape.toList_getLast?_ne_some_none namespace StackTape -variable {Symbol : Type} +variable {Symbol : Type*} /-- The empty `StackTape` -/ -@[scoped grind] def nil : StackTape Symbol := ⟨[], by grind⟩ instance : Inhabited (StackTape Symbol) where @@ -78,7 +77,6 @@ lemma empty_eq_nil : (∅ : StackTape Symbol) = nil := rfl lemma nil_toList : (nil : StackTape Symbol).toList = [] := rfl /-- Prepend an `Option` to the `StackTape` -/ -@[scoped grind] def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol := match x, xs with | none, ⟨[], _⟩ => ⟨[], by grind⟩ @@ -86,9 +84,10 @@ def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol := | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩ @[simp, scoped grind =] -lemma cons_none_nil_toList : (cons none (nil : StackTape Symbol)).toList = [] := by grind +lemma cons_none_nil_toList : (cons none (nil : StackTape Symbol)).toList = [] := by + grind only [nil, cons] -@[simp, scoped grind =] +@[simp] lemma cons_some_toList (a : Symbol) (l : StackTape Symbol) : (cons (some a) l).toList = some a :: l.toList := by simp only [cons] @@ -113,22 +112,22 @@ lemma eq_iff (l1 l2 : StackTape Symbol) : · intro ⟨hhead, htail⟩ cases l1 with | mk as1 h1 => cases l2 with | mk as2 h2 => - cases as1 <;> cases as2 <;> grind + cases as1 <;> cases as2 <;> grind [nil] @[simp] lemma head_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).head = o := by cases o with | none => cases l with | mk toList hl => - cases toList <;> grind - | some a => grind + cases toList <;> grind [cons] + | some a => grind [cons_some_toList] @[simp] lemma tail_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).tail = l := by cases o with | none => cases l with | mk toList h => - cases toList <;> grind + cases toList <;> grind [nil, cons] | some a => simp only [cons, tail] @@ -157,16 +156,15 @@ grind_pattern length_tail_le => l.tail.length lemma length_cons_none (l : StackTape Symbol) : (cons none l).length = l.length + if l.length = 0 then 0 else 1 := by cases l with | mk toList h => - cases toList <;> grind + cases toList <;> grind [cons] -@[scoped grind =] lemma length_cons_some (a : Symbol) (l : StackTape Symbol) : (cons (some a) l).length = l.length + 1 := by - grind + grind [cons_some_toList] lemma length_cons_le (o : Option Symbol) (l : StackTape Symbol) : (cons o l).length ≤ l.length + 1 := by - cases o <;> grind + cases o <;> grind [cons_some_toList] @[simp, scoped grind =] lemma length_mapSome (l : List Symbol) : (mapSome l).length = l.length := by grind @@ -178,4 +176,4 @@ end Length end StackTape -end Turing +end Cslib.Turing diff --git a/Cslib/Foundations/Semantics/LTS/Basic.lean b/Cslib/Foundations/Semantics/LTS/Basic.lean index d9e53a5906..b1f864f89d 100644 --- a/Cslib/Foundations/Semantics/LTS/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/Basic.lean @@ -56,6 +56,7 @@ universe u v A Labelled Transition System (LTS) for a type of states (`State`) and a type of transition labels (`Label`) consists of a labelled transition relation (`Tr`). -/ +@[ext] structure LTS (State : Type u) (Label : Type v) where /-- The transition relation. -/ Tr : State → Label → State → Prop diff --git a/Cslib/Foundations/Semantics/LTS/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 2b886a2957..26140c9b8b 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -29,10 +29,14 @@ namespace LTS def τSTr [HasTau Label] (lts : LTS State Label) : State → State → Prop := Relation.ReflTransGen (Tr.toRelation lts HasTau.τ) +@[scoped grind .] +theorem τSTr.refl [HasTau Label] {lts : LTS State Label} : lts.τSTr s s := + Relation.ReflTransGen.refl + /-- Saturated transition relation. -/ inductive STr [HasTau Label] (lts : LTS State Label) : State → Label → State → Prop where -| refl : lts.STr s HasTau.τ s -| tr : lts.τSTr s1 s2 → lts.Tr s2 μ s3 → lts.τSTr s3 s4 → lts.STr s1 μ s4 + | refl : lts.STr s HasTau.τ s + | tr : lts.τSTr s1 s2 → lts.Tr s2 μ s3 → lts.τSTr s3 s4 → lts.STr s1 μ s4 /-- The `LTS` obtained by saturating the transition relation in `lts`. -/ @[scoped grind =] @@ -44,17 +48,17 @@ theorem saturate_tr_sTr [HasTau Label] {lts : LTS State Label} : lts.saturate.Tr = lts.STr := by rfl /-- Any transition is also a saturated transition. -/ -theorem STr.single [HasTau Label] (lts : LTS State Label) : +theorem STr.single [HasTau Label] {lts : LTS State Label} : lts.Tr s μ s' → lts.STr s μ s' := by intro h apply STr.tr .refl h .refl lemma tr_le_tr_saturate [HasTau Label] (lts : LTS State Label) : lts.Tr ≤ lts.saturate.Tr := - fun _ _ _ => STr.single lts + fun _ _ _ => STr.single /-- STr transitions labeled by HasTau.τ are exactly the τSTr transitions. -/ -theorem sTr_τSTr [HasTau Label] (lts : LTS State Label) : - lts.STr s HasTau.τ s' ↔ lts.τSTr s s' := by +theorem sTr_τSTr_iff [HasTau Label] (lts : LTS State Label) : + lts.STr s HasTau.τ s' ↔ lts.τSTr s s' := by apply Iff.intro <;> intro h case mp => cases h @@ -67,14 +71,14 @@ theorem sTr_τSTr [HasTau Label] (lts : LTS State Label) : case tail _ h1 h2 => exact STr.tr h1 h2 .refl /-- In a saturated LTS, the transition and saturated transition relations are the same. -/ -theorem saturate_τSTr_τSTr [hHasTau : HasTau Label] (lts : LTS State Label) - : lts.saturate.τSTr s = lts.τSTr s := by - ext s'' +theorem saturate_τsTr_τSTr_iff [hHasTau : HasTau Label] (lts : LTS State Label) : + lts.saturate.τSTr = lts.τSTr := by + ext s s' apply Iff.intro <;> intro h case mp => induction h case refl => constructor - case tail _ _ _ h2 h3 => exact Relation.ReflTransGen.trans h3 ((sTr_τSTr _).mp h2) + case tail _ _ _ h2 h3 => exact Relation.ReflTransGen.trans h3 ((sTr_τSTr_iff _).mp h2) case mpr => cases h case refl => constructor @@ -85,31 +89,31 @@ theorem saturate_τSTr_τSTr [hHasTau : HasTau Label] (lts : LTS State Label) /-- Saturated transitions labelled by τ can be composed. -/ @[scoped grind .] theorem STr.trans_τ - [HasTau Label] (lts : LTS State Label) - (h1 : lts.STr s1 HasTau.τ s2) (h2 : lts.STr s2 HasTau.τ s3) : - lts.STr s1 HasTau.τ s3 := by - rw [sTr_τSTr _] at h1 h2 - rw [sTr_τSTr _] + [HasTau Label] {lts : LTS State Label} + (h1 : lts.STr s1 HasTau.τ s2) (h2 : lts.STr s2 HasTau.τ s3) : + lts.STr s1 HasTau.τ s3 := by + rw [sTr_τSTr_iff _] at h1 h2 + rw [sTr_τSTr_iff _] apply Relation.ReflTransGen.trans h1 h2 /-- Saturated transitions can be composed. -/ theorem STr.comp - [HasTau Label] (lts : LTS State Label) - (h1 : lts.STr s1 HasTau.τ s2) - (h2 : lts.STr s2 μ s3) - (h3 : lts.STr s3 HasTau.τ s4) : + [HasTau Label] {lts : LTS State Label} + (h1 : lts.STr s1 HasTau.τ s2) + (h2 : lts.STr s2 μ s3) + (h3 : lts.STr s3 HasTau.τ s4) : lts.STr s1 μ s4 := by - rw [sTr_τSTr _] at h1 h3 + rw [sTr_τSTr_iff _] at h1 h3 cases h2 case refl => - rw [sTr_τSTr _] + rw [sTr_τSTr_iff _] apply Relation.ReflTransGen.trans h1 h3 case tr _ _ hτ1 htr hτ2 => exact STr.tr (Relation.ReflTransGen.trans h1 hτ1) htr (Relation.ReflTransGen.trans hτ2 h3) /-- In a saturated LTS, the transition and saturated transition relations are the same. -/ theorem saturate_tr_saturate_sTr [hHasTau : HasTau Label] (lts : LTS State Label) - (hμ : μ = hHasTau.τ) : lts.saturate.Tr s μ = lts.saturate.STr s μ := by + (hμ : μ = hHasTau.τ) : lts.saturate.Tr s μ = lts.saturate.STr s μ := by ext s' apply Iff.intro <;> intro h case mp => @@ -122,20 +126,104 @@ theorem saturate_tr_saturate_sTr [hHasTau : HasTau Label] (lts : LTS State Label cases h case refl => constructor case tr hstr1 htr hstr2 => - rw [saturate_τSTr_τSTr lts] at hstr1 hstr2 - rw [←sTr_τSTr lts] at hstr1 hstr2 - exact STr.comp lts hstr1 htr hstr2 + rw [saturate_τsTr_τSTr_iff lts] at hstr1 hstr2 + rw [←sTr_τSTr_iff lts] at hstr1 hstr2 + exact STr.comp hstr1 htr hstr2 /-- In a saturated LTS, every state is in its τ-image. -/ @[scoped grind .] -theorem mem_saturate_image_τ [HasTau Label] (lts : LTS State Label) : +lemma mem_saturate_image_τ [HasTau Label] (lts : LTS State Label) : s ∈ lts.saturate.image s HasTau.τ := STr.refl +/-- Monotonicity of `setImage` on `HasTau.τ`. -/ +@[scoped grind .] +lemma subset_saturate_setImage_τ [HasTau Label] (lts : LTS State Label) : + S ⊆ lts.saturate.setImage S HasTau.τ := by + grind [setImage, Set.mem_iUnion] + +/-- `setImage` preserves (non-)emptyness. -/ +@[scoped grind =] +lemma empty_saturate_setImage_τ [HasTau Label] (lts : LTS State Label) : + lts.saturate.setImage S HasTau.τ = ∅ ↔ S = ∅:= by grind [Set.mem_of_mem_of_subset] + /-- The `τ`-closure of a set of states `S` is the set of states reachable by any state in `S` by performing only `τ`-transitions. -/ def τClosure [HasTau Label] (lts : LTS State Label) (S : Set State) : Set State := lts.saturate.setImage S HasTau.τ +/-- Monotonicity of `setImage` on `HasTau.τ`. -/ +@[scoped grind .] +lemma τClosure_subset [HasTau Label] (lts : LTS State Label) : + S ⊆ lts.τClosure S := by grind [Set.mem_of_mem_of_subset, = τClosure] + +/-- Saturated multistep transition relation. -/ +inductive SMTr [HasTau Label] (lts : LTS State Label) : State → List Label → State → Prop where + | τ : lts.STr s HasTau.τ s' → lts.SMTr s [] s' + | stepL : lts.STr s1 μ s2 → lts.SMTr s2 μs s3 → lts.SMTr s1 (μ :: μs) s3 + +/-- The saturated multistep transition relation is reflexive. -/ +@[scoped grind .] +theorem SMTr.refl [HasTau Label] (lts : LTS State Label) (s : State) : + lts.SMTr s [] s := by grind [LTS.STr, LTS.SMTr] + +open scoped LTS.STr + +/-- The saturated multistep transition relation is transitive. -/ +@[scoped grind .] +theorem SMTr.comp [HasTau Label] {lts : LTS State Label} + (h₁ : lts.SMTr s₁ μs₁ s₂) (h₂ : lts.SMTr s₂ μs₂ s₃) : lts.SMTr s₁ (μs₁ ++ μs₂) s₃ := by + induction h₁ + case τ s₁ s₂ htr => + cases h₂ + case τ htr' => grind [SMTr] + case stepL _ _ _ μ s₂' μs hstr hmstr => exact stepL (htr.comp hstr STr.refl) hmstr + case stepL s₁ μ s₁' μs s₂ hstr hmstr ih => + apply stepL hstr (ih h₂) + +/-- A multistep transition implies a saturated multistep transition. -/ +@[scoped grind .] +theorem SMTr.fromMTr [HasTau Label] {lts : LTS State Label} + (h : lts.MTr s μs s') : lts.SMTr s μs s' := by + induction μs generalizing s s' + case nil => grind [LTS.STr, LTS.SMTr] + case cons x xs ih => + cases h + case stepL sb htr hmtr => exact SMTr.stepL (STr.single htr) (ih hmtr) + +@[scoped grind =] +theorem sMTr_τSTr_iff [HasTau Label] {lts : LTS State Label} : + lts.τSTr s s' ↔ lts.SMTr s [] s' := by grind only [=_ sTr_τSTr_iff, SMTr] + +/-- A saturated multistep transition with a nonempty label list implies a multistep transition. -/ +@[scoped grind =] +theorem saturate_mTr_sMTr_not_nil_iff [HasTau Label] {lts : LTS State Label} + (hμs : μs ≠ []) : lts.saturate.MTr s μs s' ↔ lts.SMTr s μs s' := by + induction μs generalizing s + case nil => contradiction + case cons x xs ih => + apply Iff.intro <;> intro h + case mp => + cases h + case stepL sb htr hmtr => + cases xs with + | nil => + cases hmtr + apply LTS.SMTr.stepL htr (by grind only [SMTr.fromMTr, MTr.refl]) + | cons x' xs' => + exact LTS.SMTr.stepL htr ((ih (by simp)).mp hmtr) + case mpr => + cases h + case stepL sb htr hmtr => + cases xs with + | nil => + cases hmtr + case τ h_τ => + exact LTS.MTr.stepL + (LTS.STr.comp LTS.STr.refl htr h_τ) + LTS.MTr.refl + | cons x' xs' => + exact LTS.MTr.stepL htr ((ih (by simp)).mpr hmtr) + end LTS end Cslib diff --git a/Cslib/Foundations/Semantics/LTS/MapLabel.lean b/Cslib/Foundations/Semantics/LTS/MapLabel.lean new file mode 100644 index 0000000000..aa13af30ba --- /dev/null +++ b/Cslib/Foundations/Semantics/LTS/MapLabel.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Foundations.Semantics.LTS.Basic + + +/-! +# Label map operation for LTS. +-/ + +@[expose] public section + +namespace Cslib.LTS + +section MapLabel + +/-- Constructs an LTS by mapping its labels into those of an existing LTS. -/ +def mapLabel (lts : LTS State Label₁) (f : Label₂ → Label₁) : LTS State Label₂ where + Tr s μ s' := lts.Tr s (f μ) s' + +@[simp] +theorem mapLabel_tr {lts : LTS State Label₁} : + (lts.mapLabel f).Tr s μ s' ↔ lts.Tr s (f μ) s' := by rfl + +scoped grind_pattern mapLabel_tr => (lts.mapLabel f).Tr s μ s' + +@[simp, scoped grind =] +theorem mapLabel_mTr {lts : LTS State Label₁} {f : Label₂ → Label₁} : + (lts.mapLabel f).MTr s μs s' ↔ lts.MTr s (μs.map f) s' := by + induction μs generalizing s with + | nil => grind + | cons μ μs ih => grind [=_ mapLabel_tr (f := f)] + +end MapLabel + +end Cslib.LTS diff --git a/Cslib/Foundations/Semantics/LTS/Simulation.lean b/Cslib/Foundations/Semantics/LTS/Simulation.lean index aca8ca9fb9..8aeb119d64 100644 --- a/Cslib/Foundations/Semantics/LTS/Simulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Simulation.lean @@ -179,7 +179,7 @@ lemma IsSimulation.follow_internal [HasTau Label] {lts₁ : LTS State₁ Label} case tail sb hrsb htrsb ih1 ih2 => obtain ⟨sb2, htrsb2, hrb⟩ := ih2 have ⟨sb2', htrsb2', hrb'⟩ := h _ _ hrb HasTau.τ _ ih1 - use sb2', htrsb2.trans (lts₂.sTr_τSTr.mp htrsb2') + use sb2', htrsb2.trans (lts₂.sTr_τSTr_iff.mp htrsb2') /-- If the right-hand lts is saturated, a simulation lifts along saturating the left-hand lts. -/ theorem IsSimulation.isSimulation_saturate_left [HasTau Label] {lts₁ : LTS State₁ Label} @@ -193,8 +193,8 @@ theorem IsSimulation.isSimulation_saturate_left [HasTau Label] {lts₁ : LTS Sta obtain ⟨sb1, hstr1b, hrb⟩ := IsSimulation.follow_internal h hr hstr1 obtain ⟨sb2', hstr1b', hrb'⟩ := h _ _ hrb μ _ htr obtain ⟨s₁', hstr1', hrb2⟩ := IsSimulation.follow_internal h hrb' hstr2 - rw [←sTr_τSTr] at hstr1' hstr1b - use s₁', STr.comp lts₂ hstr1b hstr1b' hstr1', hrb2 + rw [←sTr_τSTr_iff] at hstr1' hstr1b + use s₁', STr.comp hstr1b hstr1b' hstr1', hrb2 /-- Simulation is preserved by removing transitions on the left, and adding transitions on the right. -/ diff --git a/CslibTests/GrindLint.lean b/CslibTests/GrindLint.lean index d04527c102..deba30056d 100644 --- a/CslibTests/GrindLint.lean +++ b/CslibTests/GrindLint.lean @@ -41,12 +41,15 @@ open_scoped_all Cslib #grind_lint skip Cslib.ωSequence.get_cons_append_zero #grind_lint skip Cslib.ωSequence.map_id #grind_lint skip Cslib.Automata.DA.buchi_eq_finAcc_omegaLim +#grind_lint skip Cslib.LTS.mapLabel_tr #grind_lint skip Cslib.LTS.MTr.stepL #grind_lint skip Cslib.LTS.STr.trans_τ #grind_lint skip Cslib.Automata.DA.FinAcc.toNAFinAcc_language_eq #grind_lint skip Cslib.Automata.NA.Buchi.reindex_language_eq #grind_lint skip Cslib.Automata.NA.FinAcc.toDAFinAcc_language_eq #grind_lint skip Cslib.Automata.εNA.FinAcc.toNAFinAcc_language_eq +#grind_lint skip Cslib.Automata.εNA.FinAcc.toSingleAccept_tr_tr +#grind_lint skip Cslib.Automata.εNA.FinAcc.toSingleAccept_not_tr_none #grind_lint skip Cslib.LambdaCalculus.LocallyNameless.Fsub.Sub.arrow #grind_lint skip Cslib.LambdaCalculus.LocallyNameless.Fsub.Sub.sum #grind_lint skip Cslib.LambdaCalculus.LocallyNameless.Fsub.Sub.trans_tvar From e0573fbc08dbad14cd492736d5fe83fde0d83cf2 Mon Sep 17 00:00:00 2001 From: Garmelon Date: Fri, 19 Jun 2026 17:40:52 +0200 Subject: [PATCH 29/51] chore: bump toolchain to v4.32.0-rc1 (#664) Co-authored-by: mathlib4-bot Co-authored-by: mathlib-nightly-testing[bot] <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: leanprover-community-mathlib4-bot <129911861+leanprover-community-mathlib4-bot@users.noreply.github.com> Co-authored-by: Kim Morrison Co-authored-by: leanprover-community-mathlib4-bot Co-authored-by: Chris Henson Co-authored-by: Ching-Tsun Chou Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> Co-authored-by: Kim Morrison <477956+kim-em@users.noreply.github.com> Co-authored-by: Alexandre Rademaker Co-authored-by: Fabrizio Montesi --- .../Semantics/LTS/LTSCat/Basic.lean | 1 + lake-manifest.json | 20 +++++++++---------- lakefile.toml | 2 +- lean-toolchain | 2 +- 4 files changed, 13 insertions(+), 12 deletions(-) diff --git a/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean index 9c40c3dcd5..bde0780155 100644 --- a/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean @@ -35,6 +35,7 @@ def LTS.withIdle (lts : LTS State Label) : LTS State (Option Label) := /-! ## LTSs and LTS morphisms form a category -/ +set_option linter.checkUnivs false in /-- The definition of labelled transition system (with the type of states and the type of labels as part of the structure). diff --git a/lake-manifest.json b/lake-manifest.json index 03ce69cd2f..952b7355e2 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f", + "rev": "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f", + "inputRev": "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "63045536fe95024e6c18fc7b48e03f506701c5bc", + "rev": "f3f26cc72646205ca167117487c008ee1dafe816", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "5c7542ed018c78194f1e2b903eaf6a792b74c03d", + "rev": "41f407a8e85b0fdc00910633a8f14754139b63f4", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "24b0d9dc081c5423f8eec7e866c441e5184f29d9", + "rev": "e6518a674e62de322b8f79eebeda7bcae2a36bc3", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "e3cb2f741431ce31bf73549fb52316a57368b06f", + "rev": "b5b9e2bb45ce91e4bc44eaa738c3a8910404ab82", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "f46324995fca5f0483b742e4eb4daec7f4ee50d2", + "rev": "7a62bd13860cd39ac98da16ffc8c24d601353f69", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "fa08db58b30eb033edcdab331bba000827f9f785", + "rev": "954dbc9873f3b4534dc9896604593406d0383520", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "92564e5770e4d09f2d86dfbf8ada1e9c715b384c", + "rev": "406ebb8c8e2f7e852a1b47764b42494022ce652c", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0", + "inputRev": "v4.32.0-rc1", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 7149fcc85e..2fe3f18239 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "fabf563a7c95a166b8d7b6efca11c8b4dc9d911f" +rev = "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index 18640c8b06..2694eb767c 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.31.0 +leanprover/lean4:v4.32.0-rc1 From dc23a39f58d6a8b84ef2e45975fd9c396af41082 Mon Sep 17 00:00:00 2001 From: lyj Date: Sat, 20 Jun 2026 21:43:12 +0800 Subject: [PATCH 30/51] feat(LocallyNameless/Untyped): `subst_intro` weaker precondition (#666) - New theorem `subst_intro_openRec` - `subst_intro` no longer needs `LC t` - `subst_intro` no longer needs `subst_fresh` - `subst_intro` new proof based on `subst_intro_openRec` - Updated `preservation_open` in STLC to take advantage of the weaker precondition Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- .../LocallyNameless/Stlc/Basic.lean | 2 +- .../LocallyNameless/Untyped/Properties.lean | 16 ++++++++++------ 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean index 405554ffb4..79637e8b11 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean @@ -125,7 +125,7 @@ theorem preservation_open {xs : Finset Var} (cofin : ∀ x ∉ xs, ⟨x, σ⟩ :: Γ ⊢ m ^ fvar x ∶ τ) (der : Γ ⊢ n ∶ σ) : Γ ⊢ m ^ n ∶ τ := by have ⟨fresh, _⟩ := fresh_exists <| free_union [Term.fv] Var - grind [subst_intro fresh _ _ ?_ der.lc, typing_subst_head] + grind [subst_intro fresh _ _ ?_, typing_subst_head] end LambdaCalculus.LocallyNameless.Stlc.Typing diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean index 54b3b6c9ab..44a0c6ea69 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean @@ -74,6 +74,16 @@ lemma subst_preserve_not_fvar {y : Var} (m n : Term Var) : lemma subst_refl (m : Term Var) (x : Var) : m[x := fvar x] = m := by induction m <;> grind +lemma subst_intro_openRec {x} {t e : Term Var} (mem : x ∉ e.fv) {k : ℕ} : + e ⟦k ↝ t⟧ = (e ⟦ k ↝ fvar x⟧)[ x := t ] := by + induction e generalizing k with grind + +/-- Opening to a term `t` is equivalent to opening to a free variable and substituting for `t`. -/ +lemma subst_intro (x : Var) (t e : Term Var) (mem : x ∉ e.fv) : + e ^ t = (e ^ fvar x) [ x := t ] := subst_intro_openRec mem + +scoped grind_pattern subst_intro => open' e t, open' e (fvar x) + variable [HasFresh Var] omit [DecidableEq Var] in @@ -115,12 +125,6 @@ theorem subst_lc {x : Var} {e u : Term Var} (e_lc : LC e) (u_lc : LC u) : LC (e case' abs => apply LC.abs (free_union Var) all_goals grind -/-- Opening to a term `t` is equivalent to opening to a free variable and substituting for `t`. -/ -lemma subst_intro (x : Var) (t e : Term Var) (mem : x ∉ e.fv) (t_lc : LC t) : - e ^ t = (e ^ fvar x) [ x := t ] := by grind [subst_fresh] - -scoped grind_pattern subst_intro => open' e t, open' e (fvar x) - set_option linter.unusedDecidableInType false in /-- Opening of locally closed terms is locally closed. -/ @[scoped grind ←] From 7e1ac9daeec295b1b0dd0cb6e8f9526609a5ad20 Mon Sep 17 00:00:00 2001 From: lyj Date: Sun, 21 Jun 2026 19:39:45 +0800 Subject: [PATCH 31/51] feat(LocallyNameless/Untyped): generalize `eta_subst_fvar` (#667) `step_subst_cong_l` is the more general version --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- .../LocallyNameless/Untyped/FullEta.lean | 41 ++++++++----------- 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean index ce99952950..f6b55c08c3 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean @@ -81,17 +81,25 @@ lemma step_not_fv (step : M ⭢ηᶠ M') : M.fv = M'.fv := by grind [open_preserve_not_fvar] | _ => grind -/-- Substitution of a fresh variable preserves an η-reduction step. -/ -@[scoped grind ←] -lemma eta_subst_fvar {x y : Var} (step : M ⭢ηᶠ M') : M [ x := fvar y ] ⭢ηᶠ M' [ x := fvar y ] := by - induction step with - | abs => apply Xi.abs <| free_union Var; grind - | @base M N => grind - | _ => grind +/- `s ⭢ηᶠ s'` implies `s [ x := N ] ⭢ηᶠ s' [ x := N ]`. -/ +lemma step_subst_cong_l {x : Var} (s s' N : Term Var) (step : s ⭢ηᶠ s') (lc_N : LC N) : + s [ x := N ] ⭢ηᶠ s' [ x := N ] := by + induction step + case base h => cases h with | eta lc => exact Xi.base (.eta (subst_lc lc lc_N)) + case abs => apply Xi.abs <| free_union Var; grind + all_goals grind + +/- `steps_subst_cong_l` can be generalized to multiple reductions `s ↠ηᶠ s'`. -/ +lemma steps_subst_cong_l {x : Var} (s s' N : Term Var) (steps : s ↠ηᶠ s') (lc_N : LC N) : + s [ x := N ] ↠ηᶠ s' [ x := N ] := by + induction steps with + | refl => rfl + | tail _ step ih => grind [step_subst_cong_l] /-- Abstracting then closing preserves a single η-reduction step. -/ lemma step_abs_close {x} (step : M ⭢ηᶠ M') (lc_M : LC M) : (M ^* x).abs ⭢ηᶠ (M' ^* x).abs := by - grind [Xi.abs ∅] + apply Xi.abs ∅ + grind [step_subst_cong_l] /-- Abstracting then closing preserves multiple reductions. -/ lemma redex_abs_close {x} (steps : M ↠ηᶠ M') (lc_M : LC M) : (M ^* x).abs ↠ηᶠ (M' ^* x).abs := by @@ -155,22 +163,7 @@ lemma close_eta_steps (hx_M : x ∉ M.fv) (st_M : ReflGen FullEta (M ^ fvar x) N cases st_M with | refl => rw [←open_close_var x M hx_M] | single st => - exact .single (Xi.abs {x} (by grind)) - -/- `s ⭢ηᶠ s'` implies `s [ x := N ] ⭢ηᶠ s' [ x := N ]`. -/ -lemma step_subst_cong_l {x : Var} (s s' N : Term Var) (step : s ⭢ηᶠ s') (lc_N : LC N) : - s [ x := N ] ⭢ηᶠ s' [ x := N ] := by - induction step - case base h => cases h with | eta lc => exact Xi.base (.eta (subst_lc lc lc_N)) - case abs => grind [Xi.abs <| free_union Var, subst_open_var] - all_goals grind - -/- `steps_subst_cong_l` can be generalized to multiple reductions `s ↠ηᶠ s'`. -/ -lemma steps_subst_cong_l {x : Var} (s s' N : Term Var) (steps : s ↠ηᶠ s') (lc_N : LC N) : - s [ x := N ] ↠ηᶠ s' [ x := N ] := by - induction steps with - | refl => rfl - | tail _ step ih => grind [step_subst_cong_l] + exact .single (Xi.abs {x} (by grind [step_subst_cong_l])) end LambdaCalculus.LocallyNameless.Untyped.Term.FullEta From 5564021e8a6259a48b9f6ec60560625947fc4651 Mon Sep 17 00:00:00 2001 From: lyj Date: Sun, 21 Jun 2026 19:40:12 +0800 Subject: [PATCH 32/51] =?UTF-8?q?refactor(LocallyNameless/Untyped):=20rena?= =?UTF-8?q?me=20close=5Fopen=5Fto=5Fsubst=20=E2=86=92=20close=5FopenRec=5F?= =?UTF-8?q?to=5Fsubst=20(#668)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Renamed the general `close_open_to_subst` (with explicit `k`) to `close_openRec_to_subst` - Added new `close_open_to_subst` that specializes to k = 0 using the `^*` / `^` notation: `(m ^* x) ^ n = m [x := n]` - Added `@[scoped grind =]` to both lemmas for better automation support --- .../LambdaCalculus/LocallyNameless/Untyped/Properties.lean | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean index 44a0c6ea69..36c6c816d5 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean @@ -134,7 +134,7 @@ theorem beta_lc {M N : Term Var} (m_lc : M.abs.LC) (n_lc : LC N) : LC (M ^ N) := /-- Closing then opening is equivalent to substitution. -/ @[scoped grind =] -lemma close_open_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_lc : LC n) : +lemma close_openRec_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_lc : LC n) : m ⟦k ↜ x⟧⟦k ↝ n⟧ = m [x := n] := by induction m_lc generalizing k with | abs xs t => @@ -146,6 +146,10 @@ lemma close_open_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_ · grind [open_preserve_not_fvar] | _ => grind +@[scoped grind =] +lemma close_open_to_subst (m n : Term Var) (x : Var) (m_lc : LC m) (n_lc : LC n) : + (m ^* x) ^ n = m [x := n] := close_openRec_to_subst m n x 0 m_lc n_lc + /-- Closing and opening are inverses. -/ lemma close_open (x : Var) (t : Term Var) (k : ℕ) (t_lc : LC t) : t⟦k ↜ x⟧⟦k ↝ fvar x⟧ = t := by grind [subst_refl] From f03afdc0b0638a5dbe7fb013d7d19fc34ed38654 Mon Sep 17 00:00:00 2001 From: Chris Henson <46805207+chenson2018@users.noreply.github.com> Date: Sun, 21 Jun 2026 07:41:17 -0400 Subject: [PATCH 33/51] feat: `Set.ReflOn`, `Set.SymmOn` (#663) A first pass at adding definitions corresponding to the concept of having some property of a (homogeneous) relation over a set restriction, as discussed in [this thread](https://leanprover.zulipchat.com/#narrow/channel/513188-CSLib/topic/unbundled.20relations.20with.20restricted.20.28co.29domain/with/596236853). I also add lemmas `of_{cod,dom}` for convenience of working in the "constructive" case where we explicitly are given the relation as evidence of the (co)domain. --- Cslib.lean | 1 + Cslib/Foundations/Relation/Defs.lean | 22 ++++++++ Cslib/Foundations/Relation/Domain.lean | 3 ++ Cslib/Foundations/Relation/Euclidean.lean | 60 +++++++++------------ Cslib/Foundations/Relation/Restriction.lean | 54 +++++++++++++++++++ 5 files changed, 106 insertions(+), 34 deletions(-) create mode 100644 Cslib/Foundations/Relation/Restriction.lean diff --git a/Cslib.lean b/Cslib.lean index 901c6c5e10..57c582e634 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -78,6 +78,7 @@ public import Cslib.Foundations.Relation.Confluence public import Cslib.Foundations.Relation.Defs public import Cslib.Foundations.Relation.Domain public import Cslib.Foundations.Relation.Euclidean +public import Cslib.Foundations.Relation.Restriction public import Cslib.Foundations.Semantics.FLTS.Basic public import Cslib.Foundations.Semantics.FLTS.FLTSToLTS public import Cslib.Foundations.Semantics.FLTS.LTSToFLTS diff --git a/Cslib/Foundations/Relation/Defs.lean b/Cslib/Foundations/Relation/Defs.lean index 6aecd445c2..f649ed5dd5 100644 --- a/Cslib/Foundations/Relation/Defs.lean +++ b/Cslib/Foundations/Relation/Defs.lean @@ -133,3 +133,25 @@ def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r trans hab hbc := _root_.trans hab (h _ _ hbc) end Relation + +namespace Set + +open Relation + +/-- `ReflOn s r` is true when a relation `r` is reflexive on its restriction to a set `s`. -/ +def ReflOn (s : Set α) (r : α → α → Prop) : Prop := + ∀ a ∈ s, r a a + +-- these names are used in the literature, so we provide them as `abbrev` + +/-- `LeftQuasiRefl r` is true when a relation `r` is reflexive on its domain. -/ +abbrev LeftQuasiRefl (r : α → α → Prop) := (dom r).ReflOn r + +/-- `RightQuasiRefl r` is true when a relation `r` is reflexive on its codomain. -/ +abbrev RightQuasiRefl (r : α → α → Prop) := (cod r).ReflOn r + +/-- `SymmOn s r` is true when a relation `r` is symmetric on its restriction to a set `s`. -/ +def SymmOn (s : Set α) (r : α → α → Prop) : Prop := + ∀ a ∈ s, ∀ b ∈ s, r a b → r b a + +end Set diff --git a/Cslib/Foundations/Relation/Domain.lean b/Cslib/Foundations/Relation/Domain.lean index 50dc2818f4..c4976f1a6f 100644 --- a/Cslib/Foundations/Relation/Domain.lean +++ b/Cslib/Foundations/Relation/Domain.lean @@ -34,6 +34,9 @@ variable {β : Type*} {r : α → β → Prop} @[simp, grind =] lemma mem_dom : a ∈ dom r ↔ ∃ b, r a b := .rfl @[simp, grind =] lemma mem_cod : b ∈ cod r ↔ ∃ a, r a b := .rfl +theorem of_dom (hab : r a b) : a ∈ dom r := by grind +theorem of_cod (hab : r a b) : b ∈ cod r := by grind + @[gcongr] lemma dom_mono (h : r₁ ≤ r₂) : dom r₁ ⊆ dom r₂ := fun a ⟨b, hab⟩ => ⟨b, h a b hab⟩ @[gcongr] lemma cod_mono (h : r₁ ≤ r₂) : cod r₁ ⊆ cod r₂ := fun b ⟨a, hab⟩ => ⟨a, h a b hab⟩ diff --git a/Cslib/Foundations/Relation/Euclidean.lean b/Cslib/Foundations/Relation/Euclidean.lean index edd93659e0..0773207004 100644 --- a/Cslib/Foundations/Relation/Euclidean.lean +++ b/Cslib/Foundations/Relation/Euclidean.lean @@ -6,7 +6,7 @@ Authors: Fabrizio Montesi, Thomas Waring, Chris Henson module -public import Cslib.Foundations.Relation.Domain +public import Cslib.Foundations.Relation.Restriction public import Mathlib.Data.Fintype.EquivFin public import Mathlib.Tactic.TFAE @@ -31,6 +31,12 @@ namespace Relation variable {α : Type*} {r : α → α → Prop} +instance [RightEuclidean r] (s : Set α) : RightEuclidean (α := s) r := + ⟨RightEuclidean.rightEuclidean⟩ + +instance [LeftEuclidean r] (s : Set α) : LeftEuclidean (α := s) r := + ⟨LeftEuclidean.leftEuclidean⟩ + @[scoped grind →] lemma refl_serial (r : α → α → Prop) (h : Std.Refl r) : Serial r where serial a := ⟨a, h.refl a⟩ @@ -41,10 +47,8 @@ namespace RightEuclidean variable [RightEuclidean r] -/-- A `RightEuclidean` relation is reflexive on its range -/ -theorem refl_cod (ab : r a b) : r b b := rightEuclidean ab ab - -theorem refl_cod' : b ∈ cod r → r b b := fun ⟨_, ab⟩ ↦ refl_cod ab +/-- A `RightEuclidean` relation is reflexive on its codomain -/ +theorem reflOn_cod : (cod r).ReflOn r := fun _ ⟨_, ab⟩ ↦ rightEuclidean ab ab /-- The converse of a `RightEuclidean` relation is `LeftEuclidean` -/ theorem leftEuclidean_swap : LeftEuclidean (fun a b => r b a) where @@ -56,7 +60,7 @@ instance [Std.Refl r] : Std.Symm r where theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where trans a b c ab bc := by have := Std.Trichotomous.trichotomous (r := r) a c - have cc := refl_cod bc + have cc := reflOn_cod.of_cod bc have (ca : r c a) := rightEuclidean ca cc grind @@ -65,15 +69,15 @@ theorem antisymm_rightUnique [Std.Antisymm r] : Relator.RightUnique r := by exact antisymm (rightEuclidean ab ac) (rightEuclidean ac ab) theorem rightUnique_antisymm (h : Relator.RightUnique r) : Std.Antisymm r where - antisymm _ _ ab ba := h ba (refl_cod ab) + antisymm _ _ ab ba := h ba (reflOn_cod.of_cod ab) theorem rightUnique_trans (h : Relator.RightUnique r) : IsTrans α r where trans a b c ab bc := by - have eq : c = b := h bc (refl_cod ab) + have eq : c = b := h bc (reflOn_cod.of_cod ab) simpa [eq] theorem rightTotal_equiv (h : Relator.RightTotal r) : IsEquiv α r := by - have : Std.Refl r := ⟨fun a => refl_cod (h a).choose_spec⟩ + have : Std.Refl r := ⟨fun a => reflOn_cod.of_cod (h a).choose_spec⟩ exact {toIsTrans := ⟨fun _ _ _ ab bc => rightEuclidean (symm ab) bc⟩} omit [RightEuclidean r] in @@ -92,7 +96,8 @@ private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c have := antisymm_rightUnique (r := r) - have := @refl_cod (r := r) + have := @reflOn_cod (r := r) + simp [Set.ReflOn] at this grind [Relator.RightUnique] theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by @@ -110,16 +115,10 @@ theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintyp have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h use a, b, c -theorem cod_subset_dom : cod r ⊆ dom r := fun b ⟨_, ab⟩ ↦ ⟨b, refl_cod ab⟩ - -instance : RightEuclidean (α := cod r) r where - rightEuclidean := rightEuclidean - -instance : RightEuclidean (α := dom r) r where - rightEuclidean := rightEuclidean +theorem cod_subset_dom : cod r ⊆ dom r := fun _ ⟨_, ab⟩ ↦ of_cod (reflOn_cod.of_cod ab) theorem rightTotal_cod : Relator.RightTotal (α := cod r) (β := cod r) r := - fun ⟨_, _, h⟩ => ⟨_, refl_cod h⟩ + fun ⟨_, _, h⟩ => of_cod (reflOn_cod.of_cod h) theorem equiv_cod : IsEquiv (cod r) r := rightTotal_equiv rightTotal_cod @@ -130,9 +129,7 @@ namespace LeftEuclidean variable [LeftEuclidean r] /-- A `LeftEuclidean` relation is reflexive on its domain -/ -theorem refl_dom (ab : r a b) : r a a := leftEuclidean ab ab - -theorem refl_dom' : a ∈ dom r → r a a := fun ⟨_, ab⟩ ↦ refl_dom ab +theorem reflOn_dom : (dom r).ReflOn r := fun _ ⟨_, ab⟩ ↦ leftEuclidean ab ab /-- The converse of a `LeftEuclidean` relation is `RightEuclidean` -/ theorem rightEuclidean_swap : RightEuclidean (fun a b => r b a) where @@ -144,7 +141,7 @@ instance [Std.Refl r] : Std.Symm r where theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where trans a b c ab bc := by have := Std.Trichotomous.trichotomous (r := r) a c - have aa := refl_dom ab + have aa := reflOn_dom.of_dom ab have (ca : r c a) := leftEuclidean aa ca grind @@ -153,15 +150,15 @@ theorem antisymm_leftUnique [Std.Antisymm r] : Relator.LeftUnique r := by exact antisymm (leftEuclidean ac bc) (leftEuclidean bc ac) theorem leftUnique_antisymm (h : Relator.LeftUnique r) : Std.Antisymm r where - antisymm _ _ ab ba := h ab (refl_dom ba) + antisymm _ _ ab ba := h ab (reflOn_dom.of_dom ba) theorem leftUnique_trans (h : Relator.LeftUnique r) : IsTrans α r where trans a b c ab bc := by - have eq : a = b := h ab (refl_dom bc) + have eq : a = b := h ab (reflOn_dom.of_dom bc) simpa [eq] theorem leftTotal_equiv (h : Relator.LeftTotal r) : IsEquiv α r := by - have : Std.Refl r := ⟨fun a => refl_dom (h a).choose_spec⟩ + have : Std.Refl r := ⟨fun a => reflOn_dom.of_dom (h a).choose_spec⟩ exact {toIsTrans := ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩} omit [LeftEuclidean r] in @@ -180,7 +177,8 @@ private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] : have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c have := antisymm_leftUnique (r := r) - have := @refl_dom (r := r) + have := @reflOn_dom (r := r) + simp [Set.ReflOn] at this grind [Relator.LeftUnique] theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by @@ -198,16 +196,10 @@ theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintyp have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h use a, b, c -theorem dom_subset_cod : dom r ⊆ cod r := fun a ⟨_, ab⟩ ↦ ⟨a, refl_dom ab⟩ - -instance : LeftEuclidean (α := cod r) r where - leftEuclidean := leftEuclidean - -instance : LeftEuclidean (α := dom r) r where - leftEuclidean := leftEuclidean +theorem dom_subset_cod : dom r ⊆ cod r := fun _ ⟨_, ab⟩ ↦ of_dom (reflOn_dom.of_dom ab) theorem leftTotal_dom : Relator.LeftTotal (α := dom r) (β := dom r) r := - fun ⟨_, _, h⟩ => ⟨_, refl_dom h⟩ + fun ⟨a, _, h⟩ => ⟨⟨a, of_dom h⟩, reflOn_dom.of_dom h⟩ theorem equiv_dom : IsEquiv (dom r) r := leftTotal_equiv leftTotal_dom diff --git a/Cslib/Foundations/Relation/Restriction.lean b/Cslib/Foundations/Relation/Restriction.lean new file mode 100644 index 0000000000..9de7da6d56 --- /dev/null +++ b/Cslib/Foundations/Relation/Restriction.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Chris Henson. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Chris Henson +-/ + +module + +public import Cslib.Foundations.Relation.Defs +public import Cslib.Foundations.Relation.Domain + +/-! # Relations: Properties on set restrictions + +## References + +* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018] + +-/ + +@[expose] public section + +open Relation + +namespace Set + +variable (r : α → α → Prop) (s : Set α) + +@[simp, grind .] +theorem refl_iff_reflOn : Std.Refl (α := s) r ↔ s.ReflOn r := by + constructor + · exact fun ⟨h⟩ a ha ↦ h ⟨a, ha⟩ + · exact fun h ↦ ⟨fun ⟨a, ha⟩ ↦ h a ha⟩ + +@[simp, grind .] +theorem symm_iff_symmOn : Std.Symm (α := s) r ↔ s.SymmOn r := by + constructor + · exact fun ⟨h⟩ a ha b hb ab ↦ h ⟨a, ha⟩ ⟨b, hb⟩ ab + · exact fun h ↦ ⟨fun ⟨a, ha⟩ ⟨b, hb⟩ ab ↦ h a ha b hb ab⟩ + +-- for special cases of (co)domain, we provide constructive shortcut lemmas + +theorem ReflOn.of_dom {r} : (dom r).ReflOn r → r a b → r a a +| h, hab => h a (Relation.of_dom hab) + +theorem ReflOn.of_cod {r} : (cod r).ReflOn r → r a b → r b b +| h, hab => h b (Relation.of_cod hab) + +theorem SymmOn.of_dom {r} : (dom r).SymmOn r → r a b → r b c → r b a +| h, hab, hbc => h a (Relation.of_dom hab) b (Relation.of_dom hbc) hab + +theorem SymmOn.of_cod {r} : (cod r).SymmOn r → r a b → r c a → r b a +| h, hab, hca => h a (Relation.of_cod hca) b (Relation.of_cod hab) hab + +end Set From dbce0f9a9922a2f12fcf8854082759515bcc1b18 Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Mon, 22 Jun 2026 04:51:34 -0400 Subject: [PATCH 34/51] chore: bump mathlib to 29af524, fix breaking changes (#670) Bump `mathlib` dependency to [29af524](https://github.com/leanprover-community/mathlib4/commit/29af5245bafea7d69fdca69591450f60b916ed71): chore: adaptation for batteries#1864 and batteries#1866 (#40821) (2026-06-21) Previously at: [360da6f](https://github.com/leanprover-community/mathlib4/commit/360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56): chore: bump toolchain to v4.32.0-rc1 (#40732) (2026-06-18) Closes #669 Failure log from the validation run: [download](https://github.com/leanprover-community/downstream-reports/actions/runs/27909093828/artifacts/7776869620) _(link expires after 1 year)_ --- This PR bumps `mathlib` to an identified incompatible (first-known-bad) commit (`29af524`) so you can reproduce and fix the incompatibility locally by checking out this branch. _Opened automatically by [downstream-reports/track-incompatibility](https://github.com/leanprover-community/downstream-reports) via [this workflow run](https://github.com/leanprover/cslib/actions/runs/27916674545)._ --------- Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Chris Henson --- Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean | 1 - lake-manifest.json | 6 +++--- lakefile.toml | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean index bde0780155..d1e578db87 100644 --- a/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean @@ -40,7 +40,6 @@ set_option linter.checkUnivs false in The definition of labelled transition system (with the type of states and the type of labels as part of the structure). -/ -@[nolint checkUnivs] structure LTSCat : Type (max u v + 1) where /-- Type of states of an LTS -/ State : Type u diff --git a/lake-manifest.json b/lake-manifest.json index 952b7355e2..0abf7df2b3 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56", + "rev": "29af5245bafea7d69fdca69591450f60b916ed71", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56", + "inputRev": "29af5245bafea7d69fdca69591450f60b916ed71", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "954dbc9873f3b4534dc9896604593406d0383520", + "rev": "e535e4feb0aa360e59e7adf4837b91ffbfb8c943", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.toml b/lakefile.toml index 2fe3f18239..b9f47bb6cf 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "360da6fa66c1273b76b6b2d8c5666fd5ac2e3b56" +rev = "29af5245bafea7d69fdca69591450f60b916ed71" [[lean_lib]] name = "Cslib" From f10c049326c6e432ebbaf27548e08a3ed1fdedf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Maximiliano=20Onofre=20Mart=C3=ADnez?= Date: Mon, 22 Jun 2026 14:30:12 -0600 Subject: [PATCH 35/51] feat(untyped): define CBN and Standard evaluation strategies (#671) This is the first step towards the Standardization Theorem. Instead of the classic (and painful) Barendregt approach, I defined `Standard` reduction relying on `CBN` to find the head redex, which makes the proofs much nicer. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- Cslib.lean | 2 + .../LocallyNameless/Untyped/CallByName.lean | 48 ++++++++++++++ .../Untyped/StandardReduction.lean | 63 +++++++++++++++++++ references.bib | 6 ++ 4 files changed, 119 insertions(+) create mode 100644 Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean create mode 100644 Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean diff --git a/Cslib.lean b/Cslib.lean index 57c582e634..8932852ba7 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -125,6 +125,7 @@ public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.Basic public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.Safety public import Cslib.Languages.LambdaCalculus.LocallyNameless.Stlc.StrongNorm public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Basic +public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.CallByName public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Congruence public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaConfluence @@ -136,6 +137,7 @@ public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.LcAt public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.MultiApp public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.MultiSubst public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Properties +public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.StandardReduction public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.StrongNorm public import Cslib.Languages.LambdaCalculus.Named.Untyped.Basic public import Cslib.Logics.HML.Basic diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean new file mode 100644 index 0000000000..7250ae7bb0 --- /dev/null +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Maximiliano Onofre Martínez. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Maximiliano Onofre Martínez +-/ + +module + +public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta +public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Properties + +/-! # Call-by-Name Evaluation -/ + +@[expose] public section + +set_option linter.unusedDecidableInType false + +namespace Cslib + +universe u + +variable {Var : Type u} + +namespace LambdaCalculus.LocallyNameless.Untyped.Term + +/-- A single step of Call-by-Name evaluation. -/ +@[reduction_sys "ₙ"] +inductive CBN : Term Var → Term Var → Prop +/-- Top-level β-reduction. -/ +| base : Beta M N → CBN M N +/-- Evaluates the leftmost term. -/ +| app : LC Z → CBN M N → CBN (app M Z) (app N Z) + +variable {M N : Term Var} + +/-- The left side of a CBN reduction step is locally closed. -/ +lemma CBN.lc_l (step : M ⭢ₙ N) : LC M := by + induction step with grind + +variable [HasFresh Var] [DecidableEq Var] + +/-- The right side of a CBN reduction step is locally closed. -/ +lemma CBN.lc_r (step : M ⭢ₙ N) : LC N := by + induction step with grind + +end LambdaCalculus.LocallyNameless.Untyped.Term + +end Cslib diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean new file mode 100644 index 0000000000..74d253b5cc --- /dev/null +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Maximiliano Onofre Martínez. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Maximiliano Onofre Martínez +-/ + +module + +public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.CallByName + +/-! # Standard Reduction + +## Reference + +* [B. Calisto, *Formalization in Coq of the Standardization Theorem for λ-calculus*][Calisto2022] + +-/ + +@[expose] public section + +namespace Cslib + +universe u + +variable {Var : Type u} + +namespace LambdaCalculus.LocallyNameless.Untyped.Term + +/-- The Standard reduction relation. -/ +@[reduction_sys "ₛ"] +inductive Standard : Term Var → Term Var → Prop +/-- Free variables standardly reduce to themselves. -/ +| fvar (x : Var) : Standard (fvar x) (fvar x) +/-- Congruence rule for application. -/ +| app : Standard L L' → Standard M M' → Standard (app L M) (app L' M') +/-- Congruence rule for lambda terms. -/ +| abs (xs : Finset Var) : + (∀ x ∉ xs, Standard (m ^ fvar x) (m' ^ fvar x)) → Standard (abs m) (abs m') +/-- Standard reduction of a head redex. -/ +| rdx : LC m → LC n → m ↠ₙ (abs m') → Standard (m' ^ n) p → Standard (app m n) p + +variable {M N : Term Var} + +/-- The left side of a standard reduction is locally closed. -/ +lemma Standard.lc_l (step : M ⭢ₛ N) : LC M := by + induction step + case abs xs _ ih => exact LC.abs xs _ ih + all_goals grind + +/-- Standard reduction is reflexive for locally closed terms. -/ +lemma Standard.lc_refl (M : Term Var) (lc : LC M) : M ⭢ₛ M := by + induction lc + all_goals constructor <;> assumption + +/-- The right side of a standard reduction is locally closed. -/ +lemma Standard.lc_r (step : M ⭢ₛ N) : LC N := by + induction step + case abs xs _ ih => exact LC.abs xs _ ih + all_goals grind + +end LambdaCalculus.LocallyNameless.Untyped.Term + +end Cslib diff --git a/references.bib b/references.bib index 973371b652..984dc6e23c 100644 --- a/references.bib +++ b/references.bib @@ -470,3 +470,9 @@ @book{Mitchell1997 publisher = {McGraw-Hill}, isbn = {0070428077} } +@mastersthesis{Calisto2022, + author = {Calisto, Bruna}, + title = {Formalization in {Coq} of the {Standardization Theorem} for {$\lambda$}-calculus}, + school = {Universidade do Minho}, + year = {2022} +} From 4f6cf21070609a07865758b16f330bbe2396db87 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 23 Jun 2026 16:43:00 +0200 Subject: [PATCH 36/51] More design notes, references, switch from BiTape to \int -> Nat and make step function total. --- Cslib.lean | 2 +- .../MultiTape/Deterministic.lean} | 312 +++++++++--------- references.bib | 26 ++ 3 files changed, 180 insertions(+), 160 deletions(-) rename Cslib/Computability/Machines/{MultiTapeTuring/Basic.lean => Turing/MultiTape/Deterministic.lean} (52%) diff --git a/Cslib.lean b/Cslib.lean index d806457646..4b3143aa45 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -34,7 +34,7 @@ public import Cslib.Computability.Languages.MyhillNerode public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage -public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean similarity index 52% rename from Cslib/Computability/Machines/MultiTapeTuring/Basic.lean rename to Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index f83bf9c47a..65b8db364e 100644 --- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -7,15 +7,18 @@ Authors: Christian Reitwiessner module public import Mathlib.Data.Finset.Max +public import Mathlib.Data.Int.Interval +public import Mathlib.Algebra.Order.Group.Abs +public import Mathlib.Algebra.Order.Group.Int public import Mathlib.Algebra.Order.BigOperators.Group.Finset public import Mathlib.Computability.Language -public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.RelatesInSteps /-! -# Multi-Tape Turing Machines +# Deterministic Multi-Tape Turing Machines -Defines Turing machines with a read-only input tape, `k` work tapes and one write-only output tape. +Defines deterministic Turing machines with a read-only input tape, `k` work tapes and one write-only +output tape. The tapes contain symbols from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the blank symbol). @@ -26,8 +29,37 @@ tape. The input head can move freely on the input, but any move attempt beyond one cell outside the input results in no movement. The transition function can optionally output one symbol, which models the write-only output tape. -Because of these restrictions, the input and output tapes do not count towards the space usage of -the machine. The space usage of the work tapes is the number of cells the head accessed. +Because of these restrictions, we ignore the input and output tapes for space usage of the machine. +The space usage is defined as the total number of cells the work tape heads visited during +execution. + +Restricting the movement of the input head is not essential, but useful because it allows +us to easily bound the number of possible configurations of a space-bounded machine. Most textbooks +have this restriction. + +Instead of considering the cells _visited_ by the work tape heads, some textbooks +(including [AroraBarak09]) only consider the number of cells that contain +a non-blank symbol at some point in the execution or the number of cells written to. This allows +work tape heads to freely move at no cost as long as they do not write. It is +important to note that this causes `DSPACE(1)` to include `DSPACE(log log n)`, a class that +contains e.g. the non-regular language `{0^n 1^n | n ∈ ℕ}` (it is accepted by a TM that writes a +single marker on the work tape and then counts the number of symbols by work tape head movement +without writing). +Defining space usage via "cells visited" thus yields the more fine-grained "complexity world" in +which `DSPACE(1)` is exactly the class of regular languages. + +This definition is adapted from the one in [Papadimitriou94], chapter 2.3 including +the sub-linear space modifications from chapter 2.5 with the following changes: +- We allow Turing machines to choose to not write on a tape. This is equivalent to + writing the read symbol again but makes it easier to reason about the semantics. +- Our tapes are infinite in both directions instead of just to the right. This definition is + equivalent (see [AroraBarak09], Claim 1.4). It saves us from having to add a "start marker" to + the alphabet. +- We only have a single halting state. The different ways to halt (accepting, rejecting, etc) can + be distinguished based on the output. +- The way to prevent the input head to move outside the input is enforced by the interpretation + and not by a restriction on the transition function. The two definitions are equivalent, but + not restricting the transition function makes it easier to define a universal machine. ## Important Declarations @@ -51,6 +83,12 @@ proven to be equivalent. * `RelatesInSteps tm.TransitionRelation cfg cfg' t`: a proof that `tm` transforms the configuration `cfg` into `cfg'` in exactly `t` steps +## References + +* [C. Papadimitriou, *Computational Complexity*][Papadimitriou94] +* [S. Arora, B. Barak, *Computational Complexity: A Modern Approach*][AroraBarak09] +* [M. Sipser, *Introduction to the Theory of Computation*][Sipser09] + -/ @[expose] public section @@ -59,18 +97,32 @@ open Cslib Relation namespace Turing -open BiTape StackTape - -variable {Symbol : Type} +variable {Symbol : Type*} variable {k : ℕ} +/-- Possible moves of tape heads. -/ +inductive Move + | left + | stay + | right + +/-- Translate moves to integer offsets for tape head positions. -/ +def Move.toInt : Move → ℤ + | left => -1 + | stay => 0 + | right => 1 + +@[scoped grind .] +lemma Move.toInt_bound (m : Move) : -1 ≤ m.toInt ∧ m.toInt ≤ 1 := by + rcases m with _ | d <;> decide + /-- The output of the transition function. -/ -structure TransitionOut (k : ℕ) (Symbol State : Type) where +structure TransitionOut (k : ℕ) (Symbol State : Type*) where /-- The movement (attempt) of the input head. -/ - inputMove : Option Dir + inputMove : Move /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/ - stmts : Fin k → (Option (Option Symbol)) × (Option Dir) + workActions : Fin k → (Option (Option Symbol)) × Move /-- An optional symbol to output. -/ outS : Option Symbol /-- The successor state or none to halt. -/ @@ -90,7 +142,8 @@ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where /-- transition function, mapping a state, the current input symbol and a tuple of head symbols to a movement for the input head, actions on the work tape, optionally a symbol to output and the successor state -/ - tr : State → (Option Symbol) → (Fin k → Option Symbol) → TransitionOut k Symbol State + tr (q : State) (input : Option Symbol) (work : Fin k → Option Symbol) : + TransitionOut k Symbol State namespace MultiTapeTM @@ -113,15 +166,17 @@ The configurations of a Turing machine consist of: - the output so far. -/ @[ext] -structure Cfg : Type where +structure Cfg where /-- the state of the TM (or none for the halting state) -/ state : Option tm.State /-- the input -/ input : List Symbol /-- the position of the input head, shifted by one -/ inputPos : Fin (input.length + 2) - /-- the work tape -/ - workTapes : Fin k → BiTape Symbol + /-- the work tapes -/ + workTapes : Fin k → ℤ → Option Symbol + /-- the positions of the heads on the work tapes -/ + workTapePos : Fin k → ℤ /-- the output so far -/ output : List Symbol deriving Inhabited @@ -130,15 +185,10 @@ deriving Inhabited The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. -/ @[scoped grind =] -def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : Option Dir) : Fin (n + 2) := - let p := (pos + optionDirToInt m).toNat +def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : Move) : Fin (n + 2) := + let p := (pos + m.toInt).toNat if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ -/-- The output of the transition function applied to a state and the set of topes. -/ -def transitionOutput (q : tm.State) (inputSymbol : Option Symbol) (work : Fin k → BiTape Symbol) : - TransitionOut k Symbol tm.State := - tm.tr q inputSymbol (fun i => (work i).head) - /-- The symbol currently under the input tape head. -/ @[scoped grind =] def inputSymbol (cfg : tm.Cfg) : Option Symbol := @@ -154,51 +204,58 @@ lemma inputSymbolInner {cfg : tm.Cfg} (p : ℕ) simp [inputSymbol, h₁] grind +/-- The symbol read by work tape `i`. -/ +def workTapeSymbols (cfg : tm.Cfg) (i : Fin k) : Option Symbol := + cfg.workTapes i (cfg.workTapePos i) + /-- The step function corresponding to a `MultiTapeTM`. -/ -def step (cfg : tm.Cfg) : Option tm.Cfg := +def step (cfg : tm.Cfg) : tm.Cfg := match cfg.state with - | none => none + -- in the halting state, we stay at the configuration + | none => cfg | some q => - let {inputMove, stmts, outS, q'} := tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes - some { + let {inputMove, workActions, outS, q'} := tm.tr q (tm.inputSymbol cfg) (tm.workTapeSymbols cfg) + { state := q', input := cfg.input, inputPos := moveInputPos cfg.inputPos inputMove, - workTapes i := match stmts i with - | (none, m) => cfg.workTapes i |>.optionMove m - | (some s, m) => cfg.workTapes i |>.write s |>.optionMove m + workTapes i := match (workActions i).1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s + workTapePos i := (cfg.workTapePos i) + (workActions i).2.toInt output := match outS with | none => cfg.output | some s => cfg.output ++ [s] } -/-- Any number of positive steps run from a halting configuration lead to `none`. -/ -@[simp, scoped grind =] -lemma step_iter_none_eq_none (cfg : tm.Cfg) (n : ℕ) (h_halt : cfg.state = none) : - (Option.bind · tm.step)^[n + 1] (some cfg) = none := by - rw [Function.iterate_succ_apply] - induction n with - | zero => simp [step, h_halt] - | succ n ih => grind [Function.iterate_succ_apply'] - -/-- The initial configuration corresponding to a list in the input alphabet. -/ +/-- The initial configuration corresponding to an input string. -/ @[simp] def initCfg (s : List Symbol) : tm.Cfg := - ⟨some tm.q₀, s, 1, default, []⟩ + ⟨some tm.q₀, s, 1, fun _ _ => none, fun _ => 0, []⟩ /-- The sequence of configurations of the Turing machine starting from `cfg`. -If the Turing machine halts, it will eventually get and stay `none` after reaching the halting -configuration. -/ -def configs (cfg : tm.Cfg) (t : ℕ) : Option tm.Cfg := - (Option.bind · tm.step)^[t] cfg - -lemma configs_succ' (cfg : tm.Cfg) (t : ℕ) : - tm.configs cfg (t + 1) = (Option.bind · tm.step) (tm.configs cfg t) := by - simp [configs, Function.iterate_succ_apply'] +If the Turing machine halts, it will stay at the halting configuration. -/ +def configs (cfg : tm.Cfg) (t : ℕ) : tm.Cfg := tm.step^[t] cfg -lemma configs_succ (cfg : tm.Cfg) (t : ℕ) : - tm.configs cfg (t + 1) = tm.configs cfg t >>= tm.step := by - simp [configs, Function.iterate_succ_apply'] +/-- Any number of steps run from a halting configuration results in the same configuration. -/ +@[simp, scoped grind =] +lemma iter_step_eq_of_halt {cfg : tm.Cfg} {n : ℕ} (h_halt : cfg.state = none) : + tm.step^[n] cfg = cfg := by + induction n with + | zero => rfl + | succ n ih => rw [Function.iterate_succ_apply', ih, step, h_halt] + +/-- The work-tape head moves by at most one cell in a single step. -/ +lemma workTapePos_step_le (c : tm.Cfg) (i : Fin k) : + |(tm.step c).workTapePos i - c.workTapePos i| ≤ 1 := by + unfold step + cases hstate : c.state with + | none => simp + | some q => + have := (tm.tr q (tm.inputSymbol c) (tm.workTapeSymbols c)).workActions i |>.2 |>.toInt_bound + simp only [add_sub_cancel_left] + rw [abs_le] + omega end Cfg @@ -207,33 +264,12 @@ section Space variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) -/-- Convert an "optional movement" to an integer where positive is "right". -/ -@[simp, grind] -def optionDirToInt : Option Dir → ℤ - | some .left => -1 - | none => 0 - | some .right => 1 - -/-- The movements of the work tape heads after configuration `cfg`. -/ -def headMovements (cfg : tm.Cfg) : Fin k → ℤ - | i => match cfg.state with - | none => 0 - | some q => optionDirToInt - (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.2) - -/-- The head positions of the work tapes as a function of the number of steps, relative to -the starting position in `cfg`. -/ -def headPositions (cfg : tm.Cfg) (t : ℕ) : Fin k → ℤ - | i => ∑ t' ∈ Finset.range t, (tm.configs cfg t').elim 0 (tm.headMovements · i) - /-- The number of work tape cells touched by the head of tape `i` in the computation starting from configuration `cfg` up to step `t`. -/ def spaceUsedByTape (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : ℕ := - let positions := (Finset.range (t + 1)).image (fun t' => tm.headPositions cfg t' i) - have ne := Finset.image_nonempty.mpr ⟨0, by simp⟩ - (positions.max' ne - positions.min' ne).toNat + 1 + ((List.range (t + 1)).map fun t' => (tm.configs cfg t').workTapePos i).toFinset.card /-- The number of work tape cells touched by a computation starting from configuration @@ -249,63 +285,22 @@ lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) : subst h_zero simp -@[scoped grind .] -lemma OptionDirToInt_bound (d : Option Dir) : - -1 ≤ optionDirToInt d ∧ optionDirToInt d ≤ 1 := by - rcases d with _ | d - · decide - · rcases d <;> decide - -/-- A single step moves each work tape head by at most one cell. -/ -lemma step_head_movement_bound (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : - -1 ≤ (tm.configs cfg t).elim 0 (tm.headMovements · i) - ∧ (tm.configs cfg t).elim 0 (tm.headMovements · i) ≤ 1 := by - unfold headMovements - dsimp - rcases h : tm.configs cfg t <;> - grind - -/-- The head position changes by the corresponding head movement on each step. -/ -lemma headPositions_succ (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : - tm.headPositions cfg (t + 1) i - = tm.headPositions cfg t i + (tm.configs cfg t).elim 0 (tm.headMovements · i) := by - simp only [headPositions, Finset.sum_range_succ] - -/-- -Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned -interval `max' - min'` by at most one cell. --/ -private lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty) - {a q : ℤ} (hSeq : S = insert a s) (hq : q ∈ s) (h1 : a ≤ q + 1) (h2 : q ≤ a + 1) : - (S.max' hS - S.min' hS).toNat ≤ (s.max' hs - s.min' hs).toNat + 1 := by - subst hSeq - rw [Finset.max'_insert _ _ hs, Finset.min'_insert _ _ hs] - have hm := Finset.min'_le _ _ hq - have hM := Finset.le_max' _ _ hq - grind - /-- The number of cells touched by a single work tape grows by at most one each step. -/ -lemma spaceUsedByTape_succ_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : - tm.spaceUsedByTape cfg (t + 1) i ≤ tm.spaceUsedByTape cfg t i + 1 := by - unfold spaceUsedByTape - have hs := tm.headPositions_succ cfg t i - have step_bound := tm.step_head_movement_bound cfg t i - apply Nat.add_le_add_right - refine span_insert_le _ _ - (by rw [Finset.range_add_one, Finset.image_insert]) - (by exact Finset.mem_image_of_mem _ (Finset.mem_range.mpr (Nat.lt_succ_self t))) - (by grind) - (by grind) +lemma spaceUsedByTape_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : + tm.spaceUsedByTape cfg t i ≤ t + 1 := by + calc + tm.spaceUsedByTape cfg t i + _ ≤ ((List.range (t + 1)).map _).length := List.toFinset_card_le _ + _ = t + 1 := by simp /-- -The space used by a configuration grows by at most `k` each step. +The space used by a computation is bounded linearly by the number of steps. -/ -lemma spaceUsed_linear (cfg : tm.Cfg) (t : ℕ) : - tm.spaceUsed cfg (t + 1) ≤ tm.spaceUsed cfg t + k := by - calc tm.spaceUsed cfg (t + 1) - ≤ ∑ i, (tm.spaceUsedByTape cfg t i + 1) := - Finset.sum_le_sum fun i _ => tm.spaceUsedByTape_succ_le cfg t i - _ = (∑ i, tm.spaceUsedByTape cfg t i) + k := by simp [Finset.sum_add_distrib] +lemma spaceUsed_linear (cfg : tm.Cfg) (t : ℕ) : tm.spaceUsed cfg t ≤ k * t + k := by + calc tm.spaceUsed cfg t + = ∑ i, (tm.spaceUsedByTape cfg t i) := by rfl + _ ≤ ∑ i, (t + 1) := Finset.sum_le_sum (fun i _ => tm.spaceUsedByTape_le cfg t i) + _ = k * t + k := by simp [Nat.mul_succ] end Space @@ -319,11 +314,10 @@ is defined by the `step` function, which maps a configuration to its next configuration, if it exists. -/ @[scoped grind =] -def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := - tm.step c₁ = some c₂ +def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := tm.step c₁ = c₂ -/-- A proof that the Turing machine `tm` on input `input` outputs `output` in exactly `t` steps -and uses at most `s` space. -/ +/-- A proof that the Turing machine `tm` on input `input` outputs `output` in at most `t` steps +and uses `s` space. -/ def ComputesInTimeAndSpace (tm : MultiTapeTM k Symbol) (input output : List Symbol) @@ -335,35 +329,40 @@ def ComputesInTimeAndSpace tm.spaceUsed (tm.initCfg input) t = s /-- A proof that the Turing machine `tm` computes the function `f` such that on all inputs of -length `n` it uses at most `t n` steps and `s n` space. -/ +length `n` it uses at most `t n` steps and `s n` space. It assumes an embedding function +from the input/output alphabet into the machine alphabet. -/ def ComputesFunInTimeAndSpace + {IOSymbol : Type*} (tm : MultiTapeTM k Symbol) - (f : List Symbol → List Symbol) + (f : List IOSymbol → List IOSymbol) + (toMachineSymbol : IOSymbol ↪ Symbol) (t s : ℕ → ℕ) : Prop := ∀ input, ∃ t' ≤ t input.length, ∃ s' ≤ s input.length, - ComputesInTimeAndSpace tm input (f input) t' s' + ComputesInTimeAndSpace tm (input.map toMachineSymbol) ((f input).map toMachineSymbol) t' s' open Classical in /-- The indicator function of a language. -/ noncomputable def indicator (L : Language Symbol) : List Symbol → List Symbol | x => if x ∈ L then [default] else [] -/-- A proof that a Turing machine `tm` decides a language `l` with time and space bounds. -/ +/-- A proof that a Turing machine `tm` decides a language `L` with time and space bounds. -/ def DecidesLanguageInTimeAndSpace + {IOSymbol : Type*} [Inhabited IOSymbol] (tm : MultiTapeTM k Symbol) - (L : Language Symbol) + (L : Language IOSymbol) + (toMachineSymbol : IOSymbol ↪ Symbol) (t s : ℕ → ℕ) : Prop := - ComputesFunInTimeAndSpace tm (indicator L) t s + ComputesFunInTimeAndSpace tm (indicator L) toMachineSymbol t s /-- This lemma translates between the relational notion and the iterated step notion. The latter can be more convenient especially for deterministic machines as we have here. -/ @[scoped grind =] -lemma relatesInSteps_iff_step_iter_eq_some +lemma relatesInSteps_iff_configs_eq (tm : MultiTapeTM k Symbol) (cfg₁ cfg₂ : tm.Cfg) (t : ℕ) : - RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ - (Option.bind · tm.step)^[t] cfg₁ = .some cfg₂ := by + RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ tm.configs cfg₁ t = cfg₂ := by + unfold configs induction t generalizing cfg₁ cfg₂ with | zero => simp | succ t ih => @@ -371,17 +370,15 @@ lemma relatesInSteps_iff_step_iter_eq_some constructor · grind · intro h_configs - cases h : (Option.bind · tm.step)^[t] cfg₁ with - | none => grind - | some cfg' => - use cfg' - grind + use tm.step^[t] cfg₁ + grind -/-- The Turing machine `tm` halts after exactly `t` steps on input `input`. -/ +/-- The Turing machine `tm` halts after exactly `t` steps on input `input` +if its state is `none` at step `t` and non-none at step `t - 1`. +Note that every Turing machine hast to perform at least one step to halt. -/ def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool := - match (tm.configs (tm.initCfg input) t) with - | some ⟨none, _, _, _, _⟩ => true - | _ => false + (tm.configs (tm.initCfg input) t).state.isNone && + !(tm.configs (tm.initCfg input) (t - 1)).state.isNone /-- If a Turing machine halts, the time step is uniquely determined. -/ lemma halting_step_unique @@ -397,17 +394,14 @@ lemma halting_step_unique cases d with | zero => rfl | succ d => - unfold haltsAtStep configs at h_halts₁ h_halts₂ - rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply] at h_halts₂ - grind - -/-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/ -lemma configs_isSome_of_haltsAtStep - {tm : MultiTapeTM k Symbol} {input : List Symbol} {t : ℕ} - (h_halts : tm.haltsAtStep input t) : - (tm.configs (tm.initCfg input) t).isSome := by - grind [haltsAtStep] - + have halts₁ : (tm.step^[t₁] (tm.initCfg input)).state = none := by + simp [haltsAtStep, configs] at h_halts₁ + exact h_halts₁.left + have halts₂ : (tm.step^[d + t₁] (tm.initCfg input)).state ≠ none := by + grind [haltsAtStep, configs] + refine absurd ?_ halts₂ + rw [Function.iterate_add_apply, tm.iter_step_eq_of_halt halts₁] + exact halts₁ end MultiTapeTM diff --git a/references.bib b/references.bib index 984dc6e23c..07fbfd468a 100644 --- a/references.bib +++ b/references.bib @@ -476,3 +476,29 @@ @mastersthesis{Calisto2022 school = {Universidade do Minho}, year = {2022} } + +@book{AroraBarak09, + author = {Sanjeev Arora and + Boaz Barak}, + title = {Computational Complexity - {A} Modern Approach}, + publisher = {Cambridge University Press}, + year = {2009}, +} + +@book{Sipser13, + author = {Sipser, Michael}, + title = {Introduction to the Theory of Computation}, + address = {Boston, MA}, + edition = {Third}, + publisher = {Course Technology}, + year = {2013} +} + + +@book{Papadimitriou94, + title={Computational Complexity}, + author={Papadimitriou, Christos H.}, + year={1994}, + publisher={Addison-Wesley}, + address={Reading, Massachusetts} +} \ No newline at end of file From d4a14ef23b62395c6731f4df48808efc24f1ab43 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 23 Jun 2026 16:49:22 +0200 Subject: [PATCH 37/51] Some small tweaks. --- .../Turing/MultiTape/Deterministic.lean | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 65b8db364e..70fb5084c5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -67,8 +67,9 @@ We define a number of structures and concepts related to multi-tape Turing machi * `MultiTapeTM`: the TM itself * `Cfg`: the configuration of a TM, including internal state, the tapes and the output so far -* `spaceUsed`: the number of work tape cells touched by the head until a certain step +* `spaceUsed`: the number of work tape cells touched by the heads until a certain step * `TransitionRelation`: the transition relation from one configuration to the next +* `spaceUsed`: the number of tape cells touched by work tape heads, our main space measure * `ComputesInTimeAndSpace`: a proof that a TM computes an output from an input in a certain number of steps and using a certain number of tape cells * `ComputesFunInTimeAndSpace`: a proof that a TM computes a function (on strings) respecting a @@ -87,7 +88,7 @@ proven to be equivalent. * [C. Papadimitriou, *Computational Complexity*][Papadimitriou94] * [S. Arora, B. Barak, *Computational Complexity: A Modern Approach*][AroraBarak09] -* [M. Sipser, *Introduction to the Theory of Computation*][Sipser09] +* [M. Sipser, *Introduction to the Theory of Computation*][Sipser13] -/ @@ -134,14 +135,14 @@ is the blank `BiTape` symbol). -/ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where /-- type of state labels -/ - State : Type + State : Type* /-- finiteness of the state type -/ [stateFintype : Fintype State] /-- initial state -/ q₀ : State - /-- transition function, mapping a state, the current input symbol and a tuple of head symbols - to a movement for the input head, actions on the work tape, optionally a symbol to output and - the successor state -/ + /-- transition function, mapping a state, the current input symbol and a tuple of work head + symbols to a movement for the input head, actions on the work tape, optionally a symbol to output + and the successor state -/ tr (q : State) (input : Option Symbol) (work : Fin k → Option Symbol) : TransitionOut k Symbol State @@ -154,7 +155,7 @@ section Cfg This section defines the configurations of a Turing machine, the step function that lets the machine transition from one configuration to the next, -and the intended initial and final configurations. +the resulting sequence of configurations and the initial configuration. -/ variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) @@ -311,7 +312,7 @@ variable [Inhabited Symbol] [Fintype Symbol] /-- The `TransitionRelation` corresponding to a `MultiTapeTM k Symbol` is defined by the `step` function, -which maps a configuration to its next configuration, if it exists. +which maps a configuration to its next configuration. -/ @[scoped grind =] def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := tm.step c₁ = c₂ From a441db604430aba5dc210c7f4af341a8c3cc3b6e Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Thu, 25 Jun 2026 18:28:19 +0200 Subject: [PATCH 38/51] feat(Automata): Transducers (#650) Adds a class for transducers and a first implementation based on `NA`. --- Cslib.lean | 2 + .../Automata/NA/EpsilonTransducer.lean | 68 +++++++++++++++++++ .../Automata/Transducers/Transducer.lean | 26 +++++++ Cslib/Foundations/Semantics/LTS/HasTau.lean | 3 + 4 files changed, 99 insertions(+) create mode 100644 Cslib/Computability/Automata/NA/EpsilonTransducer.lean create mode 100644 Cslib/Computability/Automata/Transducers/Transducer.lean diff --git a/Cslib.lean b/Cslib.lean index 8932852ba7..eea1f4491f 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -16,6 +16,7 @@ public import Cslib.Computability.Automata.NA.Basic public import Cslib.Computability.Automata.NA.BuchiEquiv public import Cslib.Computability.Automata.NA.BuchiInter public import Cslib.Computability.Automata.NA.Concat +public import Cslib.Computability.Automata.NA.EpsilonTransducer public import Cslib.Computability.Automata.NA.Hist public import Cslib.Computability.Automata.NA.Loop public import Cslib.Computability.Automata.NA.Pair @@ -23,6 +24,7 @@ public import Cslib.Computability.Automata.NA.Prod public import Cslib.Computability.Automata.NA.Sum public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.NA.Total +public import Cslib.Computability.Automata.Transducers.Transducer public import Cslib.Computability.Distributed.FLP.Algorithm public import Cslib.Computability.Distributed.FLP.Consensus public import Cslib.Computability.Distributed.FLP.ZeroConsensus diff --git a/Cslib/Computability/Automata/NA/EpsilonTransducer.lean b/Cslib/Computability/Automata/NA/EpsilonTransducer.lean new file mode 100644 index 0000000000..4e2e875039 --- /dev/null +++ b/Cslib/Computability/Automata/NA/EpsilonTransducer.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Computability.Automata.NA.Basic +public import Cslib.Computability.Automata.Transducers.Transducer +public import Cslib.Foundations.Semantics.LTS.HasTau + +/-! # Nondeterministic finite ε-transducers + +Transducers based on `NA` with an invisible symbol in their input and output alphabets. +-/ + +@[expose] public section + +namespace Cslib.Automata.NA + +/-- A nondeterministic ε-transducer of finite strings where the input and output alphabets include +an invisible symbol, modelled as `HasTau.τ` (typically called `ε`). -/ +structure εTransducer (State InSymbol OutSymbol : Type*) + extends NA State (InSymbol × OutSymbol) where + /-- The set of accepting states. -/ + accept : Set State + +/-- Removes all `τ`s from a list. -/ +@[scoped grind =] +def _root_.List.dropTaus [HasTau α] [DecidableEqTau α] (l : List α) : List α := + l.filter (· ≠ HasTau.τ) + +variable [HasTau InSymbol] [HasTau OutSymbol] + +namespace εTransducer + +/-- An `εTransducer` translates `xs` into `ys` from state `s` to state `s'` if there is a +multistep transition from `s` to `s'` whose visible projection is `(xs, ys)`. +`MTransl` is short for Multistep Translation relation. +-/ +def MTransl [DecidableEqTau InSymbol] [DecidableEqTau OutSymbol] + (a : εTransducer State InSymbol OutSymbol) (s : State) + (xs : List InSymbol) (ys : List OutSymbol) (s' : State) : Prop := + ∃ μs, a.MTr s μs s' ∧ (μs.map Prod.fst |>.dropTaus) = xs ∧ (μs.map Prod.snd |>.dropTaus) = ys + +/-- An `NA.εTransducer` translates a finite string `xs` into a finite string `ys` if it has +a multistep transition whose visible projection is `(xs, ys)`. + +This is the standard string translation performed by nondeterministic transducers, where +`HasTau.τ` symbols (epsilon transitions) are ignored in the input and output. -/ +instance [DecidableEqTau InSymbol] [DecidableEqTau OutSymbol] : + Transducer (εTransducer State InSymbol OutSymbol) InSymbol OutSymbol where + Translates a xs ys := ∃ s ∈ a.start, ∃ s' ∈ a.accept, a.MTransl s xs ys s' + +/-- Composition of multistep translations. -/ +theorem MTransl.comp [DecidableEqTau InSymbol] [DecidableEqTau OutSymbol] + {a : εTransducer State InSymbol OutSymbol} + {s₁ s₂ s₃ : State} {xs xs' : List InSymbol} {ys ys' : List OutSymbol} : + a.MTransl s₁ xs ys s₂ → a.MTransl s₂ xs' ys' s₃ → + a.MTransl s₁ (xs ++ xs') (ys ++ ys') s₃ := by + intro ⟨μs₁, h₁, e₁⟩ ⟨μs₂, h₂, e₂⟩ + refine ⟨μs₁ ++ μs₂, LTS.MTr.comp a.toLTS h₁ h₂, ?_⟩ + grind + +end εTransducer + +end Cslib.Automata.NA diff --git a/Cslib/Computability/Automata/Transducers/Transducer.lean b/Cslib/Computability/Automata/Transducers/Transducer.lean new file mode 100644 index 0000000000..e17942b640 --- /dev/null +++ b/Cslib/Computability/Automata/Transducers/Transducer.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Init + +/-! # Transducers -/ + +@[expose] public section + +namespace Cslib.Automata + +/-- A `Transducer` is an automaton that translates strings (lists of symbols, from an input to an +output alphabet). -/ +class Transducer (A : Type u) (InSymbol OutSymbol : outParam (Type v)) where + /-- The string `xs` can be translated into `ys` by `a`. -/ + Translates (a : A) (xs : List InSymbol) (ys : List OutSymbol) : Prop + +@[inherit_doc] +scoped notation xs "[" a "]" ys => Transducer.Translates a xs ys + +end Cslib.Automata diff --git a/Cslib/Foundations/Semantics/LTS/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 26140c9b8b..89643fdff6 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -23,6 +23,9 @@ class HasTau (Label : Type v) where /-- The internal transition label, also known as τ. -/ τ : Label +/-- Checking whether an element is `τ` is decidable. -/ +abbrev DecidableEqTau (α : Type*) [HasTau α] := ∀ a : α, Decidable (a = HasTau.τ) + namespace LTS /-- Saturated τ-transition relation. -/ From 2772f4212a5fc611583816c85b84f5d2032dc053 Mon Sep 17 00:00:00 2001 From: Ching-Tsun Chou Date: Fri, 26 Jun 2026 04:29:43 -0700 Subject: [PATCH 39/51] chore: fix the header of Cslib/Computability/Automata/DA/Prod.lean (#682) Add @fmontesi to the "Authors" field of the header of this file. --- Cslib/Computability/Automata/DA/Prod.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cslib/Computability/Automata/DA/Prod.lean b/Cslib/Computability/Automata/DA/Prod.lean index 0d6d123e85..2aa375a07f 100644 --- a/Cslib/Computability/Automata/DA/Prod.lean +++ b/Cslib/Computability/Automata/DA/Prod.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Fabrizio Montesi. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Ching-Tsun Chou +Authors: Fabrizio Montesi, Ching-Tsun Chou -/ module From 1edb3904648c13077e1501e96eb0135945f80850 Mon Sep 17 00:00:00 2001 From: Ching-Tsun Chou Date: Tue, 30 Jun 2026 22:01:01 -0700 Subject: [PATCH 40/51] chore: disable .github/workflows/lake-update.yml on personal forks (#686) Make sure this job is run only on the main cslib repo `leanprover/cslib'` and not on personal forks. --- .github/workflows/lake-update.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/lake-update.yml b/.github/workflows/lake-update.yml index 33271b968a..0bd989b6c9 100644 --- a/.github/workflows/lake-update.yml +++ b/.github/workflows/lake-update.yml @@ -25,6 +25,7 @@ on: jobs: bump: runs-on: ubuntu-latest + if: github.repository == 'leanprover/cslib' steps: - name: Generate app token id: app-token @@ -52,6 +53,7 @@ jobs: open-issue: runs-on: ubuntu-latest + if: github.repository == 'leanprover/cslib' permissions: issues: write steps: From 5c41dcf2f4767830b122c46daabcab2dfa383da1 Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Thu, 2 Jul 2026 01:18:53 +0100 Subject: [PATCH 41/51] chore: bump mathlib to d52d26f, fix breaking changes (#694) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bump `mathlib` dependency to [d52d26f](https://github.com/leanprover-community/mathlib4/commit/d52d26fc2f36d4af5215e91892b33c96dc33915a): chore(Logic/Relation): use `≤` to spell subrelation (#30526) (2026-07-01) Previously at: [29af524](https://github.com/leanprover-community/mathlib4/commit/29af5245bafea7d69fdca69591450f60b916ed71): chore: adaptation for batteries#1864 and batteries#1866 (#40821) (2026-06-21) Closes #693 Failure log from the validation run: [download](https://github.com/leanprover-community/downstream-reports/actions/runs/28530264197/artifacts/8015922463) _(link expires after 1 year)_ --- This PR bumps `mathlib` to an identified incompatible (first-known-bad) commit (`d52d26f`) so you can reproduce and fix the incompatibility locally by checking out this branch. _Opened automatically by [downstream-reports/track-incompatibility](https://github.com/leanprover-community/downstream-reports) via [this workflow run](https://github.com/leanprover/cslib/actions/runs/28546158135)._ --------- Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Chris Henson --- .../Computability/Automata/EpsilonNA/ToSingleAccept.lean | 2 +- Cslib/Foundations/Relation/Confluence.lean | 4 ++-- Cslib/Languages/CombinatoryLogic/Confluence.lean | 5 +++-- lake-manifest.json | 8 ++++---- lakefile.toml | 2 +- 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean b/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean index 91df5a24f6..1be67c5d52 100644 --- a/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean +++ b/Cslib/Computability/Automata/EpsilonNA/ToSingleAccept.lean @@ -122,7 +122,7 @@ theorem toSingleAccept_τSTr_τSTr {a : εNA.FinAcc State Symbol} · intro h cases h with | refl => exact LTS.τSTr.refl - | tail hτstr htr => exact .trans (.lift some (fun _ _ => id) hτstr) (.single htr) + | tail hτstr htr => exact .trans (.lift some (by rfl) _ _ hτstr) (.single htr) @[scoped grind →] theorem toSingleAccept_τSTr_none_accept {a : εNA.FinAcc State Symbol} diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean index 4b46aef4d9..cd23f56847 100644 --- a/Cslib/Foundations/Relation/Confluence.lean +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -362,8 +362,8 @@ theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) ( /-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/ theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) : ReflTransGen r₁ = ReflTransGen r₂ := by - ext - exact ⟨ReflTransGen.mono @h₁, reflTransGen_closed @h₂⟩ + ext a b + exact ⟨ReflTransGen.mono h₁ a b, reflTransGen_closed h₂ a b⟩ lemma ReflGen.compRel_symm : ReflGen (SymmGen r) a b → ReflGen (SymmGen r) b a | .refl => .refl diff --git a/Cslib/Languages/CombinatoryLogic/Confluence.lean b/Cslib/Languages/CombinatoryLogic/Confluence.lean index be73d02c19..9fc3c7d18b 100644 --- a/Cslib/Languages/CombinatoryLogic/Confluence.lean +++ b/Cslib/Languages/CombinatoryLogic/Confluence.lean @@ -93,9 +93,10 @@ theorem reflTransGen_parallelReduction_mRed : ReflTransGen ParallelReduction = ReflTransGen Red := by ext a b constructor - · apply Relation.reflTransGen_of_isTrans_reflexive + · apply reflTransGen_le_of_le + -- TODO: restate `parallelReduction_of_red` and others using `≤`? exact @mRed_of_parallelReduction - · apply Relation.reflTransGen_of_isTrans_reflexive + · apply Relation.reflTransGen_le_of_le exact fun a a' h => Relation.ReflTransGen.single (parallelReduction_of_red h) /-! diff --git a/lake-manifest.json b/lake-manifest.json index 0abf7df2b3..4457b0aef1 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "29af5245bafea7d69fdca69591450f60b916ed71", + "rev": "d52d26fc2f36d4af5215e91892b33c96dc33915a", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "29af5245bafea7d69fdca69591450f60b916ed71", + "inputRev": "d52d26fc2f36d4af5215e91892b33c96dc33915a", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "f3f26cc72646205ca167117487c008ee1dafe816", + "rev": "f3c7bd5061bd81b4480295c524d4f245c8b7e4e2", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "e535e4feb0aa360e59e7adf4837b91ffbfb8c943", + "rev": "77d3cc514f987c1f42f2bbd8a8d56855012dc115", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.toml b/lakefile.toml index b9f47bb6cf..817e16581a 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "29af5245bafea7d69fdca69591450f60b916ed71" +rev = "d52d26fc2f36d4af5215e91892b33c96dc33915a" [[lean_lib]] name = "Cslib" From 7940a10c3341511f2a6e6d34f705a5921e80bd1f Mon Sep 17 00:00:00 2001 From: Carl_Wu <92306328+loafer-19@users.noreply.github.com> Date: Mon, 6 Jul 2026 01:07:54 +0800 Subject: [PATCH 42/51] fix(Foundations/Syntax): guard substitution notation with noWs (#687) Fixes #631. My PR changes `HasSubstitution` notation from a plain trailing notation to a `syntax`/`macro_rules` form guarded by `noWs`. The substitution spelling remains`t[x := s]`; the spaced receiver spelling `t [x := s]` is migrated internally because it can capture brackets from following syntax. The new regression test checks that a structure field followed by an instance-binder field parses after importing `Cslib.Foundations.Syntax.HasSubstitution`. Co-authored-by: loafer-19 --- Cslib/Foundations/Syntax/HasSubstitution.lean | 20 ++++++++++++++++-- .../LocallyNameless/Fsub/Opening.lean | 6 +++--- .../LocallyNameless/Fsub/Safety.lean | 2 +- .../LocallyNameless/Fsub/Subtype.lean | 4 ++-- .../LocallyNameless/Fsub/Typing.lean | 2 +- .../LocallyNameless/Fsub/WellFormed.lean | 8 +++---- .../LocallyNameless/Stlc/Basic.lean | 2 +- .../LocallyNameless/Untyped/FullBeta.lean | 18 ++++++++-------- .../Untyped/FullBetaConfluence.lean | 2 +- .../LocallyNameless/Untyped/FullEta.lean | 12 +++++------ .../LocallyNameless/Untyped/MultiSubst.lean | 2 +- .../LocallyNameless/Untyped/Properties.lean | 16 +++++++------- CslibTests.lean | 1 + CslibTests/HasSubstitution.lean | 21 +++++++++++++++++++ 14 files changed, 77 insertions(+), 39 deletions(-) create mode 100644 CslibTests/HasSubstitution.lean diff --git a/Cslib/Foundations/Syntax/HasSubstitution.lean b/Cslib/Foundations/Syntax/HasSubstitution.lean index 15a5e8d091..b9b31470b2 100644 --- a/Cslib/Foundations/Syntax/HasSubstitution.lean +++ b/Cslib/Foundations/Syntax/HasSubstitution.lean @@ -19,7 +19,23 @@ class HasSubstitution (α : Type u) (β : Type v) (γ : Type w) where /-- Substitution function. Replaces `x` in `t` with `t'`. -/ subst (t : α) (x : β) (t' : γ) : α -/-- Notation for substitution. -/ -notation t:max "[" x ":=" t' "]" => HasSubstitution.subst t x t' +/-- +Notation for substitution. + +The `noWs` guard is intentional: substitution must be written as `t[x := s]`, +not `t [x := s]`. Without the guard, the term parser can attach a bracket from +following syntax, such as an instance-binder field in a structure declaration, +to the preceding term. +-/ +syntax:max term noWs "[" term " := " term "]" : term + +macro_rules + | `($t[$x := $s]) => `(HasSubstitution.subst $t $x $s) + +/-- Pretty-printer support for `HasSubstitution.subst`. -/ +@[app_unexpander HasSubstitution.subst] +meta def unexpandHasSubstitutionSubst : Lean.PrettyPrinter.Unexpander + | `($_ $t $x $s) => `($t[$x := $s]) + | _ => throw () end Cslib diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean index 1d7060916e..3c6bc29580 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean @@ -235,9 +235,9 @@ lemma openRecTy_lc {t : Term Var} (lc : t.LC) : t = t⟦X ↝ σ⟧ᵗᵞ := by def substTy (X : Var) (δ : Ty Var) : Term Var → Term Var | bvar x => bvar x | fvar x => fvar x -| abs σ t₁ => abs (σ [X := δ]) (substTy X δ t₁) +| abs σ t₁ => abs (σ[X := δ]) (substTy X δ t₁) | app t₁ t₂ => app (substTy X δ t₁) (substTy X δ t₂) -| tabs σ t₁ => tabs (σ [X := δ]) (substTy X δ t₁) +| tabs σ t₁ => tabs (σ[X := δ]) (substTy X δ t₁) | tapp t₁ σ => tapp (substTy X δ t₁) (σ[X := δ]) | let' t₁ t₂ => let' (substTy X δ t₁) (substTy X δ t₂) | inl t₁ => inl (substTy X δ t₁) @@ -253,7 +253,7 @@ lemma substTy_def : substTy (X : Var) (δ : Ty Var) (t : Term Var) = t[X := δ] omit [HasFresh Var] in /-- Substitution of a free type variable not present in a term leaves it unchanged. -/ -lemma substTy_fresh (nmem : X ∉ t.fvTy) (δ : Ty Var) : t = t [X := δ] := +lemma substTy_fresh (nmem : X ∉ t.fvTy) (δ : Ty Var) : t = t[X := δ] := by induction t <;> grind [Ty.subst_fresh] /-- Substitution of a locally closed type distributes with term opening to a type . -/ diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean index e777ed0ea7..f2e4d4b6c5 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean @@ -50,7 +50,7 @@ lemma Typing.preservation (der : Typing Γ t τ) (step : t ⭢βᵛ t') : Typing have ⟨_, _, ⟨_, _⟩⟩ := der.tabs_inv sub have ⟨X, mem⟩ := fresh_exists <| free_union [Ty.fv, fvTy] Var simp at mem - have : Γ = (Context.mapVal (·[X:=σ']) []) ++ Γ := by grind + have : Γ = (Context.mapVal (·[X := σ']) []) ++ Γ := by grind rw [openTy_substTy_intro (X := X), open_subst_intro (X := X)] <;> grind [subst_ty] case tapp => grind case let' Γ _ _ _ _ L der _ ih₁ _ => diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean index 7cdb72133c..66217c566a 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean @@ -144,7 +144,7 @@ lemma narrow (sub_δ : Sub Δ δ δ') (sub_narrow : Sub (Γ ++ ⟨X, Binding.sub variable [HasFresh Var] in /-- Subtyping of substitutions. -/ lemma map_subst (sub₁ : Sub (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) σ τ) (sub₂ : Sub Δ δ δ') : - Sub (Γ.mapVal (·[X:=δ]) ++ Δ) (σ[X:=δ]) (τ[X:=δ]) := by + Sub (Γ.mapVal (·[X := δ]) ++ Δ) (σ[X := δ]) (τ[X := δ]) := by generalize eq : Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ = Θ at sub₁ induction sub₁ generalizing Γ case all => apply Sub.all (free_union Var) <;> grind [open_subst_var] @@ -152,7 +152,7 @@ lemma map_subst (sub₁ : Sub (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) σ τ) (sub have := map_subst_nmem Δ X δ have : Γ ++ ⟨X, .sub δ'⟩ :: Δ ~ ⟨X, .sub δ'⟩ :: (Γ ++ Δ) := perm_middle have : .sub σ ∈ dlookup X' (⟨X, .sub δ'⟩ :: (Γ ++ Δ)) := by grind [perm_dlookup] - have := @mapVal_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var)) + have := @mapVal_mem Var (f := ((·[X := δ]) : Binding Var → Binding Var)) by_cases X = X' · trans δ' <;> grind [→ mem_dlookup, Ty.subst_fresh, Ty.Wf.nmem_fv, weaken_head] · grind diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean index c4aa13facd..b983ddb552 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean @@ -144,7 +144,7 @@ lemma subst_ty (der : Typing (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) t τ) (sub : induction der generalizing Γ X case var σ _ X' _ mem => have := map_subst_nmem Δ X δ - have := @mapVal_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var)) + have := @mapVal_mem Var (f := ((·[X := δ]) : Binding Var → Binding Var)) grind [Env.Wf.map_subst, → notMem_keys_of_nodupKeys_cons] case abs => grind [abs (free_union [Ty.fv] Var), Ty.subst_fresh, openTm_substTy_var] case tabs => grind [tabs (free_union Var), openTy_substTy_var, open_subst_var] diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean index c24a0ab669..ea45b5d7f4 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean @@ -121,7 +121,7 @@ lemma strengthen (wf : σ.Wf (Γ ++ ⟨X, Binding.ty τ⟩ :: Δ)) : σ.Wf (Γ + variable [HasFresh Var] in /-- A type remains well-formed under context substitution (of a well-formed type). -/ lemma map_subst (wf_σ : σ.Wf (Γ ++ ⟨X, Binding.sub τ⟩ :: Δ)) (wf_τ' : τ'.Wf Δ) - (ok : (Γ.mapVal (·[X:=τ']) ++ Δ)✓) : σ[X:=τ'].Wf <| Γ.mapVal (·[X:=τ']) ++ Δ := by + (ok : (Γ.mapVal (·[X := τ']) ++ Δ)✓) : σ[X := τ'].Wf <| Γ.mapVal (·[X := τ']) ++ Δ := by have := @mapVal_mem Var (Binding Var) generalize eq : Γ ++ ⟨X, Binding.sub τ⟩ :: Δ = Θ at wf_σ induction wf_σ generalizing Γ τ' with @@ -133,7 +133,7 @@ variable [HasFresh Var] in lemma open_lc (ok_Γ : Γ✓) (wf_all : (Ty.all σ τ).Wf Γ) (wf_δ : δ.Wf Γ) : (τ ^ᵞ δ).Wf Γ := by cases wf_all with | all => let ⟨X, _⟩ := fresh_exists <| free_union [fv, Context.dom] Var - have : Γ = Context.mapVal (·[X:=δ]) [] ++ Γ := by grind + have : Γ = Context.mapVal (·[X := δ]) [] ++ Γ := by grind grind [open_subst_intro, map_subst] /-- A type bound in a context is well formed. -/ @@ -177,7 +177,7 @@ lemma strengthen (wf : Env.Wf <| Γ ++ ⟨X, Binding.ty τ⟩ :: Δ) : Env.Wf <| variable [HasFresh Var] in /-- A context remains well-formed under substitution (of a well-formed type). -/ lemma map_subst (wf_env : Env.Wf (Γ ++ ⟨X, Binding.sub τ⟩ :: Δ)) (wf_τ' : τ'.Wf Δ) : - Env.Wf <| Γ.mapVal (·[X:=τ']) ++ Δ := by + Env.Wf <| Γ.mapVal (·[X := τ']) ++ Δ := by induction Γ generalizing wf_τ' Δ τ' <;> cases wf_env case nil => grind case cons.sub | cons.ty => constructor <;> grind [Ty.Wf.map_subst] @@ -186,7 +186,7 @@ variable [HasFresh Var] /-- A well-formed context is unchanged by substituting for a free key. -/ lemma map_subst_nmem (Γ : Env Var) (X : Var) (σ : Ty Var) (wf : Γ.Wf) (nmem : X ∉ Γ.dom) : - Γ = Γ.mapVal (·[X:=σ]) := by + Γ = Γ.mapVal (·[X := σ]) := by induction wf <;> grind [Ty.Wf.nmem_fv, Binding.subst_fresh] end Env.Wf diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean index 79637e8b11..fd95b1eae6 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean @@ -117,7 +117,7 @@ lemma subst_aux (h : Δ ++ ⟨x, σ⟩ :: Γ ⊢ t ∶ τ) (der : Γ ⊢ s ∶ /-- Substitution for a context weakened by a single type. -/ lemma typing_subst_head (weak : ⟨x, σ⟩ :: Γ ⊢ t ∶ τ) (der : Γ ⊢ s ∶ σ) : - Γ ⊢ (t [x := s]) ∶ τ := by + Γ ⊢ (t[x := s]) ∶ τ := by grind [subst_aux] /-- Typing preservation for opening. -/ diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean index 8cdb1ddb08..bb064d21d8 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean @@ -87,7 +87,7 @@ lemma steps_lc_or_rfl {M M' : Term Var} (redex : M ↠βᶠ M') : (LC M ∧ LC M /-- Substitution of a locally closed term respects a single reduction step. -/ lemma redex_subst_cong_lc (s s' t : Term Var) (x : Var) (step : s ⭢βᶠ s') (h_lc : LC t) : - s [ x := t ] ⭢βᶠ s' [ x := t ] := by + s[x := t] ⭢βᶠ s'[x := t] := by induction step with | base beta => cases beta; grind [subst_open] | abs => grind [Xi.abs <| free_union Var] @@ -95,7 +95,7 @@ lemma redex_subst_cong_lc (s s' t : Term Var) (x : Var) (step : s ⭢βᶠ s') ( /-- Substitution respects a single reduction step of a free variable. -/ lemma redex_subst_cong (s s' : Term Var) (x y : Var) (step : s ⭢βᶠ s') : - s [ x := fvar y ] ⭢βᶠ s' [ x := fvar y ] := + s[x := fvar y] ⭢βᶠ s'[x := fvar y] := redex_subst_cong_lc _ _ _ _ step (.fvar y) /-- An β-reduction step does not introduce new free variables. -/ @@ -159,25 +159,25 @@ lemma steps_open_cong_l_abs specialize ih s cases step with grind [invert_steps_abs, step_open_cong_l (L := free_union Var)] -/- `t ↠βᶠ t'` implies `s [ x := t ] ↠βᶠ s [ x := t' ]`. +/- `t ↠βᶠ t'` implies `s[x := t] ↠βᶠ s[x := t']`. There is no single step lemma in this case because x may be substituted for n times, so a single step t ↠βᶠ t - in general requires n steps in `s [ x := t ] ↠βᶠ (s [ x := t' ])` -/ + in general requires n steps in `s[x := t] ↠βᶠ (s[x := t'])` -/ lemma step_subst_cong_r {x : Var} (s t t' : Term Var) (step : t ⭢βᶠ t') (h_lc : LC s) : - (s [ x := t ]) ↠βᶠ (s [ x := t' ]) := by + (s[x := t]) ↠βᶠ (s[x := t']) := by induction h_lc with | fvar y => grind | abs => grind [redex_abs_cong (free_union Var)] | @app l r => calc - (l.app r)[x:=t] ↠βᶠ l[x := t].app (r[x:=t']) := by grind - _ ↠βᶠ (l.app r)[x:=t'] := by grind + (l.app r)[x := t] ↠βᶠ l[x := t].app (r[x := t']) := by grind + _ ↠βᶠ (l.app r)[x := t'] := by grind /- `step_subst_cong_r` can be generalized to multiple reductions `t ↠βᶠ t'`. This requires s to be locally closed, locally closedness of t and t' can be inferred by the fact t reduces to t' -/ lemma steps_subst_cong_r {x : Var} (s t t' : Term Var) (step : t ↠βᶠ t') (h_lc : LC s) : - (s [ x := t ]) ↠βᶠ (s [ x := t' ]) := by + (s[x := t]) ↠βᶠ (s[x := t']) := by induction step with | refl => rfl | tail steps step ih => grind [Relation.ReflTransGen.trans, step_subst_cong_r] @@ -190,7 +190,7 @@ lemma steps_open_cong_abs (s s' t t' : Term Var) | abs L => have ⟨x, _⟩ := fresh_exists <| free_union [fv] Var rw [subst_intro x t s, subst_intro x t' s'] - · trans (s ^ fvar x)[x:=t'] + · trans (s ^ fvar x)[x := t'] · grind [steps_subst_cong_r] · grind [=_ subst_intro, steps_open_cong_l_abs] all_goals grind diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean index 0ae59ca2fc..2f1f003602 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean @@ -175,7 +175,7 @@ theorem para_diamond : Diamond (@Parallel Var) := by have ⟨q1, q2, _⟩ := qx have ⟨t', _⟩ := ih2 s2pu2' have ⟨t'', _⟩ := @ih1 x q1 _ (mem' _ q2) - refine ⟨t'' [x := t'], ?_⟩ + refine ⟨t''[x := t'], ?_⟩ grind case app s1 s1' s2 s2' s1ps1' _ ih1 ih2 => cases tpt2 diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean index f6b55c08c3..2231d2b085 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean @@ -81,9 +81,9 @@ lemma step_not_fv (step : M ⭢ηᶠ M') : M.fv = M'.fv := by grind [open_preserve_not_fvar] | _ => grind -/- `s ⭢ηᶠ s'` implies `s [ x := N ] ⭢ηᶠ s' [ x := N ]`. -/ +/- `s ⭢ηᶠ s'` implies `s[x := N] ⭢ηᶠ s'[x := N]`. -/ lemma step_subst_cong_l {x : Var} (s s' N : Term Var) (step : s ⭢ηᶠ s') (lc_N : LC N) : - s [ x := N ] ⭢ηᶠ s' [ x := N ] := by + s[x := N] ⭢ηᶠ s'[x := N] := by induction step case base h => cases h with | eta lc => exact Xi.base (.eta (subst_lc lc lc_N)) case abs => apply Xi.abs <| free_union Var; grind @@ -91,7 +91,7 @@ lemma step_subst_cong_l {x : Var} (s s' N : Term Var) (step : s ⭢ηᶠ s') (lc /- `steps_subst_cong_l` can be generalized to multiple reductions `s ↠ηᶠ s'`. -/ lemma steps_subst_cong_l {x : Var} (s s' N : Term Var) (steps : s ↠ηᶠ s') (lc_N : LC N) : - s [ x := N ] ↠ηᶠ s' [ x := N ] := by + s[x := N] ↠ηᶠ s'[x := N] := by induction steps with | refl => rfl | tail _ step ih => grind [step_subst_cong_l] @@ -117,9 +117,9 @@ theorem redex_abs_cong {M M' : Term Var} (xs : Finset Var) rw [open_close x M 0, open_close x M' 0] all_goals grind [redex_abs_close (x := x) (cofin x ?_) (hL x ?_)] -/- `t ⭢ηᶠ t'` implies `s [ x := t ] ↠ηᶠ s [ x := t' ]`. -/ +/- `t ⭢ηᶠ t'` implies `s[x := t] ↠ηᶠ s[x := t']`. -/ lemma step_subst_cong_r {x : Var} (s t t' : Term Var) (st : t ⭢ηᶠ t') (lc_s : LC s) (lc_t : LC t) : - s [ x := t ] ↠ηᶠ s [ x := t' ] := by + s[x := t] ↠ηᶠ s[x := t'] := by induction lc_s generalizing t t' with | fvar => grind | app hl hr ih_l ih_r => @@ -136,7 +136,7 @@ lemma step_subst_cong_r {x : Var} (s t t' : Term Var) (st : t ⭢ηᶠ t') (lc_s /- `steps_subst_cong_r` can be generalized to multiple reductions `t ↠ηᶠ t'`. -/ lemma steps_subst_cong_r {x : Var} (s t t' : Term Var) (st : t ↠ηᶠ t') (lc_s : LC s) (lc_t : LC t) : - s [ x := t ] ↠ηᶠ s [ x := t' ] := by + s[x := t] ↠ηᶠ s[x := t'] := by induction st using Relation.ReflTransGen.head_induction_on case refl => rfl case head _ _ st _ ih => exact .trans (step_subst_cong_r s _ _ st lc_s lc_t) (ih (step_lc_r st)) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean index 1ae7265830..91deb0e118 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean @@ -37,7 +37,7 @@ abbrev Env (Var : Type u) := Context Var (Term Var) def multiSubst (E : Env Var) (M : Term Var) : Term Var := match E with | [] => M - | ⟨i, sub⟩ :: E' => (multiSubst E' M) [ i := sub ] + | ⟨i, sub⟩ :: E' => (multiSubst E' M)[i := sub] /-- The free variables of an environment are the union of the free variables of all terms in the environment. diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean index 36c6c816d5..4af9462d16 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean @@ -25,7 +25,7 @@ attribute [grind =] Finset.union_singleton variable [DecidableEq Var] /-- Substitution of a free variable not present in a term leaves it unchanged. -/ -theorem subst_fresh (x : Var) (t sub : Term Var) (nmem : x ∉ t.fv) : t [x := sub] = t := by +theorem subst_fresh (x : Var) (t sub : Term Var) (nmem : x ∉ t.fv) : t[x := sub] = t := by induction t <;> grind /- Opening and closing are inverses. -/ @@ -66,7 +66,7 @@ theorem open_preserve_not_fvar (k) (m n : Term Var) : set_option linter.tacticAnalysis.verifyGrindOnly false in /-- Substitution preserves free variables. -/ lemma subst_preserve_not_fvar {y : Var} (m n : Term Var) : - m [y := n].fv = m.fv.erase y ∨ m [y := n].fv = m.fv.erase y ∪ n.fv:= by + m[y := n].fv = m.fv.erase y ∨ m[y := n].fv = m.fv.erase y ∪ n.fv:= by induction m with | app => grind only [fv, = subst_app, = Finset.mem_union, = Finset.mem_erase] | _ => grind @@ -80,7 +80,7 @@ lemma subst_intro_openRec {x} {t e : Term Var} (mem : x ∉ e.fv) {k : ℕ} : /-- Opening to a term `t` is equivalent to opening to a free variable and substituting for `t`. -/ lemma subst_intro (x : Var) (t e : Term Var) (mem : x ∉ e.fv) : - e ^ t = (e ^ fvar x) [ x := t ] := subst_intro_openRec mem + e ^ t = (e ^ fvar x)[x := t] := subst_intro_openRec mem scoped grind_pattern subst_intro => open' e t, open' e (fvar x) @@ -107,12 +107,12 @@ lemma open_eq_app {x : Var} {m n : Term Var} (hw_n : x ∉ n.fv) (hw_m : x ∉ m /-- Substitution of a locally closed term distributes with opening. -/ @[scoped grind =] lemma subst_openRec (x : Var) (t : Term Var) (k : ℕ) (u e : Term Var) (lc : LC t) : - (e⟦ k ↝ u ⟧)[x := t] = e[x := t]⟦k ↝ u [ x := t ]⟧ := by + (e⟦ k ↝ u ⟧)[x := t] = e[x := t]⟦k ↝ u[x := t]⟧ := by induction e generalizing k with grind /-- Specialize `subst_openRec` to the first opening. -/ lemma subst_open (x : Var) (t : Term Var) (u e : Term Var) (lc : LC t) : - (e ^ u)[x := t] = e[x := t] ^ u [ x := t ] := by grind + (e ^ u)[x := t] = e[x := t] ^ u[x := t] := by grind /-- Specialize `subst_open` to the free variables. -/ theorem subst_open_var (x y : Var) (u e : Term Var) (neq : y ≠ x) (u_lc : LC u) : @@ -120,7 +120,7 @@ theorem subst_open_var (x y : Var) (u e : Term Var) (neq : y ≠ x) (u_lc : LC u /-- Substitution of locally closed terms is locally closed. -/ @[scoped grind ←] -theorem subst_lc {x : Var} {e u : Term Var} (e_lc : LC e) (u_lc : LC u) : LC (e [x := u]) := by +theorem subst_lc {x : Var} {e u : Term Var} (e_lc : LC e) (u_lc : LC u) : LC (e[x := u]) := by induction e_lc case' abs => apply LC.abs (free_union Var) all_goals grind @@ -135,7 +135,7 @@ theorem beta_lc {M N : Term Var} (m_lc : M.abs.LC) (n_lc : LC N) : LC (M ^ N) := /-- Closing then opening is equivalent to substitution. -/ @[scoped grind =] lemma close_openRec_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_lc : LC n) : - m ⟦k ↜ x⟧⟦k ↝ n⟧ = m [x := n] := by + m ⟦k ↜ x⟧⟦k ↝ n⟧ = m[x := n] := by induction m_lc generalizing k with | abs xs t => have ⟨x', _⟩ := fresh_exists <| free_union [fv] Var @@ -148,7 +148,7 @@ lemma close_openRec_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) @[scoped grind =] lemma close_open_to_subst (m n : Term Var) (x : Var) (m_lc : LC m) (n_lc : LC n) : - (m ^* x) ^ n = m [x := n] := close_openRec_to_subst m n x 0 m_lc n_lc + (m ^* x) ^ n = m[x := n] := close_openRec_to_subst m n x 0 m_lc n_lc /-- Closing and opening are inverses. -/ lemma close_open (x : Var) (t : Term Var) (k : ℕ) (t_lc : LC t) : t⟦k ↜ x⟧⟦k ↝ fvar x⟧ = t := by diff --git a/CslibTests.lean b/CslibTests.lean index 3380bb5e17..90903a188a 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -6,6 +6,7 @@ import CslibTests.FreeMonad import CslibTests.GrindLint import CslibTests.HML import CslibTests.HasFresh +import CslibTests.HasSubstitution import CslibTests.ImportWithMathlib import CslibTests.LTS import CslibTests.LambdaCalculus diff --git a/CslibTests/HasSubstitution.lean b/CslibTests/HasSubstitution.lean new file mode 100644 index 0000000000..d2b39682a6 --- /dev/null +++ b/CslibTests/HasSubstitution.lean @@ -0,0 +1,21 @@ +import Cslib.Foundations.Syntax.HasSubstitution + +namespace CslibTests +namespace HasSubstitution + +/-- Regression test for leanprover/cslib#631. + +Before the notation was guarded by `noWs`, the parser tried to read the instance +binder below as part of a substitution expression attached to `Type`. +-/ +structure InstanceBinderAfterField where + A : Type + [inst : Inhabited A] + +instance : Cslib.HasSubstitution Nat Nat Nat where + subst t _ _ := t + +example : (1[2 := 3]) = 1 := rfl + +end HasSubstitution +end CslibTests From f2aeae553b9356d3aed003cacd7e3061d9ad0bd3 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Mon, 6 Jul 2026 13:17:41 +0200 Subject: [PATCH 43/51] feat(Machines): Single-Tape Nondeterministic Turing Machines (NTMs) (#683) - Adds NTMs, defined as nondeterministic automata over `TrLabel` and the usual derived 'yields' relation (`Red`). - Instantiates Acceptor and Transducer for NTM. - Proves characterisation theorems that connect reductions on configurations to single- and multistep transitions of the underlying machine. --- Cslib.lean | 2 + .../Machines/Turing/SingleTape/Defs.lean | 68 ++++++++++ .../Turing/SingleTape/NonDeterministic.lean | 123 ++++++++++++++++++ references.bib | 8 ++ 4 files changed, 201 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/SingleTape/Defs.lean create mode 100644 Cslib/Computability/Machines/Turing/SingleTape/NonDeterministic.lean diff --git a/Cslib.lean b/Cslib.lean index eea1f4491f..43c374ae78 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -36,7 +36,9 @@ public import Cslib.Computability.Languages.MyhillNerode public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage +public import Cslib.Computability.Machines.Turing.SingleTape.Defs public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic +public import Cslib.Computability.Machines.Turing.SingleTape.NonDeterministic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable public import Cslib.Computability.URM.Defs diff --git a/Cslib/Computability/Machines/Turing/SingleTape/Defs.lean b/Cslib/Computability/Machines/Turing/SingleTape/Defs.lean new file mode 100644 index 0000000000..5cac8d41b0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/SingleTape/Defs.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi, Bolton Bailey +-/ + +module + +public import Cslib.Foundations.Data.BiTape + +/-! # Basic definitions for Turing Machines (TMs) -/ + +@[expose] public section + +namespace Cslib.Computability.Turing.SingleTape + +/-- The transition labels used by a single-tape Turing Machine. -/ +inductive TrLabel (Symbol : Type*) + /-- Read `x` from the tape. -/ + | read (x : Symbol) + /-- Write `x` on the tape. -/ + | write (x : Symbol) + /-- Move the head of the tape. -/ + | move (d : Turing.Dir) + /-- Do nothing. -/ + | skip + +/-- Applies a transition label to a tape, returning `none` if it is not possible. +The input is taken as an `Option` to make the function composable. -/ +def TrLabel.applyToTape [DecidableEq Symbol] + (otape : Option (Turing.BiTape Symbol)) (μ : TrLabel Symbol) : + Option (Turing.BiTape Symbol) := + match μ, otape with + | read x, some tape => if x = tape.head then some tape else none + | write x, some tape => some (tape.write x) + | move d, some tape => some (tape.move d) + | skip, some tape => some tape + | _, _ => none + +@[scoped grind →] +theorem TrLabel.applyToTape_isSome [DecidableEq Symbol] {μ : TrLabel Symbol} + {ot : Option (Turing.BiTape Symbol)} (h : (μ.applyToTape ot).isSome) : ot.isSome := by + have ⟨t', ht'⟩ := Option.isSome_iff_exists.mp h + simp only [applyToTape] at ht' + grind [applyToTape] + +@[scoped grind →] +theorem TrLabel.applyToTape_foldl_isSome [DecidableEq Symbol] {μs : List (TrLabel Symbol)} + {ot : Option (Turing.BiTape Symbol)} (h : (μs.foldl applyToTape ot).isSome) : ot.isSome := by + induction μs generalizing ot <;> grind + +/-- Configuration of a single-tape Turing machine. -/ +@[ext] +structure Cfg (State Symbol : Type*) where + /-- The state that the machine is in. -/ + state : State + /-- Tape of the machine (memory). -/ + tape : Turing.BiTape Symbol + +/-- Helper builder for a configuration with a given tape content. -/ +def Cfg.mk₁ (s : State) (xs : List Symbol) : Cfg State Symbol where + state := s + tape := Turing.BiTape.mk₁ xs + +/-- The space used by a configuration is the space used by its tape. -/ +def Cfg.spaceUsed (cfg : Cfg State Symbol) : ℕ := cfg.tape.spaceUsed + +end Cslib.Computability.Turing.SingleTape diff --git a/Cslib/Computability/Machines/Turing/SingleTape/NonDeterministic.lean b/Cslib/Computability/Machines/Turing/SingleTape/NonDeterministic.lean new file mode 100644 index 0000000000..ffd15a5909 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/SingleTape/NonDeterministic.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Fabrizio Montesi. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Fabrizio Montesi +-/ + +module + +public import Cslib.Foundations.Relation.Defs +public import Cslib.Foundations.Data.RelatesInSteps +public import Cslib.Computability.Automata.NA.Basic +public import Cslib.Computability.Automata.Transducers.Transducer +public import Cslib.Foundations.Data.BiTape +public import Cslib.Computability.Machines.Turing.SingleTape.Defs + +/-! # Single-Tape Nondeterministic Turing Machines (NTMs) + +Nondeterministic Turing Machines (NTMs), defined as nondeterministic automata (`NA`) that act on a +bidirectional tape (`BiTape`). + +## References + +* [M. Sipser, *Introduction to Theory of Computation*][Sipser2013] +-/ + +@[expose] public section + +namespace Cslib.Computability.Turing.SingleTape + +open Automata + +/-- A (single-tape) Nondeterministic Turing Machine (NTM) is a nondeterministic automaton equipped +with a set of accepting halting states. -/ +structure SingleTapeNTM (State Symbol : Type*) + extends NA State (TrLabel Symbol) where + /-- The set of accepting states. -/ + accept : Set State + /-- Proof that all accepting states are halting states. -/ + accept_halting (hmem : s ∈ accept) : ¬∃ μ s', Tr s μ s' + +variable {State Symbol : Type*} + +namespace SingleTapeNTM + +variable [DecidableEq Symbol] + +/-- An NTM yields a small-step operational semantics on configurations, which codifies an execution +step. This formalises the 'yields' relation from [Sipser2013]. -/ +def Yields (m : SingleTapeNTM State Symbol) + (c c' : Cfg State Symbol) : Prop := + ∃ μ, m.Tr c.state μ c'.state ∧ μ.applyToTape c.tape = c'.tape + +@[scoped grind =] +theorem yields_tr {m : SingleTapeNTM State Symbol} : + m.Yields c c' ↔ ∃ μ, m.Tr c.state μ c'.state ∧ μ.applyToTape c.tape = c'.tape := by rfl + +/-- Multistep execution of an NTM, defined as the reflexive and transitive closure of one-step +execution. +-/ +def MYields (m : SingleTapeNTM State Symbol) := Relation.ReflTransGen m.Yields + +open scoped LTS LTS.MTr TrLabel + +/-- Characterisation of executions in terms of multistep transitions. -/ +@[scoped grind =] +theorem mYields_mTr {m : SingleTapeNTM State Symbol} : + m.MYields c c' ↔ ∃ μs, m.MTr c.state μs c'.state ∧ + μs.foldl TrLabel.applyToTape (some c.tape) = c'.tape := by + apply Iff.intro <;> intro h + case mp => + induction h using Relation.ReflTransGen.head_induction_on + case refl => + exists [] + grind + case head _ c cb hred hmred ih => + rcases ih with ⟨μs, hmtr, ih⟩ + have ⟨μ, _⟩ := yields_tr.mp hred + exists μ :: μs + grind + case mpr => + rcases h with ⟨μs, hmtr, h⟩ + induction μs generalizing c + case nil => + rw [show c = c' by grind [Cfg.ext]] + apply Relation.ReflTransGen.refl + case cons μ μs ih => + cases hmtr + case stepL sb htr hmtr => + have hat : ∀ (μ : TrLabel Symbol) t, (μ.applyToTape t).isSome → t.isSome := by grind + have ⟨tb, htb⟩ : ∃ tb, μ.applyToTape c.tape = some tb := by grind [Option.isSome_iff_exists] + let cb := {state := sb, tape := tb : Cfg State Symbol} + have hmyields : m.MYields cb c' := by grind + apply Relation.ReflTransGen.head (b := cb) (by grind) + simp only [MYields] at hmyields + grind + +/-- An NTM is an acceptor of finite lists of symbols. -/ +instance : Acceptor (SingleTapeNTM State Symbol) Symbol where + Accepts (m : SingleTapeNTM State Symbol) (xs : List Symbol) := + ∃ s ∈ m.start, ∃ c', c'.state ∈ m.accept ∧ m.MYields (Cfg.mk₁ s xs) c' + +/-- The NTM `m` accepts `xs` in `n` execution steps. -/ +def AcceptsInSteps (m : SingleTapeNTM State Symbol) (xs : List Symbol) (n : ℕ) : Prop := + ∃ s ∈ m.start, ∃ c', c'.state ∈ m.accept ∧ Relation.RelatesInSteps m.Yields (Cfg.mk₁ s xs) c' n + +/-- The NTM `m` accepts `xs` in at most `n` execution steps. -/ +def AcceptsInAtMostSteps (m : SingleTapeNTM State Symbol) (xs : List Symbol) (n : ℕ) : Prop := + ∃ k ≤ n, m.AcceptsInSteps xs k + +/-- An NTM is a transducer of finite lists of symbols. -/ +instance : Transducer (SingleTapeNTM State Symbol) Symbol Symbol where + Translates (m : SingleTapeNTM State Symbol) (xs ys : List Symbol) := + ∃ s ∈ m.start, ∃ c', + c'.state ∈ m.accept ∧ + m.MYields (Cfg.mk₁ s xs) c' ∧ + /- The following condition on output deviates from textbooks, in order to have the same + criterion as for deterministic TMs. We might want to revisit this in the future. + -/ + c'.tape = Turing.BiTape.mk₁ ys + +end SingleTapeNTM + +end Cslib.Computability.Turing.SingleTape diff --git a/references.bib b/references.bib index 984dc6e23c..18281428d2 100644 --- a/references.bib +++ b/references.bib @@ -476,3 +476,11 @@ @mastersthesis{Calisto2022 school = {Universidade do Minho}, year = {2022} } + +@book{Sipser2013, + author = {Sipser, Michael}, + title = {Introduction to the Theory of Computation}, + edition = {3rd}, + publisher = {Cengage Learning}, + year = {2013} +} \ No newline at end of file From 27d53d7ce51665f3694d17d7256c62e3fe89e548 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Maximiliano=20Onofre=20Mart=C3=ADnez?= Date: Wed, 8 Jul 2026 22:05:04 -0600 Subject: [PATCH 44/51] feat(untyped): standardization theorem for the lambda calculus (#679) This PR proves the standardization theorem: if `M` beta-reduces to `N` in any number of steps, then `N` is reachable from `M` by a standard reduction. Builds on #671. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> Co-authored-by: Chris Henson --- .../LocallyNameless/Untyped/CallByName.lean | 44 ++++- .../Untyped/StandardReduction.lean | 163 +++++++++++++++++- 2 files changed, 202 insertions(+), 5 deletions(-) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean index 7250ae7bb0..a2be62e5a8 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean @@ -31,18 +31,56 @@ inductive CBN : Term Var → Term Var → Prop /-- Evaluates the leftmost term. -/ | app : LC Z → CBN M N → CBN (app M Z) (app N Z) -variable {M N : Term Var} +variable {M M' N N' : Term Var} -/-- The left side of a CBN reduction step is locally closed. -/ +/-- The left side of a Call-by-Name step is locally closed. -/ lemma CBN.lc_l (step : M ⭢ₙ N) : LC M := by induction step with grind +/-- A single Call-by-Name step is a full β-reduction. -/ +lemma CBN.step_to_redex (step : M ⭢ₙ N) : M ↠βᶠ N := by + induction step with + | base h => exact .single (.base h) + | app lc_Z _ ih => exact FullBeta.redex_app_l_cong ih lc_Z + +/-- Call-by-Name reduction is contained in full β-reduction. -/ +lemma CBN.to_redex (step : M ↠ₙ N) : M ↠βᶠ N := by + induction step + · rfl + · grind [CBN.step_to_redex, Relation.ReflTransGen.trans] + +/-- Left congruence rule for application in Call-by-Name reduction. -/ +lemma CBN.steps_app_l_cong (step : M ↠ₙ M') (lc_N : LC N) : Term.app M N ↠ₙ Term.app M' N := by + induction step + · rfl + · grind [CBN.app] + variable [HasFresh Var] [DecidableEq Var] -/-- The right side of a CBN reduction step is locally closed. -/ +/-- The right side of a Call-by-Name step is locally closed. -/ lemma CBN.lc_r (step : M ⭢ₙ N) : LC N := by induction step with grind +/-- The right side of a Call-by-Name reduction is locally closed. -/ +lemma CBN.steps_lc_r (lc_M : LC M) (step : M ↠ₙ N) : LC N := by + induction step + · exact lc_M + · grind [CBN.lc_r] + +/-- Substitution preserves a single Call-by-Name step. -/ +lemma CBN.step_subst (x : Var) (h : M ⭢ₙ M') (lc_N : LC N) : + M[x := N] ⭢ₙ M'[x := N] := by + induction h + · grind [Term.subst_open, CBN.base] + · grind [CBN.app] + +/-- Substitution preserves Call-by-Name reduction. -/ +lemma CBN.steps_subst (x : Var) (step : M ↠ₙ M') (lc_N : LC N) : + M[x := N] ↠ₙ M'[x := N] := by + induction step + · rfl + · grind [CBN.step_subst] + end LambdaCalculus.LocallyNameless.Untyped.Term end Cslib diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean index 74d253b5cc..e9cfe09ec1 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean @@ -8,7 +8,7 @@ module public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.CallByName -/-! # Standard Reduction +/-! # Standard Reduction and the Standardization Theorem ## Reference @@ -18,6 +18,8 @@ public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.CallByName @[expose] public section +set_option linter.unusedDecidableInType false + namespace Cslib universe u @@ -39,7 +41,7 @@ inductive Standard : Term Var → Term Var → Prop /-- Standard reduction of a head redex. -/ | rdx : LC m → LC n → m ↠ₙ (abs m') → Standard (m' ^ n) p → Standard (app m n) p -variable {M N : Term Var} +variable {M N P M' N' : Term Var} /-- The left side of a standard reduction is locally closed. -/ lemma Standard.lc_l (step : M ⭢ₛ N) : LC M := by @@ -58,6 +60,163 @@ lemma Standard.lc_r (step : M ⭢ₛ N) : LC N := by case abs xs _ ih => exact LC.abs xs _ ih all_goals grind +/-- A single Call-by-Name step is a standard reduction. -/ +lemma Standard.of_cbn_step (step : M ⭢ₙ N) (lc_N : LC N) : M ⭢ₛ N := by + induction step + case base h_beta => + cases h_beta + exact rdx (by assumption) (by assumption) .refl (lc_refl _ lc_N) + case app L _ _ lc_L _ ih => + cases lc_N + exact app (ih (by assumption)) (lc_refl L lc_L) + +/-- A Call-by-Name step followed by a standard reduction is a standard reduction. -/ +lemma Standard.cbn_step_trans (step : M ⭢ₙ P) (std : P ⭢ₛ N) : M ⭢ₛ N := by + induction step generalizing N + case base h_beta => + cases h_beta + exact rdx (by assumption) (by assumption) .refl std + case app step_M ih => + cases std with + | app std_L' std_M => exact app (ih std_L') std_M + | rdx _ lc_Z cbn_m std_body => exact rdx step_M.lc_l lc_Z (.head step_M cbn_m) std_body + +/-- A Call-by-Name reduction followed by a standard reduction is a standard reduction. -/ +lemma Standard.cbn_trans (h1 : M ↠ₙ P) (h2 : P ⭢ₛ N) : M ⭢ₛ N := by + induction h1 with + | refl => exact h2 + | tail _ h_step ih => exact ih (cbn_step_trans h_step h2) + +/-- Call-by-Name reduction is contained in standard reduction. -/ +lemma Standard.of_cbn (step : M ↠ₙ N) (lc_N : LC N) : M ⭢ₛ N := + cbn_trans step (lc_refl N lc_N) + +variable [DecidableEq Var] [HasFresh Var] + +/-- Standard reduction is preserved by substitution. -/ +lemma Standard.subst (hM : M ⭢ₛ M') (hN : N ⭢ₛ N') (x : Var) (lc_N : LC N) (lc_N' : LC N') : + (M[x := N]) ⭢ₛ (M'[x := N']) := by + induction hM generalizing N N' + case fvar => + simp only [Term.subst_fvar] + split + · exact hN + · exact fvar _ + case app ihL ihM => exact app (ihL hN lc_N lc_N') (ihM hN lc_N lc_N') + case abs m m' _ _ ih => + apply abs <| free_union [fv] Var + grind + case rdx n m' _ lc_m lc_n cbn_m std_p ih => + rw [Term.subst_app] + have std_p_subst := ih hN lc_N lc_N' + rw [Term.subst_open x N n m' lc_N] at std_p_subst + exact rdx (subst_lc lc_m lc_N) (subst_lc lc_n lc_N) (CBN.steps_subst x cbn_m lc_N) std_p_subst + +/-- A single full β-step is a standard reduction. -/ +lemma Standard.of_beta_step (step : M ⭢βᶠ N) (lc_M : LC M) : M ⭢ₛ N := by + induction step + case base h_beta => grind [rdx, lc_refl] + case appL Z A B lc_Z _ ih => + cases lc_M + exact app (lc_refl Z lc_Z) (ih (by assumption)) + case appR Z A B lc_Z _ ih => + cases lc_M + exact app (ih (by assumption)) (lc_refl Z lc_Z) + case abs ih => + apply abs <| free_union [fv] Var + intro x hx + exact ih x (by grind) (Term.beta_lc lc_M (by constructor)) + +open FullBeta in +/-- Standard reduction is contained in full β-reduction. -/ +lemma Standard.to_redex (step : M ⭢ₛ N) : M ↠βᶠ N := by + induction step + case fvar => rfl + case app step_L step_M ih_L ih_M => + exact .trans (redex_app_l_cong ih_L step_M.lc_l) (redex_app_r_cong ih_M step_L.lc_r) + case abs xs _ ih => exact FullBeta.redex_abs_cong xs ih + case rdx n m' _ lc_m lc_n cbn_m std_p ih => + have step1 := redex_app_l_cong (CBN.to_redex cbn_m) lc_n + have step2 : m'.abs.app n ↠βᶠ m' ^ n := .single (.base (.beta (CBN.steps_lc_r lc_m cbn_m) lc_n)) + exact .trans step1 (.trans step2 ih) + +/-- If a standard reduction reaches an abstraction, then its leading Call-by-Name + reduction reaches an abstraction that standardly reduces to the same target. -/ +lemma Standard.abs_inv (h : M ⭢ₛ N) (M' : Term Var) (eq : N = Term.abs M') : + ∃ M'', M ↠ₙ Term.abs M'' ∧ Term.abs M'' ⭢ₛ Term.abs M' := by + induction h generalizing M' + case fvar => trivial + case app => trivial + case abs m_body m_target xs h_body ih => + cases eq + exact ⟨m_body, .refl, .abs xs h_body⟩ + case rdx m1 n1 m1' p1 lc_m1 lc_n1 cbn_m1 _ ih => + have ⟨p'', cbn_body, std_p''⟩ := ih M' eq + have step1 : m1.app n1 ↠ₙ m1'.abs.app n1 := CBN.steps_app_l_cong cbn_m1 lc_n1 + have step2 : m1'.abs.app n1 ⭢ₙ m1' ^ n1 := .base (.beta (CBN.steps_lc_r lc_m1 cbn_m1) lc_n1) + exact ⟨p'', .trans step1 (.head step2 cbn_body), std_p''⟩ + +/-- Standard reduction of abstractions is preserved by opening. -/ +lemma Standard.abs_subst + (h_abs : Term.abs M ⭢ₛ Term.abs M') (hN : N ⭢ₛ N') (lc_N : LC N) (lc_N' : LC N') : + (M ^ N) ⭢ₛ (M' ^ N') := by + cases h_abs + case abs h_body => + have ⟨y, _⟩ := fresh_exists <| free_union [fv] Var + have := subst (h_body y (by grind)) hN y lc_N lc_N' + grind + +/-- A standard reduction followed by a full β-step is a standard reduction. -/ +lemma Standard.trans_step (h1 : M ⭢ₛ P) (h2 : P ⭢βᶠ N) : M ⭢ₛ N := by + induction h1 generalizing N + case fvar => contradiction + case rdx lc_L lc_M cbn _ ih => exact .rdx lc_L lc_M cbn (ih h2) + case abs p_body ih => + cases h2 + · grind + · apply abs <| free_union [fv] Var + grind + case app L' _ M _ std_L std_M ih_L ih_M => + cases h2 + case appL step_M => exact .app std_L (ih_M step_M) + case appR step_L _ => exact .app (ih_L step_L) std_M + case base h_beta => + cases h_beta + have ⟨L, cbn_L1, std_abs⟩ := abs_inv std_L _ rfl + have std_subst := std_abs.abs_subst std_M std_M.lc_l std_M.lc_r + have s1 : L'.app M ↠ₙ L.abs.app M := CBN.steps_app_l_cong cbn_L1 std_M.lc_l + have s2 : L.abs.app M ⭢ₙ L ^ M := .base (.beta (CBN.steps_lc_r std_L.lc_l cbn_L1) std_M.lc_l) + exact Standard.cbn_trans (.trans s1 (.single s2)) std_subst + +/-- A standard reduction followed by a full β-reduction is a standard reduction. -/ +lemma Standard.trans_redex (h1 : M ⭢ₛ P) (h2 : P ↠βᶠ N) : M ⭢ₛ N := by + induction h2 with + | refl => exact h1 + | tail _ step ih => exact trans_step ih step + +/-- Standard reduction is transitive. -/ +lemma Standard.trans (h1 : M ⭢ₛ P) (h2 : P ⭢ₛ N) : M ⭢ₛ N := + trans_redex h1 (to_redex h2) + +instance : Trans (· ⭢ₛ · : Term Var → Term Var → Prop) (· ⭢βᶠ ·) (· ⭢ₛ ·) where + trans := Standard.trans_step + +instance : Trans (· ⭢ₛ · : Term Var → Term Var → Prop) (· ↠βᶠ ·) (· ⭢ₛ ·) where + trans := Standard.trans_redex + +instance : Trans (· ⭢ₛ · : Term Var → Term Var → Prop) (· ⭢ₛ ·) (· ⭢ₛ ·) where + trans := Standard.trans + +/-- The standardization theorem: every full β-reduction is a standard reduction. -/ +theorem Standard.standardization (lc_M : LC M) (step : M ↠βᶠ N) : M ⭢ₛ N := by + induction step with + | refl => exact lc_refl M lc_M + | tail _ h_step ih => exact ih.trans (of_beta_step h_step h_step.step_lc_l) + +/-- Standard reduction coincides with full β-reduction on locally closed terms. -/ +theorem Standard.iff_redex (lc_M : LC M) : M ⭢ₛ N ↔ M ↠βᶠ N := + ⟨to_redex, standardization lc_M⟩ + end LambdaCalculus.LocallyNameless.Untyped.Term end Cslib From c0120dddfe75d4ab913691c0c184fc436927b19d Mon Sep 17 00:00:00 2001 From: lyj Date: Thu, 9 Jul 2026 12:35:16 +0800 Subject: [PATCH 45/51] feat(LocallyNameless/Untyped): new theorem `lcAt_le` (#699) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit If a term is locally closed at level `i` and `i ≤ j`, then it is also locally closed at level `j`. --------- Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> --- .../Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean index 72fce48957..539e92ff81 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean @@ -125,4 +125,7 @@ lemma lcAt_openRec_above_lcAt (M N : Term Var) (i j : ℕ) (h : i ≤ j) (lc : L M⟦j ↝ N⟧ = M := by induction M generalizing i j <;> grind +lemma lcAt_le (M : Term Var) (i j : ℕ) (h : i ≤ j) (lc : LcAt i M) : LcAt j M := by + induction M generalizing i j <;> grind + end Cslib.LambdaCalculus.LocallyNameless.Untyped.Term From 4d3bcce35e85383d0797c5428a9bd432a333ec46 Mon Sep 17 00:00:00 2001 From: crei Date: Sat, 11 Jul 2026 18:06:30 +0200 Subject: [PATCH 46/51] Replace Move by SignType and require Fintype and Inhabited for Symbol. --- .../Turing/MultiTape/Deterministic.lean | 41 +++++-------------- 1 file changed, 11 insertions(+), 30 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 76807c57e3..ec7ead9138 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -12,6 +12,7 @@ public import Mathlib.Algebra.Order.Group.Abs public import Mathlib.Algebra.Order.Group.Int public import Mathlib.Algebra.Order.BigOperators.Group.Finset public import Mathlib.Computability.Language +public import Mathlib.Data.Sign.Defs public import Cslib.Foundations.Data.RelatesInSteps /-! @@ -98,32 +99,16 @@ open Cslib Relation namespace Turing -variable {Symbol : Type} +variable {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] variable {k : ℕ} -/-- Possible moves of tape heads. -/ -inductive Move - | left - | stay - | right - -/-- Translate moves to integer offsets for tape head positions. -/ -def Move.toInt : Move → ℤ - | left => -1 - | stay => 0 - | right => 1 - -@[scoped grind .] -lemma Move.toInt_bound (m : Move) : -1 ≤ m.toInt ∧ m.toInt ≤ 1 := by - rcases m with _ | d <;> decide - /-- The output of the transition function. -/ structure TransitionOut (k : ℕ) (Symbol State : Type*) where /-- The movement (attempt) of the input head. -/ - inputMove : Move + inputMove : SignType /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/ - workActions : Fin k → (Option (Option Symbol)) × Move + workActions : Fin k → (Option (Option Symbol)) × SignType /-- An optional symbol to output. -/ outS : Option Symbol /-- The successor state or none to halt. -/ @@ -158,7 +143,7 @@ the step function that lets the machine transition from one configuration to the the resulting sequence of configurations and the initial configuration. -/ -variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) +variable (tm : MultiTapeTM k Symbol) /-- The configurations of a Turing machine consist of: @@ -186,8 +171,8 @@ deriving Inhabited The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. -/ @[scoped grind =] -def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : Move) : Fin (n + 2) := - let p := (pos + m.toInt).toNat +def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : Fin (n + 2) := + let p := (pos + ↑m).toNat if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ /-- The symbol currently under the input tape head. -/ @@ -223,7 +208,7 @@ def step (cfg : tm.Cfg) : tm.Cfg := workTapes i := match (workActions i).1 with | none => cfg.workTapes i | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s - workTapePos i := (cfg.workTapePos i) + (workActions i).2.toInt + workTapePos i := (cfg.workTapePos i) + (workActions i).2 output := match outS with | none => cfg.output | some s => cfg.output ++ [s] @@ -253,17 +238,15 @@ lemma workTapePos_step_le (c : tm.Cfg) (i : Fin k) : cases hstate : c.state with | none => simp | some q => - have := (tm.tr q (tm.inputSymbol c) (tm.workTapeSymbols c)).workActions i |>.2 |>.toInt_bound - simp only [add_sub_cancel_left] - rw [abs_le] - omega + simp only [add_sub_cancel_left, abs_le, SignType.cast] + grind end Cfg section Space /-! Now we define space usage and add some helper lemmas. -/ -variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) +variable (tm : MultiTapeTM k Symbol) /-- The number of work tape cells touched by the head of tape `i` in the computation starting from @@ -307,8 +290,6 @@ end Space open Cfg -variable [Inhabited Symbol] [Fintype Symbol] - /-- The `TransitionRelation` corresponding to a `MultiTapeTM k Symbol` is defined by the `step` function, From 54580afb67152f6580ccd66854afa92bd7f0a9d8 Mon Sep 17 00:00:00 2001 From: crei Date: Sat, 11 Jul 2026 18:12:00 +0200 Subject: [PATCH 47/51] Whitespace and tactic nitpicks. --- .../Computability/Machines/Turing/MultiTape/Deterministic.lean | 3 +-- references.bib | 1 - 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index ec7ead9138..dda51c8252 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -187,7 +187,6 @@ lemma inputSymbolInner {cfg : tm.Cfg} (p : ℕ) (h₁ : cfg.inputPos.val = 1 + p) (h₂ : p < cfg.input.length) : tm.inputSymbol cfg = some cfg.input[p] := by - simp [inputSymbol, h₁] grind /-- The symbol read by work tape `i`. -/ @@ -343,7 +342,7 @@ lemma relatesInSteps_iff_configs_eq (tm : MultiTapeTM k Symbol) (cfg₁ cfg₂ : tm.Cfg) (t : ℕ) : - RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ tm.configs cfg₁ t = cfg₂ := by + RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ tm.configs cfg₁ t = cfg₂ := by unfold configs induction t generalizing cfg₁ cfg₂ with | zero => simp diff --git a/references.bib b/references.bib index 429d5f9b86..7366ab0c2f 100644 --- a/references.bib +++ b/references.bib @@ -499,4 +499,3 @@ @book{Papadimitriou94 publisher={Addison-Wesley}, address={Reading, Massachusetts} } - From 647d9d06acbffcf5831e5f07a561352593202b1e Mon Sep 17 00:00:00 2001 From: crei Date: Sun, 12 Jul 2026 15:59:40 +0200 Subject: [PATCH 48/51] Generalize Symbol and State, remove the `tm` parameter from Cfg and add generic ComputableInTimeAndSpace definition. --- .../Turing/MultiTape/Deterministic.lean | 116 +++++++++--------- 1 file changed, 61 insertions(+), 55 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index dda51c8252..9d1635d643 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -71,12 +71,12 @@ We define a number of structures and concepts related to multi-tape Turing machi * `spaceUsed`: the number of work tape cells touched by the heads until a certain step * `TransitionRelation`: the transition relation from one configuration to the next * `spaceUsed`: the number of tape cells touched by work tape heads, our main space measure -* `ComputesInTimeAndSpace`: a proof that a TM computes an output from an input in a certain number - of steps and using a certain number of tape cells -* `ComputesFunInTimeAndSpace`: a proof that a TM computes a function (on strings) respecting a - time and space bound in the input length -* `DecidesLanguageInTimeAndSpace`: a proof that a TM decides a language within a certain time - and space bound +* `ComputesInTimeAndSpace`: a proof that a specific TM computes an output from an input in a certain + number of steps and using a certain number of tape cells +* `ComputableInTimeAndSpace`: a proof that there is a multi-tape TM that computes a function + (on strings) respecting a time and space bound in the input length. +* `DecidableInTimeAndSpace`: a proof that a TM decides a language within a certain time + and space bound. There are two ways to talk about the behaviour of a multi-tape Turing machine, and they are proven to be equivalent. @@ -99,9 +99,7 @@ open Cslib Relation namespace Turing -variable {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] - -variable {k : ℕ} +variable {k : ℕ} {State Symbol : Type*} /-- The output of the transition function. -/ structure TransitionOut (k : ℕ) (Symbol State : Type*) where @@ -116,23 +114,23 @@ structure TransitionOut (k : ℕ) (Symbol State : Type*) where /-- A multi-tape Turing machine with `k` work tapes over the alphabet of `Option Symbol` (where `none` -is the blank `BiTape` symbol). +is the blank `BiTape` symbol). Note that it is not required that `Symbol` or `State` are finite +to keep the definition more general. The restriction will be introduced once we start talking about +computability by Turing machines in general. -/ -structure MultiTapeTM (k : ℕ) (Symbol : Type) [Inhabited Symbol] [Fintype Symbol] where - /-- type of state labels -/ - State : Type - /-- finiteness of the state type -/ - [stateFintype : Fintype State] +structure MultiTapeTM (k : ℕ) (Symbol State : Type*) where /-- initial state -/ q₀ : State /-- transition function, mapping a state, the current input symbol and a tuple of work head symbols to a movement for the input head, actions on the work tape, optionally a symbol to output and the successor state -/ tr (q : State) (input : Option Symbol) (work : Fin k → Option Symbol) : - TransitionOut k Symbol State + TransitionOut k Symbol State namespace MultiTapeTM +variable {tm : MultiTapeTM k Symbol State} + section Cfg /-! @@ -143,8 +141,6 @@ the step function that lets the machine transition from one configuration to the the resulting sequence of configurations and the initial configuration. -/ -variable (tm : MultiTapeTM k Symbol) - /-- The configurations of a Turing machine consist of: - an `Option`al state (or none for the halting state), @@ -152,9 +148,9 @@ The configurations of a Turing machine consist of: - the output so far. -/ @[ext] -structure Cfg where +structure Cfg (k : ℕ) (Symbol State : Type*) where /-- the state of the TM (or none for the halting state) -/ - state : Option tm.State + state : Option State /-- the input -/ input : List Symbol /-- the position of the input head, shifted by one -/ @@ -172,34 +168,33 @@ The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. -/ @[scoped grind =] def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : Fin (n + 2) := - let p := (pos + ↑m).toNat + let p := (pos + m.cast).toNat if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ /-- The symbol currently under the input tape head. -/ -@[scoped grind =] -def inputSymbol (cfg : tm.Cfg) : Option Symbol := +def Cfg.inputSymbol (cfg : Cfg k Symbol State) : Option Symbol := if h₁ : cfg.inputPos = 0 then none else if h₂ : cfg.inputPos = cfg.input.length + 1 then none else cfg.input[cfg.inputPos.val - 1]'(by grind) @[simp] -lemma inputSymbolInner {cfg : tm.Cfg} (p : ℕ) +lemma inputSymbolInner {cfg : Cfg k Symbol State} (p : ℕ) (h₁ : cfg.inputPos.val = 1 + p) (h₂ : p < cfg.input.length) : - tm.inputSymbol cfg = some cfg.input[p] := by - grind + cfg.inputSymbol = some cfg.input[p] := by + grind [Cfg.inputSymbol] /-- The symbol read by work tape `i`. -/ -def workTapeSymbols (cfg : tm.Cfg) (i : Fin k) : Option Symbol := +def Cfg.workTapeSymbols (cfg : Cfg k Symbol State) (i : Fin k) : Option Symbol := cfg.workTapes i (cfg.workTapePos i) /-- The step function corresponding to a `MultiTapeTM`. -/ -def step (cfg : tm.Cfg) : tm.Cfg := +def step (cfg : Cfg k Symbol State) : Cfg k Symbol State := match cfg.state with -- in the halting state, we stay at the configuration | none => cfg | some q => - let {inputMove, workActions, outS, q'} := tm.tr q (tm.inputSymbol cfg) (tm.workTapeSymbols cfg) + let {inputMove, workActions, outS, q'} := tm.tr q cfg.inputSymbol cfg.workTapeSymbols { state := q', input := cfg.input, @@ -215,23 +210,23 @@ def step (cfg : tm.Cfg) : tm.Cfg := /-- The initial configuration corresponding to an input string. -/ @[simp] -def initCfg (s : List Symbol) : tm.Cfg := +def initCfg (s : List Symbol) : Cfg k Symbol State := ⟨some tm.q₀, s, 1, fun _ _ => none, fun _ => 0, []⟩ /-- The sequence of configurations of the Turing machine starting from `cfg`. If the Turing machine halts, it will stay at the halting configuration. -/ -def configs (cfg : tm.Cfg) (t : ℕ) : tm.Cfg := tm.step^[t] cfg +def configs (cfg : Cfg k Symbol State) (t : ℕ) : Cfg k Symbol State := tm.step^[t] cfg /-- Any number of steps run from a halting configuration results in the same configuration. -/ @[simp, scoped grind =] -lemma iter_step_eq_of_halt {cfg : tm.Cfg} {n : ℕ} (h_halt : cfg.state = none) : +lemma iter_step_eq_of_halt {cfg : Cfg k Symbol State} {n : ℕ} (h_halt : cfg.state = none) : tm.step^[n] cfg = cfg := by induction n with | zero => rfl | succ n ih => rw [Function.iterate_succ_apply', ih, step, h_halt] /-- The work-tape head moves by at most one cell in a single step. -/ -lemma workTapePos_step_le (c : tm.Cfg) (i : Fin k) : +lemma workTapePos_step_le (c : Cfg k Symbol State) (i : Fin k) : |(tm.step c).workTapePos i - c.workTapePos i| ≤ 1 := by unfold step cases hstate : c.state with @@ -245,31 +240,29 @@ end Cfg section Space /-! Now we define space usage and add some helper lemmas. -/ -variable (tm : MultiTapeTM k Symbol) - /-- The number of work tape cells touched by the head of tape `i` in the computation starting from configuration `cfg` up to step `t`. -/ -def spaceUsedByTape (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : ℕ := +def spaceUsedByTape (cfg : Cfg k Symbol State) (t : ℕ) (i : Fin k) : ℕ := ((List.range (t + 1)).map fun t' => (tm.configs cfg t').workTapePos i).toFinset.card /-- The number of work tape cells touched by a computation starting from configuration `cfg` up to step `t`. -/ -def spaceUsed (cfg : tm.Cfg) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i +def spaceUsed (cfg : Cfg k Symbol State) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i /-- A zero-tape Turing machine uses zero space. -/ @[simp] -lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) : +lemma spaceUsed_zero_tapes_eq_zero (cfg : Cfg k Symbol State) (t : ℕ) (h_zero : k = 0) : tm.spaceUsed cfg t = 0 := by unfold spaceUsed subst h_zero simp /-- The number of cells touched by a single work tape grows by at most one each step. -/ -lemma spaceUsedByTape_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : +lemma spaceUsedByTape_le (cfg : Cfg k Symbol State) (t : ℕ) (i : Fin k) : tm.spaceUsedByTape cfg t i ≤ t + 1 := by calc tm.spaceUsedByTape cfg t i @@ -279,7 +272,7 @@ lemma spaceUsedByTape_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : /-- The space used by a computation is bounded linearly by the number of steps. -/ -lemma spaceUsed_linear (cfg : tm.Cfg) (t : ℕ) : tm.spaceUsed cfg t ≤ k * t + k := by +lemma spaceUsed_linear (cfg : Cfg k Symbol State) (t : ℕ) : tm.spaceUsed cfg t ≤ k * t + k := by calc tm.spaceUsed cfg t = ∑ i, (tm.spaceUsedByTape cfg t i) := by rfl _ ≤ ∑ i, (t + 1) := Finset.sum_le_sum (fun i _ => tm.spaceUsedByTape_le cfg t i) @@ -295,12 +288,13 @@ is defined by the `step` function, which maps a configuration to its next configuration. -/ @[scoped grind =] -def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := tm.step c₁ = c₂ +def TransitionRelation (c₁ c₂ : Cfg k Symbol State) : Prop := tm.step c₁ = c₂ /-- A proof that the Turing machine `tm` on input `input` outputs `output` in at most `t` steps -and uses `s` space. -/ +and uses exactly `s` space. +Note that this does not require the alphabet or state set to be finite. -/ def ComputesInTimeAndSpace - (tm : MultiTapeTM k Symbol) + (tm : MultiTapeTM k Symbol State) (input output : List Symbol) (t s : ℕ) : Prop := ∃ cfg, @@ -311,36 +305,48 @@ def ComputesInTimeAndSpace /-- A proof that the Turing machine `tm` computes the function `f` such that on all inputs of length `n` it uses at most `t n` steps and `s n` space. It assumes an embedding function -from the input/output alphabet into the machine alphabet. -/ +from the input/output alphabet into the machine alphabet. +Note that this does not require the alphabet or state set to be finite. -/ def ComputesFunInTimeAndSpace + (tm : MultiTapeTM k Symbol State) {IOSymbol : Type*} - (tm : MultiTapeTM k Symbol) (f : List IOSymbol → List IOSymbol) (toMachineSymbol : IOSymbol ↪ Symbol) (t s : ℕ → ℕ) : Prop := ∀ input, ∃ t' ≤ t input.length, ∃ s' ≤ s input.length, ComputesInTimeAndSpace tm (input.map toMachineSymbol) ((f input).map toMachineSymbol) t' s' +/-- The main definition of complexity of multi-tape Turing machines: +A proof that the function `f` is computable by some multi-tape Turing machine `tm` (with finite +work alphabet and finite state set) via an alphabet embedding function `toMachineSymbol`, +such that on all inputs of length `n`, `tm` uses at most `t n` steps and at most `s n` space. -/ +def ComputableInTimeAndSpace + {IOSymbol : Type*} + (f : List IOSymbol → List IOSymbol) + (t s : ℕ → ℕ) : Prop := + ∃ (k sym state : ℕ) (toMachineSymbol : _) (tm : MultiTapeTM k (Fin sym) (Fin state)), + ComputesFunInTimeAndSpace tm f toMachineSymbol t s + open Classical in /-- The indicator function of a language. -/ -noncomputable def indicator (L : Language Symbol) : List Symbol → List Symbol +noncomputable def indicator {Symbol : Type*} [Inhabited Symbol] (L : Language Symbol) : + List Symbol → List Symbol | x => if x ∈ L then [default] else [] -/-- A proof that a Turing machine `tm` decides a language `L` with time and space bounds. -/ -def DecidesLanguageInTimeAndSpace +/-- A language is decidable in time `t` and space `s` if and only if its indicator function +is computable in time `t` and space `s`. -/ +def DecidableInTimeAndSpace {IOSymbol : Type} [Inhabited IOSymbol] - (tm : MultiTapeTM k Symbol) (L : Language IOSymbol) - (toMachineSymbol : IOSymbol ↪ Symbol) (t s : ℕ → ℕ) : Prop := - ComputesFunInTimeAndSpace tm (indicator L) toMachineSymbol t s + ComputableInTimeAndSpace (indicator L) t s /-- This lemma translates between the relational notion and the iterated step notion. The latter can be more convenient especially for deterministic machines as we have here. -/ @[scoped grind =] lemma relatesInSteps_iff_configs_eq - (tm : MultiTapeTM k Symbol) - (cfg₁ cfg₂ : tm.Cfg) + (tm : MultiTapeTM k Symbol State) + (cfg₁ cfg₂ : Cfg k Symbol State) (t : ℕ) : RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ tm.configs cfg₁ t = cfg₂ := by unfold configs @@ -357,13 +363,13 @@ lemma relatesInSteps_iff_configs_eq /-- The Turing machine `tm` halts after exactly `t` steps on input `input` if its state is `none` at step `t` and non-none at step `t - 1`. Note that every Turing machine hast to perform at least one step to halt. -/ -def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool := +def haltsAtStep (tm : MultiTapeTM k Symbol State) (input : List Symbol) (t : ℕ) : Bool := (tm.configs (tm.initCfg input) t).state.isNone && !(tm.configs (tm.initCfg input) (t - 1)).state.isNone /-- If a Turing machine halts, the time step is uniquely determined. -/ lemma halting_step_unique - {tm : MultiTapeTM k Symbol} + {tm : MultiTapeTM k Symbol State} {input : List Symbol} {t₁ t₂ : ℕ} (h_halts₁ : tm.haltsAtStep input t₁) From 024782242dff2d4bd215d8975837f998926d4a75 Mon Sep 17 00:00:00 2001 From: crei Date: Sun, 12 Jul 2026 23:05:50 +0200 Subject: [PATCH 49/51] Some initial space-related results. --- Cslib.lean | 2 + .../Turing/MultiTape/ConfigBound.lean | 282 +++++++++++++ .../Machines/Turing/MultiTape/Regular.lean | 398 ++++++++++++++++++ 3 files changed, 682 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Regular.lean diff --git a/Cslib.lean b/Cslib.lean index f7da441edc..cac89f6be7 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -36,7 +36,9 @@ public import Cslib.Computability.Languages.MyhillNerode public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage +public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Cslib.Computability.Machines.Turing.MultiTape.Regular public import Cslib.Computability.Machines.Turing.SingleTape.Defs public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic public import Cslib.Computability.Machines.Turing.SingleTape.NonDeterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean new file mode 100644 index 0000000000..37a0de6e5d --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Fintype.Prod +public import Mathlib.Data.Fintype.Option + +/-! +# A bound on the number of reachable configurations in bounded space + +For a deterministic multi-tape Turing machine that uses at most `s` cells of work-tape space, the +number of distinct configurations it can be in is bounded by an explicit function of `s` (and the +machine's parameters). This is the counting fact underlying, for instance, the collapse of very +small space classes and the inclusion `PSPACE ⊆ EXP`. + +We record everything about a configuration that can influence future behaviour *except* the +write-only output (which only grows and never affects the transition function). We provide two +versions: + +* `MultiTapeTM.card_image_storage_le` bounds the number of *storage configurations* — the control + state together with the work-tape contents and head positions, ignoring even the read-only input + head — by `storageBound k sym state s`. +* `MultiTapeTM.card_image_config_le` additionally tracks the input head position, giving the bound + `(n + 2) * storageBound k sym state s` on the number of full configurations of an input of + length `n`. + +## Design + +The key geometric facts (`MultiTapeTM.headPos_natAbs_le_space` and `MultiTapeTM.content_natAbs_le`) +are that, starting from the all-blank tapes with every head at `0` and moving by at most one cell +per step, a computation that has visited at most `s` work-tape cells keeps every head position and +every non-blank cell within the window `[-s, s]`. Hence a storage configuration reachable within +space `s` is determined by finite data over that window, giving the bound. Both counting theorems +share this geometry and the window encoding `MultiTapeTM.encStorage`, so the same machinery serves +the full-configuration bound needed for time-bounding space-bounded machines. +-/ + +@[expose] public section + +open Cslib + +namespace Turing.MultiTapeTM + +variable {k sym state : ℕ} + +def storageBound (k sym state s : ℕ) : ℕ := + (state + 1) * ((sym + 1) ^ (2 * s + 1) * (2 * s + 1)) ^ k + +def Cfg.storage {k : ℕ} {Sym St : Type*} (c : Cfg k Sym St) : + Option St × (Fin k → ℤ → Option Sym) × (Fin k → ℤ) := + (c.state, c.workTapes, c.workTapePos) + +/-- head position at step `t` on tape `i` -/ +def headPos (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) + (i : Fin k) (t : ℕ) : ℤ := (tm.configs (tm.initCfg input) t).workTapePos i + +def visited (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) + (i : Fin k) (t : ℕ) : Finset ℤ := (Finset.range (t+1)).image (fun t' => headPos tm input i t') + +variable (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) (i : Fin k) + +lemma headPos_zero : headPos tm input i 0 = 0 := rfl + +lemma headPos_step_le (t : ℕ) : |headPos tm input i (t+1) - headPos tm input i t| ≤ 1 := by + have := workTapePos_step_le (tm := tm) (tm.configs (tm.initCfg input) t) i + simpa [headPos, configs, Function.iterate_succ_apply'] using this + +lemma mem_visited_self (t : ℕ) : headPos tm input i t ∈ visited tm input i t := by + simp only [visited, Finset.mem_image, Finset.mem_range] + exact ⟨t, by omega, rfl⟩ + +lemma visited_mono {t t' : ℕ} (h : t ≤ t') : visited tm input i t ⊆ visited tm input i t' := by + intro z hz + simp only [visited, Finset.mem_image, Finset.mem_range] at hz ⊢ + obtain ⟨t'', ht'', rfl⟩ := hz + exact ⟨t'', by omega, rfl⟩ + +/-- Discrete intermediate value: every integer between `0` and the head position at step `t` has +been visited by step `t`. -/ +lemma Icc_subset_visited (t : ℕ) : + Finset.Icc (min 0 (headPos tm input i t)) (max 0 (headPos tm input i t)) + ⊆ visited tm input i t := by + induction t with + | zero => simpa [headPos_zero] using mem_visited_self tm input i 0 + | succ t ih => + intro z hz + simp only [Finset.mem_Icc] at hz + have hstep := headPos_step_le tm input i t + by_cases hin : min 0 (headPos tm input i t) ≤ z ∧ z ≤ max 0 (headPos tm input i t) + · exact visited_mono tm input i (Nat.le_succ t) (ih (Finset.mem_Icc.mpr hin)) + · have : z = headPos tm input i (t+1) := by + rw [abs_le] at hstep; omega + rw [this]; exact mem_visited_self tm input i (t+1) + + +lemma headPos_card (t : ℕ) : (headPos tm input i t).natAbs + 1 ≤ (visited tm input i t).card := by + have hsub := Icc_subset_visited tm input i t + have hcard := Finset.card_le_card hsub + rw [Int.card_Icc] at hcard + omega + +lemma spaceUsedByTape_eq_card_visited (T : ℕ) : + tm.spaceUsedByTape (tm.initCfg input) T i = (visited tm input i T).card := by + unfold spaceUsedByTape visited headPos + congr 1 + +lemma headPos_natAbs_le_space (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) + {t : ℕ} (ht : t ≤ T) : (headPos tm input i t).natAbs ≤ s := by + have h1 := headPos_card tm input i t + have h2 : (visited tm input i t).card ≤ (visited tm input i T).card := + Finset.card_le_card (visited_mono tm input i ht) + have h3 : (visited tm input i T).card = tm.spaceUsedByTape (tm.initCfg input) T i := + (spaceUsedByTape_eq_card_visited tm input i T).symm + have h4 : tm.spaceUsedByTape (tm.initCfg input) T i ≤ tm.spaceUsed (tm.initCfg input) T := + Finset.single_le_sum (f := fun i => tm.spaceUsedByTape (tm.initCfg input) T i) + (fun _ _ => Nat.zero_le _) (Finset.mem_univ i) + omega + + +lemma step_workTapes_mem (c : Cfg k (Fin sym) (Fin state)) (j : Fin k) (z : ℤ) + (h : (tm.step c).workTapes j z ≠ none) : + z = c.workTapePos j ∨ c.workTapes j z ≠ none := by + rw [step] at h + cases hst : c.state with + | none => simp only [hst] at h; right; exact h + | some q => + simp only [hst] at h + rcases hw : ((tm.tr q c.inputSymbol c.workTapeSymbols).workActions j).1 with _ | sy + · right; simpa only [hw] using h + · by_cases hz : z = c.workTapePos j + · exact Or.inl hz + · right; simp only [hw, Function.update_of_ne hz] at h; exact h + +lemma content_visited (t : ℕ) (z : ℤ) + (h : (tm.configs (tm.initCfg input) t).workTapes i z ≠ none) : z ∈ visited tm input i t := by + induction t with + | zero => exfalso; simp [configs, initCfg] at h + | succ t ih => + have hst : tm.configs (tm.initCfg input) (t+1) + = tm.step (tm.configs (tm.initCfg input) t) := by + rw [configs, configs, Function.iterate_succ_apply'] + rw [hst] at h + rcases step_workTapes_mem tm _ i z h with hz | hz + · rw [hz]; exact visited_mono tm input i (Nat.le_succ t) (mem_visited_self tm input i t) + · exact visited_mono tm input i (Nat.le_succ t) (ih hz) + +lemma content_natAbs_le (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) + {t : ℕ} (ht : t ≤ T) (z : ℤ) + (h : (tm.configs (tm.initCfg input) t).workTapes i z ≠ none) : z.natAbs ≤ s := by + have hzV := content_visited tm input i t z h + simp only [visited, Finset.mem_image, Finset.mem_range] at hzV + obtain ⟨t', ht', rfl⟩ := hzV + exact headPos_natAbs_le_space tm input i T s hs (by omega) + + + +/-- The finite "window" type into which storage configurations of space `≤ s` are encoded. -/ +abbrev Win (k sym state s : ℕ) : Type := + Option (Fin state) × (Fin k → ↥(Finset.Icc (-(s:ℤ)) s) → Option (Fin sym)) × + (Fin k → ↥(Finset.Icc (-(s:ℤ)) s)) + +/-- A storage tuple lies in the window of width `s`: all head positions and all non-blank cells +have absolute value `≤ s`. -/ +def WindowP (k sym state s : ℕ) + (x : Option (Fin state) × (Fin k → ℤ → Option (Fin sym)) × (Fin k → ℤ)) : Prop := + (∀ j, (x.2.2 j).natAbs ≤ s) ∧ (∀ j z, x.2.1 j z ≠ none → z.natAbs ≤ s) + +/-- Encoding of a storage tuple into the finite window type. -/ +noncomputable def encStorage (k sym state s : ℕ) + (x : Option (Fin state) × (Fin k → ℤ → Option (Fin sym)) × (Fin k → ℤ)) : + Win k sym state s := + (x.1, (fun j z => x.2.1 j z.1), + fun j => if h : x.2.2 j ∈ Finset.Icc (-(s:ℤ)) s then ⟨x.2.2 j, h⟩ else ⟨0, by simp⟩) + +lemma mem_Icc_of_natAbs_le {s : ℕ} {z : ℤ} (h : z.natAbs ≤ s) : + z ∈ Finset.Icc (-(s:ℤ)) s := by + simp only [Finset.mem_Icc]; omega + +/-- The encoding is injective on storage tuples satisfying the window predicate. -/ +lemma encStorage_injOn (k sym state s : ℕ) : + Set.InjOn (encStorage k sym state s) {x | WindowP k sym state s x} := by + rintro x ⟨hxp, hxc⟩ y ⟨hyp, hyc⟩ hxy + simp only [encStorage, Prod.mk.injEq] at hxy + obtain ⟨h1, h2, h3⟩ := hxy + refine Prod.ext h1 (Prod.ext ?_ ?_) + · funext j w + by_cases hw : w ∈ Finset.Icc (-(s:ℤ)) s + · simpa using congrFun (congrFun h2 j) ⟨w, hw⟩ + · have hwabs : s < w.natAbs := by simp only [Finset.mem_Icc, not_and, not_le] at hw; omega + have cx : x.2.1 j w = none := by by_contra hc; exact absurd (hxc j w hc) (by omega) + have cy : y.2.1 j w = none := by by_contra hc; exact absurd (hyc j w hc) (by omega) + rw [cx, cy] + · funext j + have hj := congrFun h3 j + rw [dif_pos (mem_Icc_of_natAbs_le (hxp j)), dif_pos (mem_Icc_of_natAbs_le (hyp j))] at hj + exact Subtype.ext_iff.mp hj + +lemma card_Win (k sym state s : ℕ) : + Fintype.card (Win k sym state s) = storageBound k sym state s := by + have hI : (Finset.Icc (-(s:ℤ)) s).card = 2 * s + 1 := by rw [Int.card_Icc]; omega + simp only [Win, Fintype.card_prod, Fintype.card_option, Fintype.card_fin, Fintype.card_fun, + Fintype.card_coe, hI, storageBound] + rw [← mul_pow] + + +lemma storage_windowP (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) + (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) {t : ℕ} (ht : t ≤ T) : + WindowP k sym state s (tm.configs (tm.initCfg input) t).storage := by + refine ⟨fun j => ?_, fun j z hz => ?_⟩ + · exact headPos_natAbs_le_space tm input j T s hs ht + · exact content_natAbs_le tm input j T s hs ht z hz + +open scoped Classical in +theorem card_image_storage_le (tm : MultiTapeTM k (Fin sym) (Fin state)) + (input : List (Fin sym)) (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) : + ((Finset.range (T + 1)).image + (fun t => (tm.configs (tm.initCfg input) t).storage)).card ≤ storageBound k sym state s := by + classical + rw [← card_Win k sym state s, ← Finset.card_univ] + refine Finset.card_le_card_of_injOn (encStorage k sym state s) + (fun x _ => Finset.mem_univ _) ?_ + refine Set.InjOn.mono ?_ (encStorage_injOn k sym state s) + intro x hx + simp only [Finset.coe_image, Set.mem_image, Finset.mem_coe, Finset.mem_range] at hx + obtain ⟨t, ht, rfl⟩ := hx + exact storage_windowP tm input T s hs (by omega) + + +lemma step_input (tm : MultiTapeTM k (Fin sym) (Fin state)) (c : Cfg k (Fin sym) (Fin state)) : + (tm.step c).input = c.input := by + rw [step]; cases c.state <;> rfl + +lemma configs_input (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) (t : ℕ) : + (tm.configs (tm.initCfg input) t).input = input := by + induction t with + | zero => rfl + | succ t ih => + have hstep : tm.configs (tm.initCfg input) (t + 1) + = tm.step (tm.configs (tm.initCfg input) t) := by + rw [configs, configs, Function.iterate_succ_apply'] + rw [hstep, step_input, ih] + +open scoped Classical in +theorem card_image_config_le (tm : MultiTapeTM k (Fin sym) (Fin state)) + (input : List (Fin sym)) (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) : + ((Finset.range (T + 1)).image (fun t => + ((tm.configs (tm.initCfg input) t).inputPos.val, + (tm.configs (tm.initCfg input) t).storage))).card + ≤ (input.length + 2) * storageBound k sym state s := by + classical + have hcard : (Finset.range (input.length + 2) ×ˢ + (Finset.univ : Finset (Win k sym state s))).card + = (input.length + 2) * storageBound k sym state s := by + rw [Finset.card_product, Finset.card_range, Finset.card_univ, card_Win] + rw [← hcard] + refine Finset.card_le_card_of_injOn (fun x => (x.1, encStorage k sym state s x.2)) ?_ ?_ + · intro x hx + simp only [Finset.coe_image, Set.mem_image, Finset.mem_coe, Finset.mem_range] at hx + obtain ⟨t, ht, rfl⟩ := hx + simp only [Finset.mem_coe, Finset.mem_product, Finset.mem_range, Finset.mem_univ, and_true] + have hlt := (tm.configs (tm.initCfg input) t).inputPos.isLt + have hlen : (tm.configs (tm.initCfg input) t).input.length = input.length := by + rw [configs_input] + omega + · intro x hx y hy hxy + simp only [Finset.coe_image, Set.mem_image, Finset.mem_coe, Finset.mem_range] at hx hy + obtain ⟨tx, htx, rfl⟩ := hx + obtain ⟨ty, hty, rfl⟩ := hy + simp only [Prod.mk.injEq] at hxy + have hst := encStorage_injOn k sym state s + (storage_windowP tm input T s hs (show tx ≤ T by omega)) + (storage_windowP tm input T s hs (show ty ≤ T by omega)) hxy.2 + exact Prod.ext hxy.1 hst + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean new file mode 100644 index 0000000000..c18fc331a2 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean @@ -0,0 +1,398 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Mathlib.Computability.DFA + +/-! +# Regular languages are decidable in linear time and zero space + +This file connects the notion of a regular language (as defined in Mathlib via a deterministic +finite automaton with finitely many states, `Language.IsRegular`) with the complexity classes of +multi-tape Turing machines defined in `Cslib.Computability.Machines.Turing.MultiTape.Deterministic`. + +The main result states that every regular language over a *finite* alphabet is decidable by a +multi-tape Turing machine *without work tapes* (`k = 0`). Such a machine uses zero space (by +`MultiTapeTM.spaceUsed_zero_tapes_eq_zero`) and only needs to sweep once over the input, so it +decides the language within `n + 2` steps. + +This is the "regular ⇒ `DSPACE(1)`" direction of the characterisation mentioned in the design notes +of the multi-tape Turing machine file: with the "cells visited" space measure, `DSPACE(1)` is +exactly the class of regular languages. + +A finite input alphabet (`Finite IOSymbol`) is necessary: a `k = 0` machine has a finite work +alphabet and finite state set, so it can only handle inputs over a finite alphabet. +-/ + +@[expose] public section + +open Cslib + +namespace Turing.MultiTapeTM + +/-! +## Relabeling the state type + +Relabeling only the state type of a Turing machine along an equivalence `State ≃ State'` does not +change its behaviour: the tapes, input and output are untouched, so the machine computes exactly the +same input/output pairs in the same time and space. This is straightforward because none of the +dependent structure of a configuration (the input tape and head position) mentions the state type. +-/ + +section CongrState + +variable {k : ℕ} {Symbol State State' : Type*} + +/-- Relabel the state of a configuration along `eState : State ↪ State'`. -/ +def Cfg.congrState (eState : State ↪ State') (cfg : Cfg k Symbol State) : Cfg k Symbol State' := + { cfg with state := cfg.state.map eState } + +/-- Relabel the state type of a Turing machine along an embedding `eState : State ↪ State'`. + +Only a left inverse of `eState` is needed: every state reachable during a computation is an +`eState`-image (the start state is `eState tm.q₀` and successors are `eState`-images), so the value +of `Function.invFun eState` outside the range of `eState` is irrelevant. -/ +noncomputable def congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) : + MultiTapeTM k Symbol State' := + haveI : Nonempty State := ⟨tm.q₀⟩ + { q₀ := eState tm.q₀ + tr := fun q input work => + let o := tm.tr (Function.invFun eState q) input work + { inputMove := o.inputMove + workActions := o.workActions + outS := o.outS + q' := o.q'.map eState } } + +/-- The step function commutes with state relabeling. -/ +@[simp] +lemma step_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State) : + (tm.congrState eState).step (cfg.congrState eState) + = (tm.step cfg).congrState eState := by + unfold step + cases hs : cfg.state with + | none => simp [Cfg.congrState, hs] + | some q => + haveI : Nonempty State := ⟨tm.q₀⟩ + have hinv : Function.invFun eState (eState q) = q := + Function.leftInverse_invFun eState.injective q + simp only [Cfg.congrState, hs, Option.map_some, congrState, hinv] + rfl + +/-- The configuration sequence commutes with state relabeling. -/ +lemma configs_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State) (t : ℕ) : + (tm.congrState eState).configs (cfg.congrState eState) t + = (tm.configs cfg t).congrState eState := by + unfold configs + induction t with + | zero => rfl + | succ t ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih, step_congrState] + +lemma initCfg_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) + (input : List Symbol) : + (tm.congrState eState).initCfg input = (tm.initCfg input).congrState eState := by + simp [initCfg, Cfg.congrState, congrState] + +/-- Relabeling the state type of a Turing machine along an embedding preserves its computations: +`tm.congrState eState` computes the same input/output pairs in the same time and space as `tm`. -/ +lemma computesInTimeAndSpace_congrState (eState : State ↪ State') + (tm : MultiTapeTM k Symbol State) (input output : List Symbol) (t s : ℕ) + (h : tm.ComputesInTimeAndSpace input output t s) : + (tm.congrState eState).ComputesInTimeAndSpace input output t s := by + obtain ⟨cfg, hstate, hout, hrel, hspace⟩ := h + refine ⟨cfg.congrState eState, ?_, ?_, ?_, ?_⟩ + · simp [Cfg.congrState, hstate] + · simpa [Cfg.congrState] using hout + · rw [relatesInSteps_iff_configs_eq] at hrel ⊢ + rw [initCfg_congrState, configs_congrState, hrel] + · rw [initCfg_congrState, ← hspace] + unfold spaceUsed spaceUsedByTape + simp only [configs_congrState] + rfl + +end CongrState + +/-! +## Relabeling the symbol type + +Relabeling the tape alphabet along an equivalence `Symbol ≃ Symbol'` transports a computation to +the relabeled input and output. Unlike state relabeling, this touches the dependent structure of a +configuration: the input head position lives in `Fin (input.length + 2)`, so mapping the input list +requires transporting the position along `List.length_map` via `Fin.cast`. +-/ + +section CongrSymbol + +variable {k : ℕ} {Symbol Symbol' State : Type*} + +/-- Relabel the tape alphabet of a configuration along `eSym : Symbol ≃ Symbol'`. -/ +def Cfg.congrSymbol (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : Cfg k Symbol' State where + state := cfg.state + input := cfg.input.map eSym + inputPos := Fin.cast (by rw [List.length_map]) cfg.inputPos + workTapes i z := (cfg.workTapes i z).map eSym + workTapePos := cfg.workTapePos + output := cfg.output.map eSym + +/-- Relabel the tape alphabet of a Turing machine along `eSym : Symbol ≃ Symbol'`. -/ +def congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) : + MultiTapeTM k Symbol' State where + q₀ := tm.q₀ + tr q input work := + let o := tm.tr q (input.map eSym.symm) (fun i => (work i).map eSym.symm) + { inputMove := o.inputMove + workActions := fun i => ((o.workActions i).1.map (Option.map eSym), (o.workActions i).2) + outS := o.outS.map eSym + q' := o.q' } + +@[simp] +lemma Cfg.congrSymbol_state (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).state = cfg.state := rfl + +@[simp] +lemma Cfg.congrSymbol_output (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).output = cfg.output.map eSym := rfl + +@[simp] +lemma Cfg.congrSymbol_workTapePos (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).workTapePos = cfg.workTapePos := rfl + +@[simp] +lemma Cfg.congrSymbol_input (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).input = cfg.input.map eSym := rfl + +@[simp] +lemma Cfg.congrSymbol_inputPos_val (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).inputPos.val = cfg.inputPos.val := rfl + +/-- The symbol read by the input head commutes with symbol relabeling. -/ +@[simp] +lemma Cfg.congrSymbol_inputSymbol (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : + (cfg.congrSymbol eSym).inputSymbol = cfg.inputSymbol.map eSym := by + have hz : ((cfg.congrSymbol eSym).inputPos = 0) ↔ (cfg.inputPos = 0) := by + simp only [Fin.ext_iff, Cfg.congrSymbol_inputPos_val, Fin.val_zero] + have he : ((cfg.congrSymbol eSym).inputPos = (cfg.congrSymbol eSym).input.length + 1) + ↔ (cfg.inputPos = cfg.input.length + 1) := by + simp only [Cfg.congrSymbol_inputPos_val, Cfg.congrSymbol_input, List.length_map] + unfold Cfg.inputSymbol + simp only [hz, he] + split_ifs with h1 h2 + · rfl + · rfl + · simp [Cfg.congrSymbol, List.getElem_map] + +/-- The symbol read by a work-tape head commutes with symbol relabeling. -/ +@[simp] +lemma Cfg.congrSymbol_workTapeSymbols (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) + (i : Fin k) : + (cfg.congrSymbol eSym).workTapeSymbols i = (cfg.workTapeSymbols i).map eSym := rfl + +/-- Moving the input head commutes with the `Fin.cast` coming from `List.length_map`. -/ +lemma moveInputPos_cast {n m : ℕ} (h : n + 2 = m + 2) (pos : Fin (n + 2)) (mv : SignType) : + moveInputPos (Fin.cast h pos) mv = Fin.cast h (moveInputPos pos mv) := by + obtain rfl : n = m := by omega + simp + +/-- The step function commutes with symbol relabeling. -/ +lemma step_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State) : + (tm.congrSymbol eSym).step (cfg.congrSymbol eSym) + = (tm.step cfg).congrSymbol eSym := by + have key : ∀ x : Option Symbol, Option.map (⇑eSym.symm) (Option.map (⇑eSym) x) = x := by + intro x; cases x <;> simp + cases hs : cfg.state with + | none => + have h1 : (tm.congrSymbol eSym).step (cfg.congrSymbol eSym) = cfg.congrSymbol eSym := by + rw [step]; simp [hs] + have h2 : tm.step cfg = cfg := by rw [step]; simp [hs] + rw [h1, h2] + | some q => + conv_lhs => rw [step] + conv_rhs => rw [step] + simp only [Cfg.congrSymbol_state, hs, Cfg.congrSymbol_inputSymbol, + Cfg.congrSymbol_workTapeSymbols, congrSymbol, key] + refine Cfg.ext ?_ ?_ (heq_of_eq ?_) ?_ ?_ ?_ + · rfl + · rfl + · exact moveInputPos_cast (by simp) _ _ + · funext i z + simp only [Cfg.congrSymbol] + rcases hw : (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i |>.1 with _ | s + · simp + · simp [Function.apply_update (fun _ (y : Option Symbol) => Option.map eSym y)] + · rfl + · rcases ho : (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).outS with _ | s + · simp [Cfg.congrSymbol] + · simp [Cfg.congrSymbol] + +/-- The configuration sequence commutes with symbol relabeling. -/ +lemma configs_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State) (t : ℕ) : + (tm.congrSymbol eSym).configs (cfg.congrSymbol eSym) t + = (tm.configs cfg t).congrSymbol eSym := by + unfold configs + induction t with + | zero => rfl + | succ t ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih, step_congrSymbol] + +lemma initCfg_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (input : List Symbol) : + (tm.congrSymbol eSym).initCfg (input.map eSym) = (tm.initCfg input).congrSymbol eSym := by + refine Cfg.ext ?_ ?_ (heq_of_eq ?_) ?_ ?_ ?_ <;> + simp [initCfg, Cfg.congrSymbol, congrSymbol, Fin.ext_iff] + +/-- Symbol relabeling preserves the space used, since it does not touch the tape head positions. -/ +lemma spaceUsed_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State) (t : ℕ) : + (tm.congrSymbol eSym).spaceUsed (cfg.congrSymbol eSym) t = tm.spaceUsed cfg t := by + unfold spaceUsed spaceUsedByTape + simp only [configs_congrSymbol, Cfg.congrSymbol_workTapePos] + +/-- Relabeling the tape alphabet of a Turing machine transports its computations along the +equivalence: `tm.congrSymbol eSym` computes the relabeled output from the relabeled input in the +same time and space as `tm`. -/ +lemma computesInTimeAndSpace_congrSymbol (eSym : Symbol ≃ Symbol') + (tm : MultiTapeTM k Symbol State) (input output : List Symbol) (t s : ℕ) + (h : tm.ComputesInTimeAndSpace input output t s) : + (tm.congrSymbol eSym).ComputesInTimeAndSpace (input.map eSym) (output.map eSym) t s := by + obtain ⟨cfg, hstate, hout, hrel, hspace⟩ := h + refine ⟨cfg.congrSymbol eSym, by simpa using hstate, by simp [hout], ?_, ?_⟩ + · rw [relatesInSteps_iff_configs_eq] at hrel ⊢ + rw [initCfg_congrSymbol, configs_congrSymbol, hrel] + · rw [initCfg_congrSymbol, spaceUsed_congrSymbol, hspace] + +end CongrSymbol + +/-! +## Simulating a deterministic finite automaton + +We build a `k = 0` (work-tape-free) multi-tape Turing machine `ofDFA M` that simulates a +deterministic finite automaton `M`, directly over the state type `σ` and alphabet `IOSymbol` of +`M`. The relabeling lemmas above are used later to encode `σ` and `IOSymbol` into `Fin`. +-/ + +open scoped Classical in +/-- +The `k = 0` multi-tape Turing machine simulating a deterministic finite automaton `M`, using `M`'s +state type as its state type and `M`'s alphabet as its tape alphabet. + +The machine has no work tapes. The input head starts on the first input cell and only ever moves +right, consuming one input symbol per step and advancing `M`'s state accordingly. When it reaches +the blank cell past the end of the input, it halts, outputting the default symbol iff `M`'s current +state is accepting. +-/ +noncomputable def ofDFA {IOSymbol : Type} [Inhabited IOSymbol] {σ : Type} (M : DFA IOSymbol σ) : + MultiTapeTM 0 IOSymbol σ where + q₀ := M.start + tr q input _ := + match input with + | some a => + { inputMove := SignType.pos, workActions := Fin.elim0, outS := none, + q' := some (M.step q a) } + | none => + { inputMove := 0, workActions := Fin.elim0, + outS := if q ∈ M.accept then some default else none, + q' := none } + +/-- Moving the input head right by one increments its position, if it stays within bounds. -/ +lemma moveInputPos_pos {n : ℕ} (pos : Fin (n + 2)) (h : pos.val + 1 < n + 2) : + (moveInputPos pos SignType.pos).val = pos.val + 1 := by + unfold moveInputPos + simp only [SignType.cast, Fin.toNat_eq_val, Fin.is_lt, ↓reduceDIte, Fin.eta] + rw [Fin.val_add_one_of_lt (by rw [Fin.lt_def, Fin.val_last]; omega)] + +/-- Invariant of the simulation: after `t ≤ |input|` steps, `ofDFA M` is in the state `M` would be +in after reading the first `t` input symbols, has produced no output, still holds the same input, +and its head is at position `1 + t`. -/ +lemma ofDFA_sim {IOSymbol : Type} [Inhabited IOSymbol] {σ : Type} (M : DFA IOSymbol σ) + (input : List IOSymbol) : + ∀ t, t ≤ input.length → + ((ofDFA M).configs ((ofDFA M).initCfg input) t).state = some (M.eval (input.take t)) ∧ + ((ofDFA M).configs ((ofDFA M).initCfg input) t).output = [] ∧ + ((ofDFA M).configs ((ofDFA M).initCfg input) t).input = input ∧ + ((ofDFA M).configs ((ofDFA M).initCfg input) t).inputPos.val = 1 + t := by + intro t + induction t with + | zero => intro _; refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [configs, ofDFA] + | succ t ih => + intro ht + obtain ⟨hst, hout, hin, hpos⟩ := ih (by omega) + have hlt : t < input.length := by omega + set c := (ofDFA M).configs ((ofDFA M).initCfg input) t with hc + have hlt' : t < c.input.length := by rw [hin]; exact hlt + have hsym : c.inputSymbol = some input[t] := by + have h := inputSymbolInner (cfg := c) t hpos hlt' + rw [h]; simp only [hin] + have hstep : (ofDFA M).configs ((ofDFA M).initCfg input) (t + 1) = (ofDFA M).step c := by + rw [hc, configs, configs, Function.iterate_succ_apply'] + rw [hstep] + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [step, hst, hsym]; simp only [ofDFA] + rw [List.take_succ_eq_append_getElem hlt, M.eval_append_singleton] + · rw [step, hst, hsym]; simp [ofDFA, hout] + · rw [step, hst, hsym]; simp [hin] + · rw [step, hst, hsym]; simp only [ofDFA] + rw [moveInputPos_pos c.inputPos (by omega)]; omega + +open scoped Classical in +/-- The Turing machine `ofDFA M` computes the indicator of the language of `M`: on input `input` it +halts after `|input| + 1` steps in zero space, outputting `[default]` iff `M` accepts `input`. -/ +lemma ofDFA_computes {IOSymbol : Type} [Inhabited IOSymbol] {σ : Type} (M : DFA IOSymbol σ) + (input : List IOSymbol) : + (ofDFA M).ComputesInTimeAndSpace input + (if M.eval input ∈ M.accept then [default] else []) (input.length + 1) 0 := by + obtain ⟨hst, hout, hin, hpos⟩ := ofDFA_sim M input input.length le_rfl + set c := (ofDFA M).configs ((ofDFA M).initCfg input) input.length with hc + have hlen : c.input.length = input.length := by rw [hin] + have hval : c.inputPos.val = c.input.length + 1 := by omega + have hsym : c.inputSymbol = none := by + unfold Cfg.inputSymbol + rw [dif_neg (by simp [Fin.ext_iff, hval]), dif_pos (by simp [hval])] + have hstep : (ofDFA M).configs ((ofDFA M).initCfg input) (input.length + 1) + = (ofDFA M).step c := by + rw [hc, configs, configs, Function.iterate_succ_apply'] + refine ⟨(ofDFA M).configs ((ofDFA M).initCfg input) (input.length + 1), ?_, ?_, ?_, ?_⟩ + · rw [hstep, step, hst, hsym]; simp [ofDFA] + · rw [hstep, step, hst, hsym]; simp only [ofDFA, hout, List.take_length] + by_cases hacc : M.eval input ∈ M.accept <;> simp [hacc] + · rw [relatesInSteps_iff_configs_eq] + · exact spaceUsed_zero_tapes_eq_zero _ _ rfl + +/-- +Every regular language over a finite alphabet is decidable by a multi-tape Turing machine without +work tapes (`k = 0`), hence in zero space, within `n + 2` steps. +-/ +theorem isRegular_decidableInTimeAndSpace + {IOSymbol : Type} [Inhabited IOSymbol] [Finite IOSymbol] + {L : Language IOSymbol} (hL : L.IsRegular) : + DecidableInTimeAndSpace L (fun n => n + 2) (fun _ => 0) := by + classical + obtain ⟨σ, _, M, hM⟩ := hL + have : Fintype IOSymbol := Fintype.ofFinite IOSymbol + refine ⟨0, Fintype.card IOSymbol, Fintype.card σ, (Fintype.equivFin IOSymbol).toEmbedding, + ((ofDFA M).congrState (Fintype.equivFin σ).toEmbedding).congrSymbol + (Fintype.equivFin IOSymbol), ?_⟩ + intro input + refine ⟨input.length + 1, Nat.le_succ _, 0, le_rfl, ?_⟩ + have heq : (if M.eval input ∈ M.accept then [default] else []) = indicator L input := by + have hiff : (M.eval input ∈ M.accept) ↔ (input ∈ L) := by rw [← hM, DFA.mem_accepts] + unfold indicator + exact if_congr hiff rfl rfl + have hcomp := ofDFA_computes M input + rw [heq] at hcomp + have h1 := computesInTimeAndSpace_congrState (Fintype.equivFin σ).toEmbedding (ofDFA M) + input (indicator L input) (input.length + 1) 0 hcomp + have h2 := computesInTimeAndSpace_congrSymbol (Fintype.equivFin IOSymbol) + ((ofDFA M).congrState (Fintype.equivFin σ).toEmbedding) + input (indicator L input) (input.length + 1) 0 h1 + simpa using h2 + +end Turing.MultiTapeTM From 11433071f2084f56e96a8bcd8a49fa2c89044559 Mon Sep 17 00:00:00 2001 From: crei Date: Sun, 12 Jul 2026 23:11:32 +0200 Subject: [PATCH 50/51] Unbundle configuration input and fix doc string. --- .../Turing/MultiTape/Deterministic.lean | 52 +++++++++---------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 9d1635d643..36382861aa 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -142,17 +142,17 @@ the resulting sequence of configurations and the initial configuration. -/ /-- -The configurations of a Turing machine consist of: +The configurations of a Turing machine is relative to the input of the machine and consist of: - an `Option`al state (or none for the halting state), -- `BiTape`s representing the tape contents and +- the position of the input head (shifted by one), +- the contents of the work tape, +- the positions of the work tape heads, - the output so far. -/ @[ext] -structure Cfg (k : ℕ) (Symbol State : Type*) where +structure Cfg (k : ℕ) (Symbol State : Type*) (input : List Symbol) where /-- the state of the TM (or none for the halting state) -/ state : Option State - /-- the input -/ - input : List Symbol /-- the position of the input head, shifted by one -/ inputPos : Fin (input.length + 2) /-- the work tapes -/ @@ -172,24 +172,24 @@ def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : Fin (n + 2) := if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ /-- The symbol currently under the input tape head. -/ -def Cfg.inputSymbol (cfg : Cfg k Symbol State) : Option Symbol := +def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol := if h₁ : cfg.inputPos = 0 then none - else if h₂ : cfg.inputPos = cfg.input.length + 1 then none - else cfg.input[cfg.inputPos.val - 1]'(by grind) + else if h₂ : cfg.inputPos = input.length + 1 then none + else input[cfg.inputPos.val - 1]'(by grind) @[simp] -lemma inputSymbolInner {cfg : Cfg k Symbol State} (p : ℕ) +lemma inputSymbolInner {cfg : Cfg k Symbol State input} (p : ℕ) (h₁ : cfg.inputPos.val = 1 + p) - (h₂ : p < cfg.input.length) : - cfg.inputSymbol = some cfg.input[p] := by + (h₂ : p < input.length) : + cfg.inputSymbol = some input[p] := by grind [Cfg.inputSymbol] /-- The symbol read by work tape `i`. -/ -def Cfg.workTapeSymbols (cfg : Cfg k Symbol State) (i : Fin k) : Option Symbol := +def Cfg.workTapeSymbols (cfg : Cfg k Symbol State input) (i : Fin k) : Option Symbol := cfg.workTapes i (cfg.workTapePos i) /-- The step function corresponding to a `MultiTapeTM`. -/ -def step (cfg : Cfg k Symbol State) : Cfg k Symbol State := +def step (cfg : Cfg k Symbol State input) : Cfg k Symbol State input := match cfg.state with -- in the halting state, we stay at the configuration | none => cfg @@ -197,7 +197,6 @@ def step (cfg : Cfg k Symbol State) : Cfg k Symbol State := let {inputMove, workActions, outS, q'} := tm.tr q cfg.inputSymbol cfg.workTapeSymbols { state := q', - input := cfg.input, inputPos := moveInputPos cfg.inputPos inputMove, workTapes i := match (workActions i).1 with | none => cfg.workTapes i @@ -210,23 +209,23 @@ def step (cfg : Cfg k Symbol State) : Cfg k Symbol State := /-- The initial configuration corresponding to an input string. -/ @[simp] -def initCfg (s : List Symbol) : Cfg k Symbol State := - ⟨some tm.q₀, s, 1, fun _ _ => none, fun _ => 0, []⟩ +def initCfg (input : List Symbol) : Cfg k Symbol State input := + ⟨some tm.q₀, 1, fun _ _ => none, fun _ => 0, []⟩ /-- The sequence of configurations of the Turing machine starting from `cfg`. If the Turing machine halts, it will stay at the halting configuration. -/ -def configs (cfg : Cfg k Symbol State) (t : ℕ) : Cfg k Symbol State := tm.step^[t] cfg +def configs (cfg : Cfg k Symbol State input) (t : ℕ) : Cfg k Symbol State input := tm.step^[t] cfg /-- Any number of steps run from a halting configuration results in the same configuration. -/ @[simp, scoped grind =] -lemma iter_step_eq_of_halt {cfg : Cfg k Symbol State} {n : ℕ} (h_halt : cfg.state = none) : +lemma iter_step_eq_of_halt {cfg : Cfg k Symbol State input} {n : ℕ} (h_halt : cfg.state = none) : tm.step^[n] cfg = cfg := by induction n with | zero => rfl | succ n ih => rw [Function.iterate_succ_apply', ih, step, h_halt] /-- The work-tape head moves by at most one cell in a single step. -/ -lemma workTapePos_step_le (c : Cfg k Symbol State) (i : Fin k) : +lemma workTapePos_step_le (c : Cfg k Symbol State input) (i : Fin k) : |(tm.step c).workTapePos i - c.workTapePos i| ≤ 1 := by unfold step cases hstate : c.state with @@ -244,25 +243,25 @@ section Space The number of work tape cells touched by the head of tape `i` in the computation starting from configuration `cfg` up to step `t`. -/ -def spaceUsedByTape (cfg : Cfg k Symbol State) (t : ℕ) (i : Fin k) : ℕ := +def spaceUsedByTape (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : ℕ := ((List.range (t + 1)).map fun t' => (tm.configs cfg t').workTapePos i).toFinset.card /-- The number of work tape cells touched by a computation starting from configuration `cfg` up to step `t`. -/ -def spaceUsed (cfg : Cfg k Symbol State) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i +def spaceUsed (cfg : Cfg k Symbol State input) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i /-- A zero-tape Turing machine uses zero space. -/ @[simp] -lemma spaceUsed_zero_tapes_eq_zero (cfg : Cfg k Symbol State) (t : ℕ) (h_zero : k = 0) : +lemma spaceUsed_zero_tapes_eq_zero (cfg : Cfg k Symbol State input) (t : ℕ) (h_zero : k = 0) : tm.spaceUsed cfg t = 0 := by unfold spaceUsed subst h_zero simp /-- The number of cells touched by a single work tape grows by at most one each step. -/ -lemma spaceUsedByTape_le (cfg : Cfg k Symbol State) (t : ℕ) (i : Fin k) : +lemma spaceUsedByTape_le (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : tm.spaceUsedByTape cfg t i ≤ t + 1 := by calc tm.spaceUsedByTape cfg t i @@ -272,7 +271,8 @@ lemma spaceUsedByTape_le (cfg : Cfg k Symbol State) (t : ℕ) (i : Fin k) : /-- The space used by a computation is bounded linearly by the number of steps. -/ -lemma spaceUsed_linear (cfg : Cfg k Symbol State) (t : ℕ) : tm.spaceUsed cfg t ≤ k * t + k := by +lemma spaceUsed_linear (cfg : Cfg k Symbol State input) (t : ℕ) : + tm.spaceUsed cfg t ≤ k * t + k := by calc tm.spaceUsed cfg t = ∑ i, (tm.spaceUsedByTape cfg t i) := by rfl _ ≤ ∑ i, (t + 1) := Finset.sum_le_sum (fun i _ => tm.spaceUsedByTape_le cfg t i) @@ -288,7 +288,7 @@ is defined by the `step` function, which maps a configuration to its next configuration. -/ @[scoped grind =] -def TransitionRelation (c₁ c₂ : Cfg k Symbol State) : Prop := tm.step c₁ = c₂ +def TransitionRelation (c₁ c₂ : Cfg k Symbol State input) : Prop := tm.step c₁ = c₂ /-- A proof that the Turing machine `tm` on input `input` outputs `output` in at most `t` steps and uses exactly `s` space. @@ -346,7 +346,7 @@ can be more convenient especially for deterministic machines as we have here. -/ @[scoped grind =] lemma relatesInSteps_iff_configs_eq (tm : MultiTapeTM k Symbol State) - (cfg₁ cfg₂ : Cfg k Symbol State) + (cfg₁ cfg₂ : Cfg k Symbol State input) (t : ℕ) : RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ tm.configs cfg₁ t = cfg₂ := by unfold configs From 4a149e205c99d4636d3a421c8cf3526e47b00f16 Mon Sep 17 00:00:00 2001 From: crei Date: Sun, 19 Jul 2026 16:09:34 +0200 Subject: [PATCH 51/51] updates --- .../Turing/MultiTape/ConfigBound.lean | 24 +---- .../Machines/Turing/MultiTape/Regular.lean | 101 +++++++----------- 2 files changed, 44 insertions(+), 81 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean index 37a0de6e5d..65dd1ba024 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -53,7 +53,7 @@ variable {k sym state : ℕ} def storageBound (k sym state s : ℕ) : ℕ := (state + 1) * ((sym + 1) ^ (2 * s + 1) * (2 * s + 1)) ^ k -def Cfg.storage {k : ℕ} {Sym St : Type*} (c : Cfg k Sym St) : +def Cfg.storage {k : ℕ} {Sym St : Type*} {input : List Sym} (c : Cfg k Sym St input) : Option St × (Fin k → ℤ → Option Sym) × (Fin k → ℤ) := (c.state, c.workTapes, c.workTapePos) @@ -124,7 +124,8 @@ lemma headPos_natAbs_le_space (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) omega -lemma step_workTapes_mem (c : Cfg k (Fin sym) (Fin state)) (j : Fin k) (z : ℤ) +lemma step_workTapes_mem {inp : List (Fin sym)} (c : Cfg k (Fin sym) (Fin state) inp) + (j : Fin k) (z : ℤ) (h : (tm.step c).workTapes j z ≠ none) : z = c.workTapePos j ∨ c.workTapes j z ≠ none := by rw [step] at h @@ -233,20 +234,6 @@ theorem card_image_storage_le (tm : MultiTapeTM k (Fin sym) (Fin state)) exact storage_windowP tm input T s hs (by omega) -lemma step_input (tm : MultiTapeTM k (Fin sym) (Fin state)) (c : Cfg k (Fin sym) (Fin state)) : - (tm.step c).input = c.input := by - rw [step]; cases c.state <;> rfl - -lemma configs_input (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) (t : ℕ) : - (tm.configs (tm.initCfg input) t).input = input := by - induction t with - | zero => rfl - | succ t ih => - have hstep : tm.configs (tm.initCfg input) (t + 1) - = tm.step (tm.configs (tm.initCfg input) t) := by - rw [configs, configs, Function.iterate_succ_apply'] - rw [hstep, step_input, ih] - open scoped Classical in theorem card_image_config_le (tm : MultiTapeTM k (Fin sym) (Fin state)) (input : List (Fin sym)) (T s : ℕ) (hs : tm.spaceUsed (tm.initCfg input) T ≤ s) : @@ -265,10 +252,7 @@ theorem card_image_config_le (tm : MultiTapeTM k (Fin sym) (Fin state)) simp only [Finset.coe_image, Set.mem_image, Finset.mem_coe, Finset.mem_range] at hx obtain ⟨t, ht, rfl⟩ := hx simp only [Finset.mem_coe, Finset.mem_product, Finset.mem_range, Finset.mem_univ, and_true] - have hlt := (tm.configs (tm.initCfg input) t).inputPos.isLt - have hlen : (tm.configs (tm.initCfg input) t).input.length = input.length := by - rw [configs_input] - omega + exact (tm.configs (tm.initCfg input) t).inputPos.isLt · intro x hx y hy hxy simp only [Finset.coe_image, Set.mem_image, Finset.mem_coe, Finset.mem_range] at hx hy obtain ⟨tx, htx, rfl⟩ := hx diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean index c18fc331a2..34d1236a1c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean @@ -49,7 +49,8 @@ section CongrState variable {k : ℕ} {Symbol State State' : Type*} /-- Relabel the state of a configuration along `eState : State ↪ State'`. -/ -def Cfg.congrState (eState : State ↪ State') (cfg : Cfg k Symbol State) : Cfg k Symbol State' := +def Cfg.congrState {input : List Symbol} (eState : State ↪ State') + (cfg : Cfg k Symbol State input) : Cfg k Symbol State' input := { cfg with state := cfg.state.map eState } /-- Relabel the state type of a Turing machine along an embedding `eState : State ↪ State'`. @@ -70,8 +71,8 @@ noncomputable def congrState (eState : State ↪ State') (tm : MultiTapeTM k Sym /-- The step function commutes with state relabeling. -/ @[simp] -lemma step_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) - (cfg : Cfg k Symbol State) : +lemma step_congrState {input : List Symbol} (eState : State ↪ State') + (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) : (tm.congrState eState).step (cfg.congrState eState) = (tm.step cfg).congrState eState := by unfold step @@ -85,8 +86,8 @@ lemma step_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol Sta rfl /-- The configuration sequence commutes with state relabeling. -/ -lemma configs_congrState (eState : State ↪ State') (tm : MultiTapeTM k Symbol State) - (cfg : Cfg k Symbol State) (t : ℕ) : +lemma configs_congrState {input : List Symbol} (eState : State ↪ State') + (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) (t : ℕ) : (tm.congrState eState).configs (cfg.congrState eState) t = (tm.configs cfg t).congrState eState := by unfold configs @@ -132,16 +133,14 @@ section CongrSymbol variable {k : ℕ} {Symbol Symbol' State : Type*} -/-- Relabel the tape alphabet of a configuration along `eSym : Symbol ≃ Symbol'`. -/ -def Cfg.congrSymbol (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : Cfg k Symbol' State where +def Cfg.congrSymbol {input : List Symbol} (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : Cfg k Symbol' State (input.map eSym) where state := cfg.state - input := cfg.input.map eSym inputPos := Fin.cast (by rw [List.length_map]) cfg.inputPos workTapes i z := (cfg.workTapes i z).map eSym workTapePos := cfg.workTapePos output := cfg.output.map eSym -/-- Relabel the tape alphabet of a Turing machine along `eSym : Symbol ≃ Symbol'`. -/ def congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) : MultiTapeTM k Symbol' State where q₀ := tm.q₀ @@ -152,35 +151,29 @@ def congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) : outS := o.outS.map eSym q' := o.q' } -@[simp] -lemma Cfg.congrSymbol_state (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : - (cfg.congrSymbol eSym).state = cfg.state := rfl +variable {input : List Symbol} -@[simp] -lemma Cfg.congrSymbol_output (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : +@[simp] lemma Cfg.congrSymbol_state (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : + (cfg.congrSymbol eSym).state = cfg.state := rfl +@[simp] lemma Cfg.congrSymbol_output (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : (cfg.congrSymbol eSym).output = cfg.output.map eSym := rfl - -@[simp] -lemma Cfg.congrSymbol_workTapePos (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : +@[simp] lemma Cfg.congrSymbol_workTapePos (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : (cfg.congrSymbol eSym).workTapePos = cfg.workTapePos := rfl - -@[simp] -lemma Cfg.congrSymbol_input (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : - (cfg.congrSymbol eSym).input = cfg.input.map eSym := rfl - -@[simp] -lemma Cfg.congrSymbol_inputPos_val (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : +@[simp] lemma Cfg.congrSymbol_inputPos_val (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : (cfg.congrSymbol eSym).inputPos.val = cfg.inputPos.val := rfl -/-- The symbol read by the input head commutes with symbol relabeling. -/ -@[simp] -lemma Cfg.congrSymbol_inputSymbol (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) : +@[simp] lemma Cfg.congrSymbol_inputSymbol (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : (cfg.congrSymbol eSym).inputSymbol = cfg.inputSymbol.map eSym := by have hz : ((cfg.congrSymbol eSym).inputPos = 0) ↔ (cfg.inputPos = 0) := by simp only [Fin.ext_iff, Cfg.congrSymbol_inputPos_val, Fin.val_zero] - have he : ((cfg.congrSymbol eSym).inputPos = (cfg.congrSymbol eSym).input.length + 1) - ↔ (cfg.inputPos = cfg.input.length + 1) := by - simp only [Cfg.congrSymbol_inputPos_val, Cfg.congrSymbol_input, List.length_map] + have he : ((cfg.congrSymbol eSym).inputPos = (input.map eSym).length + 1) + ↔ (cfg.inputPos = input.length + 1) := by + simp only [Cfg.congrSymbol_inputPos_val, List.length_map] unfold Cfg.inputSymbol simp only [hz, he] split_ifs with h1 h2 @@ -188,21 +181,18 @@ lemma Cfg.congrSymbol_inputSymbol (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbo · rfl · simp [Cfg.congrSymbol, List.getElem_map] -/-- The symbol read by a work-tape head commutes with symbol relabeling. -/ -@[simp] -lemma Cfg.congrSymbol_workTapeSymbols (eSym : Symbol ≃ Symbol') (cfg : Cfg k Symbol State) - (i : Fin k) : +@[simp] lemma Cfg.congrSymbol_workTapeSymbols (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) (i : Fin k) : (cfg.congrSymbol eSym).workTapeSymbols i = (cfg.workTapeSymbols i).map eSym := rfl -/-- Moving the input head commutes with the `Fin.cast` coming from `List.length_map`. -/ + lemma moveInputPos_cast {n m : ℕ} (h : n + 2 = m + 2) (pos : Fin (n + 2)) (mv : SignType) : moveInputPos (Fin.cast h pos) mv = Fin.cast h (moveInputPos pos mv) := by obtain rfl : n = m := by omega simp -/-- The step function commutes with symbol relabeling. -/ lemma step_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) - (cfg : Cfg k Symbol State) : + (cfg : Cfg k Symbol State input) : (tm.congrSymbol eSym).step (cfg.congrSymbol eSym) = (tm.step cfg).congrSymbol eSym := by have key : ∀ x : Option Symbol, Option.map (⇑eSym.symm) (Option.map (⇑eSym) x) = x := by @@ -218,8 +208,7 @@ lemma step_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol St conv_rhs => rw [step] simp only [Cfg.congrSymbol_state, hs, Cfg.congrSymbol_inputSymbol, Cfg.congrSymbol_workTapeSymbols, congrSymbol, key] - refine Cfg.ext ?_ ?_ (heq_of_eq ?_) ?_ ?_ ?_ - · rfl + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ · rfl · exact moveInputPos_cast (by simp) _ _ · funext i z @@ -232,9 +221,9 @@ lemma step_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol St · simp [Cfg.congrSymbol] · simp [Cfg.congrSymbol] -/-- The configuration sequence commutes with symbol relabeling. -/ + lemma configs_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) - (cfg : Cfg k Symbol State) (t : ℕ) : + (cfg : Cfg k Symbol State input) (t : ℕ) : (tm.congrSymbol eSym).configs (cfg.congrSymbol eSym) t = (tm.configs cfg t).congrSymbol eSym := by unfold configs @@ -246,19 +235,15 @@ lemma configs_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol lemma initCfg_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) (input : List Symbol) : (tm.congrSymbol eSym).initCfg (input.map eSym) = (tm.initCfg input).congrSymbol eSym := by - refine Cfg.ext ?_ ?_ (heq_of_eq ?_) ?_ ?_ ?_ <;> + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> simp [initCfg, Cfg.congrSymbol, congrSymbol, Fin.ext_iff] -/-- Symbol relabeling preserves the space used, since it does not touch the tape head positions. -/ lemma spaceUsed_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) - (cfg : Cfg k Symbol State) (t : ℕ) : + (cfg : Cfg k Symbol State input) (t : ℕ) : (tm.congrSymbol eSym).spaceUsed (cfg.congrSymbol eSym) t = tm.spaceUsed cfg t := by unfold spaceUsed spaceUsedByTape simp only [configs_congrSymbol, Cfg.congrSymbol_workTapePos] -/-- Relabeling the tape alphabet of a Turing machine transports its computations along the -equivalence: `tm.congrSymbol eSym` computes the relabeled output from the relabeled input in the -same time and space as `tm`. -/ lemma computesInTimeAndSpace_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) (input output : List Symbol) (t s : ℕ) (h : tm.ComputesInTimeAndSpace input output t s) : @@ -310,35 +295,30 @@ lemma moveInputPos_pos {n : ℕ} (pos : Fin (n + 2)) (h : pos.val + 1 < n + 2) : rw [Fin.val_add_one_of_lt (by rw [Fin.lt_def, Fin.val_last]; omega)] /-- Invariant of the simulation: after `t ≤ |input|` steps, `ofDFA M` is in the state `M` would be -in after reading the first `t` input symbols, has produced no output, still holds the same input, -and its head is at position `1 + t`. -/ +in after reading the first `t` input symbols, has produced no output, and its head is at position +`1 + t`. -/ lemma ofDFA_sim {IOSymbol : Type} [Inhabited IOSymbol] {σ : Type} (M : DFA IOSymbol σ) (input : List IOSymbol) : ∀ t, t ≤ input.length → ((ofDFA M).configs ((ofDFA M).initCfg input) t).state = some (M.eval (input.take t)) ∧ ((ofDFA M).configs ((ofDFA M).initCfg input) t).output = [] ∧ - ((ofDFA M).configs ((ofDFA M).initCfg input) t).input = input ∧ ((ofDFA M).configs ((ofDFA M).initCfg input) t).inputPos.val = 1 + t := by intro t induction t with - | zero => intro _; refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [configs, ofDFA] + | zero => intro _; refine ⟨?_, ?_, ?_⟩ <;> simp [configs, ofDFA] | succ t ih => intro ht - obtain ⟨hst, hout, hin, hpos⟩ := ih (by omega) + obtain ⟨hst, hout, hpos⟩ := ih (by omega) have hlt : t < input.length := by omega set c := (ofDFA M).configs ((ofDFA M).initCfg input) t with hc - have hlt' : t < c.input.length := by rw [hin]; exact hlt - have hsym : c.inputSymbol = some input[t] := by - have h := inputSymbolInner (cfg := c) t hpos hlt' - rw [h]; simp only [hin] + have hsym : c.inputSymbol = some input[t] := inputSymbolInner (cfg := c) t hpos hlt have hstep : (ofDFA M).configs ((ofDFA M).initCfg input) (t + 1) = (ofDFA M).step c := by rw [hc, configs, configs, Function.iterate_succ_apply'] rw [hstep] - refine ⟨?_, ?_, ?_, ?_⟩ + refine ⟨?_, ?_, ?_⟩ · rw [step, hst, hsym]; simp only [ofDFA] rw [List.take_succ_eq_append_getElem hlt, M.eval_append_singleton] · rw [step, hst, hsym]; simp [ofDFA, hout] - · rw [step, hst, hsym]; simp [hin] · rw [step, hst, hsym]; simp only [ofDFA] rw [moveInputPos_pos c.inputPos (by omega)]; omega @@ -349,10 +329,9 @@ lemma ofDFA_computes {IOSymbol : Type} [Inhabited IOSymbol] {σ : Type} (M : DFA (input : List IOSymbol) : (ofDFA M).ComputesInTimeAndSpace input (if M.eval input ∈ M.accept then [default] else []) (input.length + 1) 0 := by - obtain ⟨hst, hout, hin, hpos⟩ := ofDFA_sim M input input.length le_rfl + obtain ⟨hst, hout, hpos⟩ := ofDFA_sim M input input.length le_rfl set c := (ofDFA M).configs ((ofDFA M).initCfg input) input.length with hc - have hlen : c.input.length = input.length := by rw [hin] - have hval : c.inputPos.val = c.input.length + 1 := by omega + have hval : c.inputPos.val = input.length + 1 := by omega have hsym : c.inputSymbol = none := by unfold Cfg.inputSymbol rw [dif_neg (by simp [Fin.ext_iff, hval]), dif_pos (by simp [hval])]