diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index fefafe3e50..100fecf654 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/Languages/LambdaCalculus/ @chenson2018 +/Cslib/Algorithms/ @fmontesi @sorrachai @chenson2018 +/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 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: 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.lean b/Cslib.lean index 657d106c2e..cac89f6be7 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -11,10 +11,12 @@ 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 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 @@ -22,8 +24,10 @@ 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 public import Cslib.Computability.Languages.Congruences.BuchiCongruence public import Cslib.Computability.Languages.Congruences.RightCongruence public import Cslib.Computability.Languages.ExampleEventuallyZero @@ -32,7 +36,12 @@ 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.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 public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable public import Cslib.Computability.URM.Defs @@ -64,13 +73,19 @@ 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 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.Relation.Restriction public import Cslib.Foundations.Semantics.FLTS.Basic public import Cslib.Foundations.Semantics.FLTS.FLTSToLTS public import Cslib.Foundations.Semantics.FLTS.LTSToFLTS @@ -81,6 +96,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 @@ -116,6 +132,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 @@ -127,6 +144,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 @@ -139,8 +157,10 @@ 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.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/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/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 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..1be67c5d52 --- /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 (by rfl) _ _ 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/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/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/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean new file mode 100644 index 0000000000..65dd1ba024 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -0,0 +1,266 @@ +/- +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*} {input : List Sym} (c : Cfg k Sym St input) : + 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 {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 + 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) + + +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] + 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 + 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/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean new file mode 100644 index 0000000000..36382861aa --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -0,0 +1,395 @@ +/- +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 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 Mathlib.Data.Sign.Defs +public import Cslib.Foundations.Data.RelatesInSteps + +/-! +# Deterministic Multi-Tape Turing Machines + +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). + +## Design + +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, 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 + +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, the tapes and the output so far +* `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 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. + +* `MultiTapeTM.configs`: a sequence of configurations by execution step +* `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*][Sipser2013] + +-/ + +@[expose] public section + +open Cslib Relation + +namespace Turing + +variable {k : ℕ} {State Symbol : Type*} + +/-- The output of the transition function. -/ +structure TransitionOut (k : ℕ) (Symbol State : Type*) where + /-- The movement (attempt) of the input head. -/ + inputMove : SignType + /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/ + workActions : Fin k → (Option (Option Symbol)) × SignType + /-- An optional symbol to output. -/ + outS : Option Symbol + /-- The successor state or none to halt. -/ + q' : Option State + +/-- +A multi-tape Turing machine with `k` work tapes over the alphabet of `Option Symbol` (where `none` +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 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 + +namespace MultiTapeTM + +variable {tm : MultiTapeTM k Symbol State} + +section Cfg + +/-! +## Configurations of a Turing Machine + +This section defines the configurations of a Turing machine, +the step function that lets the machine transition from one configuration to the next, +the resulting sequence of configurations and the initial configuration. +-/ + +/-- +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), +- 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*) (input : List Symbol) where + /-- the state of the TM (or none for the halting state) -/ + state : Option State + /-- the position of the input head, shifted by one -/ + inputPos : Fin (input.length + 2) + /-- 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 + +/-- 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 : SignType) : Fin (n + 2) := + 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. -/ +def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol := + if h₁ : cfg.inputPos = 0 then none + 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 input} (p : ℕ) + (h₁ : cfg.inputPos.val = 1 + p) + (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 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 input) : Cfg k Symbol State input := + 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 cfg.inputSymbol cfg.workTapeSymbols + { + state := q', + inputPos := moveInputPos cfg.inputPos inputMove, + 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 + output := match outS with + | none => cfg.output + | some s => cfg.output ++ [s] + } + +/-- The initial configuration corresponding to an input string. -/ +@[simp] +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 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 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 input) (i : Fin k) : + |(tm.step c).workTapePos i - c.workTapePos i| ≤ 1 := by + unfold step + cases hstate : c.state with + | none => simp + | some q => + 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. -/ + +/-- +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 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 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 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 input) (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 computation is bounded linearly by the number of steps. +-/ +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) + _ = k * t + k := by simp [Nat.mul_succ] + +end Space + +open Cfg + +/-- +The `TransitionRelation` corresponding to a `MultiTapeTM k Symbol` +is defined by the `step` function, +which maps a configuration to its next configuration. +-/ +@[scoped grind =] +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. +Note that this does not require the alphabet or state set to be finite. -/ +def ComputesInTimeAndSpace + (tm : MultiTapeTM k Symbol State) + (input output : List Symbol) + (t s : ℕ) : Prop := + ∃ 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. It assumes an embedding function +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*} + (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 {Symbol : Type*} [Inhabited Symbol] (L : Language Symbol) : + List Symbol → List Symbol + | x => if x ∈ L then [default] else [] + +/-- 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] + (L : Language IOSymbol) + (t s : ℕ → ℕ) : Prop := + 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 State) + (cfg₁ cfg₂ : Cfg k Symbol State input) + (t : ℕ) : + 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 => + rw [RelatesInSteps.succ_iff, Function.iterate_succ_apply'] + constructor + · grind + · intro h_configs + use tm.step^[t] cfg₁ + grind + +/-- 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 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 State} + {input : List Symbol} + {t₁ 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 + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le h + cases d with + | zero => rfl + | succ d => + 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 + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean new file mode 100644 index 0000000000..34d1236a1c --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Regular.lean @@ -0,0 +1,377 @@ +/- +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 {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'`. + +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 {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 + 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 {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 + 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*} + +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 + 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 + +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' } + +variable {input : List Symbol} + +@[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 input) : + (cfg.congrSymbol eSym).workTapePos = cfg.workTapePos := rfl +@[simp] lemma Cfg.congrSymbol_inputPos_val (eSym : Symbol ≃ Symbol') + (cfg : Cfg k Symbol State input) : + (cfg.congrSymbol eSym).inputPos.val = cfg.inputPos.val := rfl + +@[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 = (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 + · rfl + · rfl + · simp [Cfg.congrSymbol, List.getElem_map] + +@[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 + + +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 + +lemma step_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM 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 + 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 ?_ ?_ ?_ ?_ ?_ + · 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] + + +lemma configs_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (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 ?_ ?_ ?_ ?_ ?_ <;> + simp [initCfg, Cfg.congrSymbol, congrSymbol, Fin.ext_iff] + +lemma spaceUsed_congrSymbol (eSym : Symbol ≃ Symbol') (tm : MultiTapeTM k Symbol State) + (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] + +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, 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).inputPos.val = 1 + t := by + intro t + induction t with + | zero => intro _; refine ⟨?_, ?_, ?_⟩ <;> simp [configs, ofDFA] + | succ t ih => + intro ht + 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 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 ⟨?_, ?_, ?_⟩ + · 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 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, hpos⟩ := ofDFA_sim M input input.length le_rfl + set c := (ofDFA M).configs ((ofDFA M).initCfg input) input.length with hc + 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])] + 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 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/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/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/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/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/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/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/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/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/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 diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean deleted file mode 100644 index 262ccbbd8c..0000000000 --- a/Cslib/Foundations/Data/Relation.lean +++ /dev/null @@ -1,872 +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.symm : Symmetric (MJoin r) := Relation.symmetric_join - -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 symmetric_join 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 - -theorem Commute.symmetric : Symmetric (@Commute α) := by - intro r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ - obtain ⟨_, _, _⟩ := h x_y₂ x_y₁ - grind - -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, symmetric] - 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/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/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..cd23f56847 --- /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 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 +| .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..f649ed5dd5 --- /dev/null +++ b/Cslib/Foundations/Relation/Defs.lean @@ -0,0 +1,157 @@ +/- +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 + +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 new file mode 100644 index 0000000000..c4976f1a6f --- /dev/null +++ b/Cslib/Foundations/Relation/Domain.lean @@ -0,0 +1,85 @@ +/- +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 + +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⟩ + +@[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..0773207004 --- /dev/null +++ b/Cslib/Foundations/Relation/Euclidean.lean @@ -0,0 +1,258 @@ +/- +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.Restriction +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} + +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⟩ + +instance [instRefl : Std.Refl r] : Serial r := refl_serial r instRefl + +namespace RightEuclidean + +variable [RightEuclidean r] + +/-- 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 + 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 := reflOn_cod.of_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 (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 (reflOn_cod.of_cod ab) + simpa [eq] + +theorem rightTotal_equiv (h : Relator.RightTotal r) : IsEquiv α r := by + 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 +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 := @reflOn_cod (r := r) + simp [Set.ReflOn] at this + 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 _ ⟨_, ab⟩ ↦ of_cod (reflOn_cod.of_cod ab) + +theorem rightTotal_cod : Relator.RightTotal (α := cod r) (β := cod r) r := + fun ⟨_, _, h⟩ => of_cod (reflOn_cod.of_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 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 + 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 := reflOn_dom.of_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 (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 (reflOn_dom.of_dom bc) + simpa [eq] + +theorem leftTotal_equiv (h : Relator.LeftTotal r) : IsEquiv α r := by + 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 +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 := @reflOn_dom (r := r) + simp [Set.ReflOn] at this + 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 _ ⟨_, ab⟩ ↦ of_dom (reflOn_dom.of_dom ab) + +theorem leftTotal_dom : Relator.LeftTotal (α := dom r) (β := dom r) r := + fun ⟨a, _, h⟩ => ⟨⟨a, of_dom h⟩, reflOn_dom.of_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/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 diff --git a/Cslib/Foundations/Semantics/LTS/Basic.lean b/Cslib/Foundations/Semantics/LTS/Basic.lean index 0f56865026..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 @@ -78,13 +79,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 +104,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 +148,44 @@ 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' + +/-- 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`. -/ @@ -167,6 +220,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 21ffd67eb5..d49a11a04b 100644 --- a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean +++ b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean @@ -1,15 +1,15 @@ /- 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.Relation.Domain public import Cslib.Foundations.Semantics.LTS.Simulation public import Cslib.Foundations.Semantics.LTS.TraceEq +public import Mathlib.Tactic.TFAE /-! # Bisimulation and Bisimilarity @@ -51,7 +51,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 +68,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 +83,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 +95,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 +129,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 +169,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 : @@ -162,67 +184,34 @@ 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) : - 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 +224,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 +244,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 +254,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 +269,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,109 +281,42 @@ 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' +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 /-! ## Relation to trace equivalence -/ /-- 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 - funext μs - simp only [eq_iff_iff] - 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 - 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 +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 .] @@ -444,356 +343,104 @@ 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 ⟨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 - -/-! ## Relation to simulation -/ - -/-- Any bisimulation is also a simulation. -/ -theorem IsBisimulation.isSimulation : IsBisimulation lts₁ lts₂ r → IsSimulation lts₁ lts₂ r := by - grind [IsSimulation] + ext s₁ s₂ + exact (Deterministic.bisim_tfae s₁ s₂).out 0 1 -/-- 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 +483,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 +507,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/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/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 9deb34d449..89643fdff6 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -23,16 +23,23 @@ 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. -/ 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,14 +51,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 + /-- 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 @@ -64,14 +74,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 @@ -82,31 +92,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 => @@ -119,20 +129,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/LTSCat/Basic.lean b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean index 9c40c3dcd5..d1e578db87 100644 --- a/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean +++ b/Cslib/Foundations/Semantics/LTS/LTSCat/Basic.lean @@ -35,11 +35,11 @@ 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). -/ -@[nolint checkUnivs] structure LTSCat : Type (max u v + 1) where /-- Type of states of an LTS -/ State : Type u 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 cf401de048..8aeb119d64 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 @@ -89,31 +89,40 @@ 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 + 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₁`. -/ @@ -160,6 +169,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_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} + {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_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. -/ +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..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,20 +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] +@[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] /-- 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] + 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 @@ -87,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 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/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/Languages/CombinatoryLogic/Confluence.lean b/Cslib/Languages/CombinatoryLogic/Confluence.lean index 6a0d20022a..9fc3c7d18b 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 @@ -92,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/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/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/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/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 405554ffb4..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. -/ @@ -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/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/CallByName.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean new file mode 100644 index 0000000000..a2be62e5a8 --- /dev/null +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/CallByName.lean @@ -0,0 +1,86 @@ +/- +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 M' N N' : Term Var} + +/-- 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 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/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean index f23f6c5083..bb064d21d8 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 @@ -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 84d5865c95..2f1f003602 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 -/ @@ -174,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 @@ -202,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 989142ac67..2412f2c109 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean @@ -92,11 +92,13 @@ 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 · 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/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean index ee2ee01d1c..2231d2b085 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 @@ -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 @@ -109,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 => @@ -128,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)) @@ -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 diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEtaConfluence.lean index 500febbb76..4defb563e1 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 @@ -33,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 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 diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean index 4cf0657415..91deb0e118 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 @@ -38,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 54b3b6c9ab..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 @@ -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 @@ -97,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) : @@ -110,17 +120,11 @@ 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 -/-- 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 ←] @@ -130,8 +134,8 @@ 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) : - m ⟦k ↜ x⟧⟦k ↝ n⟧ = m [x := n] := by +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 => have ⟨x', _⟩ := fresh_exists <| free_union [fv] Var @@ -142,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] diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean new file mode 100644 index 0000000000..e9cfe09ec1 --- /dev/null +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean @@ -0,0 +1,222 @@ +/- +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 and the Standardization Theorem + +## Reference + +* [B. Calisto, *Formalization in Coq of the Standardization Theorem for λ-calculus*][Calisto2022] + +-/ + +@[expose] public section + +set_option linter.unusedDecidableInType false + +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 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 + 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 + +/-- 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 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/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/Cslib/Logics/Modal/Basic.lean b/Cslib/Logics/Modal/Basic.lean index a627923676..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 @@ -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 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 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..90903a188a 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -1,15 +1,14 @@ -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.HasSubstitution +import CslibTests.ImportWithMathlib +import CslibTests.LTS +import CslibTests.LambdaCalculus +import CslibTests.MLL +import CslibTests.Reduction diff --git a/CslibTests/GrindLint.lean b/CslibTests/GrindLint.lean index 370e58db3a..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 @@ -73,14 +76,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 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 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 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 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 diff --git a/lake-manifest.json b/lake-manifest.json index 99fff5ea9d..4457b0aef1 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "rev": "d52d26fc2f36d4af5215e91892b33c96dc33915a", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "inputRev": "d52d26fc2f36d4af5215e91892b33c96dc33915a", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "744117af710b1c0400cd297c9ce91f8d0ad3a347", + "rev": "f3c7bd5061bd81b4480295c524d4f245c8b7e4e2", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "99c763c8a96d3d44fb4994e96eaa51ca4568449d", + "rev": "41f407a8e85b0fdc00910633a8f14754139b63f4", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,50 +45,50 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "1537e3fc7e680d64e06fe5fb95c4c9edee7941c2", + "rev": "e6518a674e62de322b8f79eebeda7bcae2a36bc3", "name": "proofwidgets", "manifestFile": "lake-manifest.json", - "inputRev": "v0.0.101", + "inputRev": "main", "inherited": true, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/aesop", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "7897ea6e5cfc6522d355083bdfa798377ab35e11", + "rev": "b5b9e2bb45ce91e4bc44eaa738c3a8910404ab82", "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", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "94346b7b49c36ae871639d1434232f057c193d60", + "rev": "7a62bd13860cd39ac98da16ffc8c24d601353f69", "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": "77d3cc514f987c1f42f2bbd8a8d56855012dc115", "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", "type": "git", "subDir": null, "scope": "leanprover", - "rev": "baf3e62fbb3502305076ca077e004aea78157c63", + "rev": "406ebb8c8e2f7e852a1b47764b42494022ce652c", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "v4.32.0-rc1", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 79a2ff1a8b..817e16581a 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,16 +18,14 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab" +rev = "d52d26fc2f36d4af5215e91892b33c96dc33915a" [[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" diff --git a/lean-toolchain b/lean-toolchain index e6a8c3c1fa..2694eb767c 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.31.0-rc2 +leanprover/lean4:v4.32.0-rc1 diff --git a/references.bib b/references.bib index 973371b652..7366ab0c2f 100644 --- a/references.bib +++ b/references.bib @@ -470,3 +470,32 @@ @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} +} + +@book{Sipser2013, + author = {Sipser, Michael}, + title = {Introduction to the Theory of Computation}, + edition = {3rd}, + publisher = {Cengage Learning}, + year = {2013} +} +@book{AroraBarak09, + author = {Sanjeev Arora and + Boaz Barak}, + title = {Computational Complexity - {A} Modern Approach}, + publisher = {Cambridge University Press}, + year = {2009}, +} + +@book{Papadimitriou94, + title={Computational Complexity}, + author={Papadimitriou, Christos H.}, + year={1994}, + publisher={Addison-Wesley}, + address={Reading, Massachusetts} +}