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/AUTHORS.md b/AUTHORS.md new file mode 100644 index 0000000000..8517b90603 --- /dev/null +++ b/AUTHORS.md @@ -0,0 +1,15 @@ +# CSLib Authors + +## Copyright and Authorship + +**Copyright in CSLib is held by the individual authors** who contributed to the code. + +Each file in CSLib includes a copyright header that lists the authors who contributed significantly to that specific file (in the opener and in the optional `Authors` field, when there are multiple significant authors). Examples of significant contributions are original creation, major refactoring, or important additions. + +To see more people who have contributed to CSLib and own copyright to parts of the codebase, please refer to its Git history (on a web browser, this can be accessed at ). + +**Note**: Git history may not always be fully comprehensive. In cases where code is co-written, commit messages and copyright headers in files may attribute additional authors beyond the single commit author. + +## Co-Authorship + +To ensure **all contributors are properly credited**, we strongly encourage the use of GitHub's [commit with multiple authors feature](https://docs.github.com/en/pull-requests/committing-changes-to-your-project/creating-and-editing-commits/creating-a-commit-with-multiple-authors) whenever code is co-written. This helps with maintaining accurate attribution in CSLib's Git history. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a2f8f88415..2526676ea0 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -101,7 +101,7 @@ instructions on how to run these locally. ## Pull Request Titles -It is required that pull request titles begun with one of the following categories followed by a +It is required that pull request titles begin with one of the following categories followed by a colon: `feat`, `fix`, `doc`, `style`, `refactor`, `test`, `chore`, `perf`. These may optionally be followed by a parenthetical containing what area of the library the PR is working on. @@ -125,8 +125,8 @@ 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. +There is also a test that [Cslib.lean](/Cslib.lean) imports all files. You can ensure this by +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..42b1c87af2 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,14 @@ 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.CanReachVia public import Cslib.Computability.Distributed.FLP.Consensus +public import Cslib.Computability.Distributed.FLP.FairScheduler +public import Cslib.Computability.Distributed.FLP.OnePseudoConsensus +public import Cslib.Computability.Distributed.FLP.PseudoConsensus +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 +40,14 @@ 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.Classes +public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Cslib.Computability.Machines.Turing.MultiTape.SpaceInTime +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas +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 @@ -58,19 +73,26 @@ public import Cslib.Foundations.Data.DecidableEqZero public import Cslib.Foundations.Data.FinFun.Basic public import Cslib.Foundations.Data.FinFun.Update public import Cslib.Foundations.Data.HasFresh +public import Cslib.Foundations.Data.Nat.BigO public import Cslib.Foundations.Data.Nat.Segment public import Cslib.Foundations.Data.OmegaSequence.Defs 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 +103,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 +139,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 +151,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,9 +164,12 @@ 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 +public import Cslib.MachineLearning.PACLearning.VersionSpaceLattice public import Cslib.Probability.PMF 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/Algorithms/README.md b/Cslib/Algorithms/README.md new file mode 100644 index 0000000000..9d946c476d --- /dev/null +++ b/Cslib/Algorithms/README.md @@ -0,0 +1,31 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Clark Barrett, Swarat Chaudhuri, Jim Grundy, Fabrizio Montesi, Leonardo de Moura, Alexandre Rademaker, Sorrachai Yingchareonthawornchai
+
+ +# Algorithms + +This directory hosts **algorithms and their properties**. These properties concern functional correctness, complexity, and other relevant results. The directory also includes dedicated facilities for reasoning about algorithms written in Lean. + +The broader aim is to develop a library of verified algorithms, both in Lean and in other languages formalised in CSLib. Accordingly, it is in scope to study algorithms implemented as Lean programs as well as algorithms expressed inside one of CSLib's [Languages](../Languages), depending on the purpose of the development. +All algorithms sit in a language-specific subdirectory depending on the language they are written in, like `Boole`, `Lean`, etc. + +## Principles + +### Synergies with languages and logics + +Important synergies are expected with both [Languages](../Languages) and [Logics](../Logics). Languages provide settings in which algorithms can be written and studied under formal semantics, while logics provide tools for specifying and proving their properties. + +One long-term aim is to support principled reasoning pipelines where algorithms are defined in a language, specified through logical notions, and verified inside shared semantic frameworks. + +### Dealing with optimisation + +Optimising an algorithm can make it harder to reason about it. When this happens, one can prove a relation (e.g., functional or behavioural) to a simpler, less optimised version, and then work by transferring results from it. +In doing this, we expect contributions to leverage Lean's and CSLib's common infrastructures whenever reasonable. + +## Plans and notes + +- We aim at developing a comprehensive library of verified algorithms, covering both Lean implementations and algorithms represented in other languages. +- We plan on expanding the infrastructure for proving properties of Lean algorithms, including correctness, complexity, and other forms of analysis. +- Reusable mathematical and semantic infrastructure should live elsewhere in CSLib when it is more general-purpose, so developments in this directory should integrate well with [Foundations](../Foundations), [Languages](../Languages), and [Logics](../Logics). 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/DA/ToNA.lean b/Cslib/Computability/Automata/DA/ToNA.lean index fe8c58f25c..27efa64c5c 100644 --- a/Cslib/Computability/Automata/DA/ToNA.lean +++ b/Cslib/Computability/Automata/DA/ToNA.lean @@ -60,7 +60,7 @@ theorem toNAFinAcc_language_eq {a : DA.FinAcc State Symbol} : #adaptation_note /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/ constructor - · simp_all [mem_language a xs, Accepts, toNAFinAcc, toNA, FLTS.toLTS_mtr] + · simp [mem_language a xs, Accepts, toNAFinAcc, toNA, FLTS.toLTS_mtr] · intro _ use a.start simp_all [Accepts, toNAFinAcc, toNA, FLTS.toLTS_mtr] @@ -82,7 +82,7 @@ theorem toNABuchi_language_eq {a : DA.Buchi State Symbol} : ext xs; constructor #adaptation_note /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/ - · simp_all [Accepts, language, toNABuchi] + · simp [Accepts, language, toNABuchi] · intro h use (a.run xs) split_ands 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..6b85893fde --- /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 + exact .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/NA/Hist.lean b/Cslib/Computability/Automata/NA/Hist.lean index ed2137efe6..716b76f9f5 100644 --- a/Cslib/Computability/Automata/NA/Hist.lean +++ b/Cslib/Computability/Automata/NA/Hist.lean @@ -57,7 +57,7 @@ theorem hist_run_exists {xs : ωSequence Symbol} {ss : ωSequence State} use ⟨fun n ↦ (ss n, makeHist start' tr' xs ss n)⟩ constructor · simp only [addHist] - grind only [Run, usr Set.mem_setOf_eq, = get_fun, = LTS.OmegaExecution, makeHist] + grind only [Run, usr Set.mem_ofPred_eq, = get_fun, = LTS.OmegaExecution, makeHist] · grind end Cslib.Automata.NA diff --git a/Cslib/Computability/Automata/NA/Loop.lean b/Cslib/Computability/Automata/NA/Loop.lean index 2b543787fe..b34985912e 100644 --- a/Cslib/Computability/Automata/NA/Loop.lean +++ b/Cslib/Computability/Automata/NA/Loop.lean @@ -215,10 +215,10 @@ theorem loop_language_eq [Inhabited Symbol] (h : ¬ language na = 0) : · obtain ⟨xl1, ⟨h_xl1, _⟩, xl2, h_xl2, rfl⟩ := h rw [← totalize_language_eq] at h_xl1 have := loop_fin_run_mtr h_xl1 - obtain ⟨s1, _, s2, _, _⟩ := h_xl2 + obtain ⟨s1, hs, s2, sa, sb⟩ := h_xl2 obtain ⟨rfl⟩ : s1 = inl () := by grind [finLoop, loop] obtain ⟨rfl⟩ : s2 = inl () := by grind [finLoop, loop] - refine ⟨inl (), ?_, inl (), ?_, LTS.MTr.comp _ this ?_⟩ <;> assumption + exact ⟨inl (), sa, inl (), hs, LTS.MTr.comp _ this sb⟩ · obtain ⟨rfl⟩ := (Language.mem_one xl).mp h refine ⟨inl (), ?_, inl (), ?_, ?_⟩ <;> grind [finLoop, loop] diff --git a/Cslib/Computability/Automata/NA/Pair.lean b/Cslib/Computability/Automata/NA/Pair.lean index 45beb89d7a..fa233e8068 100644 --- a/Cslib/Computability/Automata/NA/Pair.lean +++ b/Cslib/Computability/Automata/NA/Pair.lean @@ -15,7 +15,7 @@ public import Cslib.Computability.Languages.RegularLanguage namespace Cslib -open Language Automata Acceptor +open Cslib.Language Automata Acceptor variable {Symbol : Type*} {State : Type} @@ -50,7 +50,7 @@ theorem LTS.mem_pairViaLang {lts : LTS State Symbol} {via : Set State} /-- `LTS.pairViaLang via s t` is a regular language if there are only finitely many states. -/ @[simp] -theorem LTS.pairViaLang_regular [Inhabited Symbol] [Finite State] {lts : LTS State Symbol} +theorem LTS.pairViaLang_regular [Finite State] {lts : LTS State Symbol} {via : Set State} {s t : State} : (lts.pairViaLang via s t).IsRegular := by apply IsRegular.iSup grind [Language.IsRegular.mul, LTS.pairLang_regular] 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/Algorithm.lean b/Cslib/Computability/Distributed/FLP/Algorithm.lean index ccd90dbf65..8a858af0fe 100644 --- a/Cslib/Computability/Distributed/FLP/Algorithm.lean +++ b/Cslib/Computability/Distributed/FLP/Algorithm.lean @@ -202,13 +202,16 @@ theorem tr_diamond {ps : Set P} {x1 x2 : Action P M} {s s1 s2 : State P M S} (hx1 : DestIn ps x1) (hs1 : a.lts.Tr s x1 s1) (hx2 : DestIn psᶜ x2) (hs2 : a.lts.Tr s x2 s2) : ∃ s', a.lts.Tr s1 x2 s' ∧ a.lts.Tr s2 x1 s' := by - cases x1 <;> cases x2 <;> try grind [Algorithm.lts] - case some m1 m2 => - have hd : m1.dest ≠ m2.dest := by grind [DestIn] - obtain ⟨h_m1, rfl⟩ := hs1 - obtain ⟨h_m2, rfl⟩ := hs2 - simp only [Algorithm.lts, exists_eq_right_right] - grind [recvMsg_comm (a := a) hd h_m1 h_m2] + cases x1 <;> cases x2 + · grind [Algorithm.lts] + · grind [Algorithm.lts] + · grind [Algorithm.lts] + · case some m1 m2 => + have hd : m1.dest ≠ m2.dest := by grind [DestIn] + obtain ⟨h_m1, rfl⟩ := hs1 + obtain ⟨h_m2, rfl⟩ := hs2 + simp only [Algorithm.lts, exists_eq_right_right] + grind [recvMsg_comm (a := a) hd h_m1 h_m2] /-- A message that is in-flight stays in-flight as long as it is not received (finite execution version). -/ diff --git a/Cslib/Computability/Distributed/FLP/CanReachVia.lean b/Cslib/Computability/Distributed/FLP/CanReachVia.lean new file mode 100644 index 0000000000..44a538e7a1 --- /dev/null +++ b/Cslib/Computability/Distributed/FLP/CanReachVia.lean @@ -0,0 +1,144 @@ +/- +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.Algorithm + +/-! # Reachability via a subset of processes + +This file develops a theory of reachability via a subset of processes, that is, what happens +when only a subset of processes can receive messages and take steps. It culminates with two +"diamond properties" of this more refined reachability relation. + +## References + +* [Volzer2004] H. Völzer, A constructive proof for FLP. + Information Processing Letters 92(2), (October 2004) 83–87. +-/ + +@[expose] public section + +namespace Cslib.FLP + +open Function Set Sum Multiset + +variable {P M S : Type*} [DecidableEq P] [DecidableEq M] + +/-- `a.CanReachVia ps s1 s2` means that state `s2` is reachable from state `s1` via a finite +execution of algorithm `a` in which all messages received have destinations in `ps`. -/ +def Algorithm.CanReachVia (a : Algorithm P M S) (ps : Set P) (s1 s2 : State P M S) : Prop := + ∃ xs, a.lts.MTr s1 xs s2 ∧ xs.Forall (DestIn ps) + +/-- `InpEqOn ps inp1 inp2` means that inputs `inp1` and `inp2` agree on all processes in `ps`. -/ +def InpEqOn (ps : Set P) (inp1 inp2 : P → Bool) : Prop := + ∀ p, p ∈ ps → inp1 p = inp2 p + +namespace CanReachVia + +variable {a : Algorithm P M S} + +/-- `a.CanReachVia ps s s'` implies `a.lts.CanReach s s'` for any `ps`. -/ +theorem canReach {ps : Set P} {s s' : State P M S} + (h : a.CanReachVia ps s s') : a.lts.CanReach s s' := by + obtain ⟨xs, h_mtr, _⟩ := h + use xs + +/-- `a.CanReachVia ps s s` is true for any `ps`. -/ +theorem refl (ps : Set P) (s : State P M S) : + a.CanReachVia ps s s := by + use [] + simp + +/-- Extending `CanReachVia` on the left by one step. -/ +theorem stepL {ps : Set P} {x : Action P M} {s1 s2 s3 : State P M S} + (hx : DestIn ps x) (h1 : a.lts.Tr s1 x s2) (h2 : a.CanReachVia ps s2 s3) : + a.CanReachVia ps s1 s3 := by + obtain ⟨xs, _, _⟩ := h2 + use (x :: xs) + grind [LTS.MTr.stepL, List.forall_cons] + +private lemma diamond_helper + {ps : Set P} {x : Action P M} {s s1 s2 : State P M S} + (hx : DestIn ps x) (h1 : a.lts.Tr s x s1) (h2 : a.CanReachVia psᶜ s s2) : + ∃ s', a.CanReachVia psᶜ s1 s' ∧ a.lts.Tr s2 x s' := by + obtain ⟨xs2, h_mtr2, h_via2⟩ := h2 + induction h_mtr2 generalizing s1 + case refl s => + use s1 + simp_all [refl] + case stepL s y t2 ys s2 h_tr2 h_mtr2 h_ind => + obtain ⟨h_y, h_ys⟩ := (List.forall_cons (DestIn psᶜ) y ys).mp h_via2 + obtain ⟨t1, h_tr1, h_tr21⟩ := Algorithm.tr_diamond hx h1 h_y h_tr2 + obtain ⟨s', h_crv1, h_tr2'⟩ := h_ind h_tr21 h_ys + use s', ?_, h_tr2' + exact stepL h_y h_tr1 h_crv1 + +/-- A diamond property for `CanReachVia`. This theorem formalizes Proposition 1 of [Volzer2004]. -/ +theorem diamond {ps : Set P} {s s1 s2 : State P M S} + (h1 : a.CanReachVia ps s s1) (h2 : a.CanReachVia psᶜ s s2) : + ∃ s', a.CanReachVia psᶜ s1 s' ∧ a.CanReachVia ps s2 s' := by + obtain ⟨xs1, h_mtr1, h_via1⟩ := h1 + induction h_mtr1 generalizing s2 + case refl s => + use s2 + simp_all [refl] + case stepL s x t1 xs s1 h_tr1 h_mtr1 h_ind => + obtain ⟨h_x, h_xs⟩ := (List.forall_cons (DestIn ps) x xs).mp h_via1 + obtain ⟨t2, h_crv, h_tr2⟩:= diamond_helper h_x h_tr1 h2 + obtain ⟨s', h_crv1, h_crv2⟩ := h_ind h_crv h_xs + use s', h_crv1 + exact stepL h_x h_tr2 h_crv2 + +/-- If inputs `inp1` and `inp2` agree on all processes in `ps` and state `s` is reachable from +the initial state determined by `inp1` by receiving messages with destinations in `ps` only, +then there exists a state `s2` that agrees with `s` on the states of all processes and is +reachable from the initial state determined by `inp2` by receiving messages with destinations +in `ps` only. This theorem is implicitly used in the proof of Lemma 1 of [Volzer2004]. -/ +theorem subset_inp [Fintype P] {ps : Set P} {inp1 inp2 : P → Bool} {s1 : State P M S} + (he : InpEqOn ps inp1 inp2) (hr : a.CanReachVia ps (a.start inp1) s1) : + ∃ s2, a.CanReachVia ps (a.start inp2) s2 ∧ s2.proc = s1.proc := by + obtain ⟨xs, h_mtr, h_xs⟩ := hr + obtain ⟨ss, _, h_ss0, _, _⟩ := LTS.Execution.of_mTr h_mtr + suffices h_inv : ∀ k, (_ : k ≤ xs.length) → + ∃ s2, a.lts.MTr (a.start inp2) (xs.take k) s2 ∧ s2.proc = ss[k].proc ∧ + ∀ m, m.dest ∈ ps → s2.msgs.count m = ss[k].msgs.count m by + obtain ⟨s2, _⟩ := h_inv xs.length (by simp) + use s2, ?_, by grind + use xs, by grind + intro k h_k + induction k + case zero => + use a.start inp2, by grind [LTS.MTr], by grind [Algorithm.start] + intro m h_m + simp only [h_ss0, Algorithm.start, count_map, Message.ext_iff] + congr + grind [InpEqOn] + case succ k h_ind => + obtain ⟨s2, h_mtr, h_proc, h_msgs⟩ := h_ind (by grind) + obtain (_ | ⟨m, h_m⟩) := Option.eq_none_or_eq_some xs[k] + · use s2, ?_, ?_, ?_ + · have h_tr : a.lts.Tr s2 xs[k] s2 := by grind [Algorithm.lts] + grind [List.take_add_one, LTS.MTr.stepR (lts := a.lts) h_mtr h_tr] + · grind [Algorithm.tr_none] + · grind [Algorithm.tr_none] + · obtain ⟨_, h_k1⟩ : m ∈ ss[k].msgs ∧ ss[k + 1] = a.recvMsg m ss[k] := by grind [Algorithm.lts] + use a.recvMsg m s2, ?_, ?_, ?_ + · have := List.forall_mem_iff_forall_getElem.mp <| List.forall_iff_forall_mem.mp h_xs + have h_tr : a.lts.Tr s2 xs[k] (a.recvMsg m s2) := by + grind [Algorithm.lts, DestIn, one_le_count_iff_mem] + grind [List.take_add_one, LTS.MTr.stepR (lts := a.lts) h_mtr h_tr] + · grind [Algorithm.recvMsg] + · intro m1 h_m1 + by_cases h1 : m1 = m + · simp [h_k1, Algorithm.recvMsg, h_proc, h1, count_erase_self] + grind + · simp [h_k1, Algorithm.recvMsg, h_proc, count_erase_of_ne h1] + grind + +end CanReachVia + +end Cslib.FLP 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/FairScheduler.lean b/Cslib/Computability/Distributed/FLP/FairScheduler.lean new file mode 100644 index 0000000000..9e9d622c58 --- /dev/null +++ b/Cslib/Computability/Distributed/FLP/FairScheduler.lean @@ -0,0 +1,250 @@ +/- +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.InfOcc +public import Mathlib.Data.List.ReduceOption + +/-! # Machinery for constructing infinite fair executions + +The main goal of this file is to define a `fairScheduler` that, given a function `d` +of type `DeliverMsg`, a state predicate `q`, and a state `s0` of an algorithm `a`, +constructs an infinite execution of `a` starting from state `s0` in which all processes +from a set `ps` are fair and `q` is true infinitely often. With additional assumptions, +we may also want to require that all actions in the infinite execution satisfy an action +predicate `r`. +-/ + +@[expose] public section + +namespace Cslib.FLP + +open Function Set Multiset Filter ωSequence + +variable {P M S : Type*} [DecidableEq P] [DecidableEq M] + +/-- Given a state `s` and a message `m`, a function `d` of type `DeliverMsg` is supposed to +return `(xs, t)` where `xs` is a finite execution from `s` to `t` in which `m` is delivered. -/ +def DeliverMsg P M S := State P M S → Message P M → List (Action P M) × State P M S + +/-- `d.ForallActions r` requires that all actions returned by `d` satisfy `r`. -/ +def DeliverMsg.ForallActions (d : DeliverMsg P M S) (r : Action P M → Prop) : Prop := + ∀ s m, (d s m).fst.Forall r + +/-- `d.foldList s ml ms` uses `d` to deliver all messages that are in `ml` but not in `ms` from +state `s`. Note that if a message `m` in `ml` is delivered during the delivery of an earlier +message, `m` is added to `ms` so that it is not processed again. -/ +def DeliverMsg.foldList (d : DeliverMsg P M S) (s : State P M S) : + List (Message P M) → Finset (Message P M) → List (Action P M) × State P M S + | [], _ => ([], s) + | m :: ml, ms => + if m ∈ ms then + d.foldList s ml ms + else + let (xl1, s1) := d s m + let ms' := ms ∪ xl1.reduceOption.toFinset + let (xl2, s2) := d.foldList s1 ml ms' + (xl1 ++ xl2, s2) + +open scoped Classical in +/-- `d.scheduleMsgs ps s` schedules and delivers all messages which are in-flight in state `s` +and have destinations in `ps` in some order (as determined by choice). If no such message exists, +then the the stuttering step is taken. -/ +noncomputable def DeliverMsg.scheduleMsgs (d : DeliverMsg P M S) (ps : Set P) + (s : State P M S) : List (Action P M) × State P M S := + let ms := s.msgs.filter (fun m ↦ m.dest ∈ ps) + if ms = 0 then + ([none], s) + else + d.foldList s ms.toList ∅ + +namespace DeliverMsg + +variable {d : DeliverMsg P M S} + +/-- If `d.ForallActions r`, then `d.foldList s ml ms` can only use actions satisfying `r`. -/ +theorem foldList_forallActions {r : Action P M → Prop} + (s : State P M S) (ml : List (Message P M)) (ms : Finset (Message P M)) + (h : d.ForallActions r) : (d.foldList s ml ms).fst.Forall r := by + induction ml generalizing s ms <;> + grind [DeliverMsg.foldList, DeliverMsg.ForallActions, List.Forall, List.forall_append] + +end DeliverMsg + +/-- Starting from state `s0`, `a.fairSchedular d ps s0` constructs an infinite sequence of +finite executions of `a` by repeatedly applying `d.scheduleMsgs ps`. -/ +noncomputable def Algorithm.fairScheduler (a : Algorithm P M S) (d : DeliverMsg P M S) (ps : Set P) + (s0 : State P M S) : ℕ → List (Action P M) × State P M S + | 0 => ([], s0) + | k + 1 => d.scheduleMsgs ps (a.fairScheduler d ps s0 k).snd + +/-- The infinite sequence of states forming the end states of the finite executions constructed +by `Algorithm.fairScheduler`. -/ +noncomputable def Algorithm.fairSegEnds (a : Algorithm P M S) (d : DeliverMsg P M S) + (ps : Set P) (s0 : State P M S) : ωSequence (State P M S) := + ωSequence.mk (fun k ↦ (a.fairScheduler d ps s0 k).snd) + +/-- The infinite sequence of finite action sequences from the finite executions constructed +by `Algorithm.fairScheduler`. -/ +noncomputable def Algorithm.fairSegActions (a : Algorithm P M S) (d : DeliverMsg P M S) + (ps : Set P) (s0 : State P M S) : ωSequence (List (Action P M)) := + (ωSequence.mk (fun k ↦ (a.fairScheduler d ps s0 k).fst)).tail + +/-- `a.FairDeliverMsg d ps q` says that for any state `s` of `a` satisfying `q` and +any message `m` which is in-flight in `s` and whose destination is in `ps`, `d s m` +produces a legal finite execution of `a` in which `m` is delivered and which ends in +a state satisfying `q` again. -/ +def Algorithm.FairDeliverMsg (a : Algorithm P M S) (d : DeliverMsg P M S) + (ps : Set P) (q : State P M S → Prop) : Prop := + ∀ s m, m ∈ s.msgs ∧ m.dest ∈ ps ∧ q s → + let (xl, t) := d s m + a.lts.MTr s xl t ∧ some m ∈ xl ∧ q t + +namespace FairScheduler + +variable {a : Algorithm P M S} + +/-- Re-stating the definition of `Algorithm.fairScheduler` as a mutual recursion of +`Algorithm.fairSegEnds` and `Algorithm.fairSegActions`. -/ +theorem fairScheduler_init {d : DeliverMsg P M S} (ps : Set P) (s0 : State P M S) : + a.fairSegEnds d ps s0 0 = s0 := by + grind [Algorithm.fairScheduler, Algorithm.fairSegEnds] + +/-- Re-stating the definition of `Algorithm.fairScheduler` as a mutual recursion of +`Algorithm.fairSegEnds` and `Algorithm.fairSegActions`. -/ +theorem fairScheduler_step {d : DeliverMsg P M S} (ps : Set P) (s0 : State P M S) (k : ℕ) : + d.scheduleMsgs ps (a.fairSegEnds d ps s0 k) = + (a.fairSegActions d ps s0 k, a.fairSegEnds d ps s0 (k + 1)) := by + grind [Algorithm.fairScheduler, Algorithm.fairSegEnds, Algorithm.fairSegActions] + +/-- If `d.ForallActions r`, then `a.fairSegActions d ps s0` can only use actions satisfying `r`. -/ +theorem fairSeg_forallActions {d : DeliverMsg P M S} {r : Action P M → Prop} + (ps : Set P) (s0 : State P M S) (k : ℕ) (ha : d.ForallActions r) (hn : r none) : + (a.fairSegActions d ps s0 k).Forall r := by + grind [fairScheduler_step (a := a) (d := d) ps s0 k, + DeliverMsg.scheduleMsgs, DeliverMsg.foldList_forallActions, List.Forall] + +/-- The correctness of `d.foldList s ml ms` under the assumption `a.FairDeliverMsg d ps q`. -/ +theorem fairDeliverMsg_foldList {d : DeliverMsg P M S} {ps : Set P} {q : State P M S → Prop} + (hd : a.FairDeliverMsg d ps q) (s : State P M S) + (ml : List (Message P M)) (ms : Finset (Message P M)) + (hs : q s ∧ ∀ m, m ∈ ml → ¬ m ∈ ms → m ∈ s.msgs ∧ m.dest ∈ ps) : + let (xl, t) := d.foldList s ml ms + a.lts.MTr s xl t ∧ q t ∧ ∀ m, m ∈ ml → ¬ m ∈ ms → some m ∈ xl := by + induction ml generalizing s ms + case nil => grind [DeliverMsg.foldList, LTS.MTr] + case cons m ml h_ind => + by_cases h_m : m ∈ ms + · grind [DeliverMsg.foldList] + · let xl1 := (d s m).fst + let s1 := (d s m).snd + let ms' := ms ∪ xl1.reduceOption.toFinset + have (m' : Message P M) : m' ∈ xl1.reduceOption.toFinset ↔ some m' ∈ xl1 := by + simp [List.mem_toFinset, List.reduceOption_mem_iff] + have (m' : Message P M) : m' ∈ ml → ¬ m' ∈ ms' → m' ∈ s1.msgs := by + grind [Algorithm.FairDeliverMsg, Algorithm.mTr_notRcvd_enabled] + grind [DeliverMsg.foldList, Algorithm.FairDeliverMsg, LTS.MTr.comp] + +/-- The correctness of `d.scheduleMsgs ps s` under the assumption `a.FairDeliverMsg d ps q`. -/ +theorem fairDeliverMsg_scheduleMsgs {d : DeliverMsg P M S} {ps : Set P} {q : State P M S → Prop} + (hd : a.FairDeliverMsg d ps q) (s : State P M S) (hs : q s) : + let xl := (d.scheduleMsgs ps s).fst + let t := (d.scheduleMsgs ps s).snd + q t ∧ a.lts.MTr s xl t ∧ xl.length > 0 ∧ ∀ m, m ∈ s.msgs → m.dest ∈ ps → some m ∈ xl := by + classical + intro xl t + let ms := s.msgs.filter (fun m ↦ m.dest ∈ ps) + by_cases h_ms : ms = 0 + · have h1 : xl = [none] ∧ t = s := by grind [DeliverMsg.scheduleMsgs] + simp [ms, eq_zero_iff_forall_notMem] at h_ms + simp only [h1, hs, List.length_cons, List.length_nil, zero_add, Order.lt_one_iff, true_and] + split_ands + · apply LTS.MTr.single + grind [Algorithm.lts] + · grind + · have : q t ∧ a.lts.MTr s xl t ∧ ∀ m, m ∈ ms.toList → some m ∈ xl := by + grind [DeliverMsg.scheduleMsgs, fairDeliverMsg_foldList hd s ms.toList ∅ (by simp [ms, hs])] + obtain ⟨m, _⟩ := exists_mem_of_ne_zero h_ms + have : some m ∈ xl := by grind [mem_toList] + split_ands <;> grind [mem_toList, mem_filter] + +/-- The correctness of `a.fairSegEnds d ps s0` and `a.fairSegActions d ps s0` +under the assumption `a.FairDeliverMsg d ps q`. -/ +theorem fair_fairSegs {d : DeliverMsg P M S} {ps : Set P} {q : State P M S → Prop} + (hd : a.FairDeliverMsg d ps q) (s0 : State P M S) (hs0 : q s0) : + let ts := a.fairSegEnds d ps s0 + let xls := a.fairSegActions d ps s0 + ∀ k, q (ts k) ∧ a.lts.MTr (ts k) (xls k) (ts (k + 1)) ∧ (xls k).length > 0 ∧ + ∀ m, m ∈ (ts k).msgs → m.dest ∈ ps → some m ∈ xls k := by + classical + intro ts xls k + induction k <;> grind [fairScheduler_init, fairScheduler_step, fairDeliverMsg_scheduleMsgs] + +/-- Given an infinite sequence of non-empty finite executions of algorithm `a`, +if all messages with destinations in `ps` that are in-flight at the beginning of each +finite execution are delivered in that finite execution, then those finite executions can +be concatenated into an infinite execution of `a` in which every process in `ps` is fair. -/ +theorem flatten_fairSegs {ps : Set P} + {ts : ωSequence (State P M S)} {xls : ωSequence (List (Action P M))} + (hmtr : ∀ k, a.lts.MTr (ts k) (xls k) (ts (k + 1))) + (hpos : ∀ k, (xls k).length > 0) + (hsch : ∀ k m, m ∈ (ts k).msgs → m.dest ∈ ps → some m ∈ xls k) : + ∃ ss, a.lts.OmegaExecution ss xls.flatten ∧ (∀ k, ss (xls.cumLen k) = ts k) ∧ + ∀ p, p ∈ ps → ProcFair p ss xls.flatten := by + obtain ⟨ss, h_omega, h_ts⟩ := LTS.OmegaExecution.flatten_mTr hmtr hpos + use ss, h_omega, h_ts + rintro p h_m m ⟨rfl⟩ + by_contra! ⟨k, h_k, h_k'⟩ + have h_xls : ∃ᶠ n in atTop, n ∈ xls.cumLen '' univ := by + apply frequently_iff_strictMono.mpr + use xls.cumLen + grind [cumLen_strictMono] + obtain ⟨j, _, h_j⟩ : ∃ j, k ≤ xls.cumLen j ∧ m ∈ (ts j).msgs := by + obtain ⟨n, _, j, _, _⟩ := frequently_atTop.mp h_xls k + grind [Algorithm.omega_notRcvd_enabled h_omega h_k h_k'] + obtain ⟨i, _, _⟩ := List.getElem_of_mem <| hsch j m h_j h_m + grind [extract_flatten hpos j] + +/-- Under the assumption `a.FairDeliverMsg d ps q`, the infinite sequence of finite executions +of `a` represented by `a.fairSegEnds d ps s0` and `a.fairSegActions d ps s0` can be concatenated +into an infinite execution of `a` in which every process in `ps` is fair and `q` is true at +the ends of all those finite executions. -/ +theorem fair_omegaExecution {d : DeliverMsg P M S} {ps : Set P} {q : State P M S → Prop} + (hd : a.FairDeliverMsg d ps q) (s0 : State P M S) (hs0 : q s0) : + let ts := a.fairSegEnds d ps s0 + let xls := a.fairSegActions d ps s0 + ∃ ss, a.lts.OmegaExecution ss xls.flatten ∧ + ss 0 = s0 ∧ (∀ k, ss (xls.cumLen k) = ts k) ∧ + (∀ k, q (ss (xls.cumLen k))) ∧ (∀ k, (xls k).length > 0) ∧ + ∀ p, p ∈ ps → ProcFair p ss xls.flatten := by + intro ts xls + obtain ⟨h_q, hmtr, hpos, hsch⟩ : + (∀ k, q (ts k)) ∧ + (∀ k, a.lts.MTr (ts k) (xls k) (ts (k + 1))) ∧ + (∀ k, (xls k).length > 0) ∧ + (∀ k m, m ∈ (ts k).msgs → m.dest ∈ ps → some m ∈ xls k) := by + grind [fair_fairSegs hd s0 hs0] + obtain ⟨ss, _, _, _⟩ := flatten_fairSegs hmtr hpos hsch + have : ss 0 = s0 := by grind [fairScheduler_init] + use ss + grind + +/-- If `d.ForallActions r`, then the concatenation of all `a.fairSegActions d ps s0` segments +can only use actions satisfying `r`. -/ +theorem omega_forall_actions {d : DeliverMsg P M S} {ps : Set P} + {q : State P M S → Prop} {r : Action P M → Prop} + (hd : a.FairDeliverMsg d ps q) (s0 : State P M S) (hs0 : q s0) + (ha : d.ForallActions r) (hn : r none) : + ∀ k, r ((a.fairSegActions d ps s0).flatten k) := by + have hpos : ∀ k, (a.fairSegActions d ps s0 k).length > 0 := by grind [fair_fairSegs hd s0 hs0] + simp only [forall_flatten_iff hpos] + grind [fairSeg_forallActions] + +end FairScheduler + +end Cslib.FLP diff --git a/Cslib/Computability/Distributed/FLP/OnePseudoConsensus.lean b/Cslib/Computability/Distributed/FLP/OnePseudoConsensus.lean new file mode 100644 index 0000000000..7436c16b11 --- /dev/null +++ b/Cslib/Computability/Distributed/FLP/OnePseudoConsensus.lean @@ -0,0 +1,287 @@ +/- +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.PseudoConsensus + +/-! # 1-tolerant pseudo-consensus + +This file develops the theory of pseudo-consensus algorithms that can tolerate up to 1 fault. +It formalizes section 3 of [Volzer2004] except Theorem 1. +-/ + +@[expose] public section + +namespace Cslib.FLP + +open Function Set Multiset Fintype + +variable {P M S : Type*} [DecidableEq P] [DecidableEq M] + +/-- `a.CanDecideWithout s p b` means that the boolean value `b` is decided on in a state that +is reachable from `s` without the participation of `p`. In the notation of [Volzer2004], this +is equivalent to `b ∈ val(p,s)`. -/ +def Algorithm.CanDecideWithout (a : Algorithm P M S) + (s : State P M S) (p : P) (b : Bool) : Prop := + ∃ s', a.CanReachVia {p}ᶜ s s' ∧ s'.Decided b + +/-- `a.Uniform s b` means that for every process `p`, `a.CanDecideWithout s p b` but +not `a.CanDecideWithout s p !b`. -/ +def Algorithm.Uniform (a : Algorithm P M S) (s : State P M S) (b : Bool) : Prop := + ∀ p, a.CanDecideWithout s p b ∧ ¬ a.CanDecideWithout s p !b + +/-- `a.NonUniform s` means that for each boolean value `b`, there is a process `p` +such that `a.CanDecideWithout s p b`. -/ +def Algorithm.NonUniform (a : Algorithm P M S) (s : State P M S) : Prop := + ∀ b, ∃ p, a.CanDecideWithout s p b + +namespace OnePseudoConsensus + +variable {a : Algorithm P M S} {inp : P → Bool} + +/-- Draw a consequence of `a.PseudoConsensus 1`. -/ +theorem pseudoTermination [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) (p : P) : + ∃ s' b, a.CanReachVia {p}ᶜ s s' ∧ s'.Decided b := by + apply hpc1.right inp s hr {p}ᶜ + simp [Set.ncard_compl {p}] + +/-- Assuming `a.PseudoConsensus 1`, for any reachable state of `a` and for any process `p`, +there is a boolean value `b` such that `a.CanDecideWithout s p b`. This theorem formalizes +Proposition 2(a) of [Volzer2004]. -/ +theorem canDecideWithout_exists [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) (p : P) : + ∃ b, a.CanDecideWithout s p b := by + obtain ⟨s', b, _⟩ := pseudoTermination hpc1 hr p + use b + grind [Algorithm.CanDecideWithout] + +/-- A state cannot be both uniform and non-uniform. -/ +theorem not_uniform_and_nonUniform {s : State P M S} (b : Bool) : + ¬ (a.Uniform s b ∧ a.NonUniform s) := by + rintro ⟨_, h_n⟩ + obtain ⟨p, _⟩ := h_n !b + grind [Algorithm.Uniform] + +/-- Assuming `a.PseudoConsensus 1`, any reachable state of `a` is either uniform or non-uniform. -/ +theorem uniform_or_nonUniform [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) : + a.Uniform s false ∨ a.Uniform s true ∨ a.NonUniform s := by + by_cases h : a.Uniform s false ∨ a.Uniform s true + · grind + · suffices a.NonUniform s by grind + simp only [Algorithm.Uniform, not_or, not_forall, not_and, not_not, + Bool.not_false, Bool.not_true] at h + obtain ⟨⟨p, _⟩, ⟨q, _⟩⟩ := h + rintro (_ | _) + · use q + obtain ⟨b, _⟩ := canDecideWithout_exists hpc1 hr q + grind [Bool.dichotomy b] + · use p + obtain ⟨b, _⟩ := canDecideWithout_exists hpc1 hr p + grind [Bool.dichotomy b] + +/-- Assuming `a.PseudoConsensus 1`, if a reachable state of `a` has decided on a boolean value `b` +and `a.CanDecideWithout s p b'` for any process `p`, then `b = b'`. -/ +theorem decided_eq_canDecideWithout [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) {b b' : Bool} {p : P} + (hd : s.Decided b) (hd' : a.CanDecideWithout s p b') : b = b' := by + obtain ⟨s', hc, _⟩ := hd' + have hc := CanReachVia.canReach hc + grind [Algorithm.reachable_stable hr hc, Algorithm.decided_stable hd hc, + Algorithm.PseudoConsensus, Algorithm.SafeConsensus, State.Agreed] + +/-- Assuming `a.PseudoConsensus 1`, if a reachable state of `a` has decided on a boolean value `b`, +then `s` is uniform for `b`. This theorem formalizes Proposition 2(b) of [Volzer2004]. -/ +theorem decided_imp_uniform [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) {b : Bool} (hd : s.Decided b) : + a.Uniform s b := by + intro p + obtain ⟨b', _⟩ := canDecideWithout_exists hpc1 hr p + grind [decided_eq_canDecideWithout hpc1 hr hd] + +/-- For any message `m`, if state `s'` is reached from state `s` by receiving `m`, then +`a.CanDecideWithout s m.dest b` implies `a.CanDecideWithout s' m.dest b` for any `b`. +This theorem formalizes Proposition 3(b) of [Volzer2004]. -/ +theorem canDecideWithout_dest {s s' : State P M S} {m : Message P M} {b : Bool} + (ht : a.lts.Tr s (some m) s') + (hd : a.CanDecideWithout s m.dest b) : a.CanDecideWithout s' m.dest b := by + obtain ⟨t, h_s, h_t⟩ := hd + have h_m : a.CanReachVia {m.dest} s s' := by + use [some m] + grind [DestIn, LTS.MTr, List.Forall] + obtain ⟨t', h_s', h_t'⟩ := CanReachVia.diamond h_m h_s + use t', h_s' + grind [CanReachVia.canReach h_t', Algorithm.decided_stable] + +/-- For any message `m`, if state `s'` is reached from state `s` by receiving `m`, then +`a.CanDecideWithout s' p b` implies `a.CanDecideWithout s p b` for any `b` and any `p ≠ m.dest`. +This theorem formalizes Proposition 3(a) of [Volzer2004]. -/ +theorem canDecideWithout_nondest {s s' : State P M S} {m : Message P M} {b : Bool} + (ht : a.lts.Tr s (some m) s') {p : P} (hn : p ≠ m.dest) + (hd' : a.CanDecideWithout s' p b) : a.CanDecideWithout s p b := by + obtain ⟨t, h_s', h_t⟩ := hd' + refine ⟨t, ?_, h_t⟩ + have hx : DestIn {p}ᶜ (some m) := by grind [DestIn] + exact CanReachVia.stepL hx ht h_s' + +/-- Assuming `a.PseudoConsensus 1`, if any reachable state `s` of `a` is uniform for `b` and +state `s'` is reached from `s` by receiving a message `m`, then `a.CanDecideWithout s' p b`. +This theorem formalizes Proposition 3(c) of [Volzer2004]. -/ +theorem canDecideWithout_uniform [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s s' : State P M S} {m : Message P M} {b : Bool} + (hr : a.Reachable inp s) (ht : a.lts.Tr s (some m) s') {p : P} + (hd : a.CanDecideWithout s p b) (hdn : ¬ a.CanDecideWithout s p !b) : + a.CanDecideWithout s' p b := by + by_cases h_card : p = m.dest + · obtain ⟨rfl⟩ := h_card + exact canDecideWithout_dest ht hd + · have h_ss'' : a.Reachable inp s' := by + apply Algorithm.reachable_stable hr + use [some m] + grind [LTS.MTr] + obtain ⟨b', h_s'⟩ := canDecideWithout_exists hpc1 h_ss'' p + by_cases h_b : b' = b + · grind + · grind [canDecideWithout_nondest ht h_card h_s', Bool.eq_not_of_ne h_b] + +/-- Assuming `a.PseudoConsensus 1`, if any reachable state `s` of `a` that is non-uniform, +then for any process `p`, there exists a state `s'` reachable from `s` such that +`a.CanDecideWithout s' p b` for all `b`. This theorem formalizes Lemma 2 of [Volzer2004]. -/ +theorem nonUniform_step [Fintype P] (hpc1 : a.PseudoConsensus 1) + {s : State P M S} (hr : a.Reachable inp s) (hn : a.NonUniform s) (p : P) : + ∃ s', a.lts.CanReach s s' ∧ ∀ b, a.CanDecideWithout s' p b := by + obtain ⟨b, h_s⟩ := canDecideWithout_exists hpc1 hr p + obtain ⟨q, s', h_ss', h_s'⟩ := hn !b + have hr' := Algorithm.reachable_stable hr (CanReachVia.canReach h_ss') + obtain ⟨xs, h_mtr, h_xs'⟩ := h_ss' + obtain ⟨ss, h_ss'⟩ := LTS.Execution.of_mTr h_mtr + have reach_lemma (k : ℕ) (h : k < ss.length) : a.lts.CanReach s ss[k] := by + use xs.take k + have := LTS.Execution.split h_ss' k + grind [LTS.Execution, LTS.Execution.to_mTr] + have : a.CanDecideWithout s' p !b := by + obtain ⟨b', h_b'⟩ := canDecideWithout_exists hpc1 hr' p + grind [decided_eq_canDecideWithout hpc1 hr' h_s' h_b'] + have h_nb : ∃ n, ∃ _ : n < ss.length, a.CanDecideWithout ss[n] p !b := by grind [LTS.Execution] + classical + let n := Nat.find h_nb + obtain ⟨_, _⟩ : ∃ _ : n < ss.length, a.CanDecideWithout ss[n] p !b := by grind + use ss[n], ?_, ?_ + · grind [reach_lemma n] + · suffices ∀ k, (_ : k ≤ n) → a.CanDecideWithout ss[k] p b by + intro b' + by_cases h : b' = !b + · grind + · simp only [Bool.not_eq_not] at h + grind + intro k + induction k + case zero => grind [LTS.Execution] + case succ k h_ind => + intro h_k + obtain ⟨_, _, _, _⟩ := h_ss' + have h_tr : a.lts.Tr ss[k] xs[k] ss[k + 1] := by grind + obtain (_ | ⟨m, h_m⟩) := Option.eq_none_or_eq_some xs[k] + · grind [Algorithm.tr_none] + · rw [h_m] at h_tr + have hr_k : a.Reachable inp ss[k] := by + apply Algorithm.reachable_stable hr + grind [reach_lemma k] + have hnb_k : ¬a.CanDecideWithout ss[k] p !b := by grind [Nat.find_min h_nb (m := k)] + exact canDecideWithout_uniform hpc1 hr_k h_tr (h_ind (by grind)) hnb_k + +section NonUniformInit + +variable [Fintype P] + +/-- Given a numbering `pn` of processes and `n : ℕ`, `inpN pn n` assigns `true` to the processes +numbered `0, ..., (n - 1)` and `false` to the rest. -/ +def inpN (pn : P ≃ Fin (card P)) (n : ℕ) : P → Bool := + fun p ↦ if pn p < n then true else false + +omit [DecidableEq P] in +/-- Assuming `0 < n ≤ card P`, the inputs `inpN pn (n - 1)` amd `inpN pn n` agree on all processes +except the one that is numbered `(n - 1)`. -/ +theorem inpN_eqOn_except_singleton (pn : P ≃ Fin (card P)) + {n : ℕ} (hn0 : 0 < n) (hnc : n ≤ card P) : + InpEqOn {pn.symm ⟨n - 1, by grind⟩}ᶜ (inpN pn (n - 1)) (inpN pn n) := by + intro p h_p + suffices pn p ≠ n - 1 by + grind [inpN] + intro h + simp [← h] at h_p + +lemma inpN_zero_no_true (pn : P ≃ Fin (card P)) (hpc1 : a.PseudoConsensus 1) (p : P) : + ¬ a.CanDecideWithout (a.start (inpN pn 0)) p true := by + rintro ⟨s, h_r, h_b⟩ + have h_s : a.Reachable (inpN pn 0) s := by + have h_i := Algorithm.reachable_start (a := a) (inp := inpN pn 0) + exact Algorithm.reachable_stable h_i (CanReachVia.canReach h_r) + obtain ⟨q, h_q⟩ := (hpc1.left (inpN pn 0) s h_s).right true h_b + simp [inpN] at h_q + +/-- Assuming `a.PseudoConsensus 1`, the initial state determined by the all-`false` input +is uniform for `false`. -/ +theorem inpN_zero_uniform (pn : P ≃ Fin (card P)) (hpc1 : a.PseudoConsensus 1) (hc : card P ≥ 1) : + a.Uniform (a.start (inpN pn 0)) false := by + have h_i := Algorithm.reachable_start (a := a) (inp := inpN pn 0) + obtain (h | h | h) := uniform_or_nonUniform hpc1 h_i + · exact h + · grind [inpN_zero_no_true, h (pn.symm ⟨0, by grind⟩)] + · grind [inpN_zero_no_true, h true] + +lemma inpN_card_not_false (pn : P ≃ Fin (card P)) (hpc1 : a.PseudoConsensus 1) (p : P) : + ¬ a.CanDecideWithout (a.start (inpN pn (card P))) p false := by + rintro ⟨s, h_r, h_b⟩ + have h_s : a.Reachable (inpN pn (card P)) s := by + have h_i := Algorithm.reachable_start (a := a) (inp := inpN pn (card P)) + exact Algorithm.reachable_stable h_i (CanReachVia.canReach h_r) + obtain ⟨q, h_q⟩ := (hpc1.left (inpN pn (card P)) s h_s).right false h_b + simp [inpN] at h_q + +/-- Assuming `a.PseudoConsensus 1`, the initial state determined by the all-`true` input +is uniform for `true`. -/ +theorem inpN_card_uniform (pn : P ≃ Fin (card P)) (hpc1 : a.PseudoConsensus 1) (hc : card P ≥ 1) : + a.Uniform (a.start (inpN pn (card P))) true := by + have h_i := Algorithm.reachable_start (a := a) (inp := inpN pn (card P)) + obtain (h | h | h) := uniform_or_nonUniform hpc1 h_i + · grind [inpN_card_not_false, h (pn.symm ⟨0, by grind⟩)] + · exact h + · grind [inpN_card_not_false, h false] + +/-- Assuming `a.PseudoConsensus 1` and there are at least 2 processes, there must exist an input +that gives rise to a non-uniform initial state. This theorem formalizes Lemma 1 of [Volzer2004]. -/ +theorem nonUniform_inp (hpc1 : a.PseudoConsensus 1) (hc : card P ≥ 2) : + ∃ inp : P → Bool, a.NonUniform (a.start inp) := by + let pn := Fintype.equivFin P + let uniF (n : ℕ) := ¬ a.Uniform (a.start (inpN pn n)) false + have h_card : uniF (card P) := by + grind [Algorithm.Uniform, inpN_card_uniform pn hpc1 (by grind) (pn.symm ⟨0, by grind⟩)] + have h_uniF : ∃ n, uniF n := ⟨card P, h_card⟩ + classical + let n := Nat.find h_uniF + use (inpN pn n) + have h_n : ¬ a.Uniform (a.start (inpN pn n)) false := by grind + have h_n0 : 0 < n := by grind [inpN_zero_uniform] + have h_nc : n ≤ card P := by grind [Nat.find_min' h_uniF] + have h_n1 : a.Uniform (a.start (inpN pn (n - 1))) false := by grind [Nat.find_min h_uniF] + have : ¬ a.Uniform (a.start (inpN pn n)) true := by + obtain ⟨⟨s, h_reach, p, _⟩, _⟩ := h_n1 (pn.symm ⟨n - 1, by grind⟩) + obtain ⟨s', h_reach', _⟩ := CanReachVia.subset_inp + (inpN_eqOn_except_singleton pn h_n0 h_nc) h_reach + have : a.CanDecideWithout (a.start (inpN pn n)) (pn.symm ⟨n - 1, by grind⟩) false := by + use s', h_reach', p + grind + grind [Algorithm.Uniform] + grind [uniform_or_nonUniform, Algorithm.reachable_start (a := a) (inp := inpN pn n)] + +end NonUniformInit + +end OnePseudoConsensus + +end Cslib.FLP diff --git a/Cslib/Computability/Distributed/FLP/PseudoConsensus.lean b/Cslib/Computability/Distributed/FLP/PseudoConsensus.lean new file mode 100644 index 0000000000..db3a0f4851 --- /dev/null +++ b/Cslib/Computability/Distributed/FLP/PseudoConsensus.lean @@ -0,0 +1,122 @@ +/- +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.CanReachVia +public import Cslib.Computability.Distributed.FLP.FairScheduler + +/-! # Fault-tolerant pseudo-consensus + +A central idea of [Volzer2004] is the notion of pseudo-consensus, which weakens the notion of +consensus by replacing the requirement of termination, which is stated in terms of infinite +executions, by that of pseudo-termination, which is stated in terms of finite executions. +This makes the notion of pseudo-consensus easier to work with than consensus. This file +defines pseudo-consensus and proves that it is implied by consensus. This result is intuitively +obvious and is stated without proof in [Volzer2004], but it turns out to require quite a bit +of formal machinery to prove. +-/ + +@[expose] public section + +namespace Cslib.FLP + +open Function Set Multiset Fintype ωSequence FairScheduler + +variable {P M S : Type*} [DecidableEq P] [DecidableEq M] + +/-- An algorithm `a` satisfies `f`-tolerant pseudo-termination iff for every reachable state `s` +of `a` and every `ps` of at least `card P - f` processes, there exists a state `s'` reachable from +`s` using only messages with destinations in `ps` which has decided on a boolean value. +In other words, from any reachable state of `a`, a decision can be made without the participation +of at most `f` processes. -/ +def Algorithm.PseudoTermination [Fintype P] (a : Algorithm P M S) (f : ℕ) : Prop := + ∀ inp s, a.Reachable inp s → + ∀ ps : Set P, ps.ncard ≥ card P - f → + ∃ s' b, a.CanReachVia ps s s' ∧ s'.Decided b + +/-- An algorithm `a` is a pseudo-consensus algorithm tolerating up to `f` faults iff it satisfies +both the consensus safety property `a.SafeConsensus` and `f`-tolerant pseudo-termination. -/ +def Algorithm.PseudoConsensus [Fintype P] (a : Algorithm P M S) (f : ℕ) : Prop := + a.SafeConsensus ∧ a.PseudoTermination f + +open scoped Classical in +/-- `a.simpleDeliver ps` delivers any message that is in-flight and has its destination in `ps`. -/ +noncomputable def Algorithm.simpleDeliver (a : Algorithm P M S) (ps : Set P) : DeliverMsg P M S := + fun s m ↦ if m ∈ s.msgs ∧ m.dest ∈ ps then + ([m], a.recvMsg m s) + else + ([], s) + +namespace PseudoConsensus + +variable {a : Algorithm P M S} + +lemma simpleDeliver_fair (ps : Set P) : + a.FairDeliverMsg (a.simpleDeliver ps) ps (fun _ ↦ True) := by + intro s m h + simp only [h, Algorithm.simpleDeliver, Algorithm.lts] + grind [LTS.MTr.single] + +lemma simpleDeliver_forallActions (ps : Set P) : + (a.simpleDeliver ps).ForallActions (DestIn ps) := by + simp only [DeliverMsg.ForallActions, Algorithm.simpleDeliver] + intro s m + by_cases h : m ∈ s.msgs ∧ m.dest ∈ ps <;> simp [h, DestIn] + +/-- If an algorithm `a` is a consensus algorithm tolerating up to `f` faults, then `a` is also +a pseudo-consensus algorithm tolerating up to `f` faults. The main difficulty in the proof of +this theorem is that we need to construct an infinite admissible execution starting from any +reachable state of `a` using any subset of non-faulty processes. This is achieved using the +fair scheduler developed in `FairSchedular.lean`. -/ +theorem of_consensus [Fintype P] (f : ℕ) (hf : f < card P) + (hc : a.Consensus f) : a.PseudoConsensus f := by + obtain ⟨h_safe, h_term⟩ := hc + use h_safe + rintro inp s ⟨xl, h_xl⟩ ps h_ps + let xls := a.fairSegActions (a.simpleDeliver ps) ps s + obtain ⟨ss, h_omega, h_s, _⟩ := fair_omegaExecution (simpleDeliver_fair ps) s trivial + obtain ⟨ss', h_omega', _, _, _⟩ := LTS.OmegaExecution.append h_xl h_omega h_s + have h_dest := omega_forall_actions (r := DestIn ps) (d := a.simpleDeliver ps) + (simpleDeliver_fair ps) s trivial (simpleDeliver_forallActions ps) (by simp [DestIn]) + have : ∀ p, p ∈ ps → ProcFair p ss' (xl ++ω xls.flatten) := by + intro p h_p + rw [← Algorithm.drop_procFair_iff h_omega' p xl.length] + grind [drop_append_of_ge_length] + have : FairRun ss' (xl ++ω xls.flatten) := by + intro p + by_cases h_f : ProcFair p ss' (xl ++ω xls.flatten) + · grind + · obtain ⟨m, _, n, _, _⟩ := Algorithm.not_fair_stay_enabled h_omega' h_f + suffices ProcFaulty p ss' (xl ++ω xls.flatten) by grind + use n + xl.length, by grind + intro k h_k m' h_m' + have : xls.flatten (k - xl.length) = some m' := by grind [get_append_right'] + grind [DestIn] + have : numProcFaulty ss' (xl ++ω xls.flatten) ≤ f := by + suffices numProcFaulty ss' (xl ++ω xls.flatten) ≤ card P - ps.ncard by grind + apply numProcFaulty_le_not_procFair + grind + have h_adm : a.AdmissibleRun inp f ss' (xl ++ω xls.flatten) := by grind [Algorithm.AdmissibleRun] + have hf' : numProcFaulty ss' (xl ++ω xls.flatten) < card P := by grind + obtain ⟨p, _⟩ := not_procFaulty_of_numProcFaulty hf' + obtain ⟨n, b, _⟩ : ∃ n b, (ss' n).ProcDecided p b := by + grind [ProcTermination, h_term inp ss' (xl ++ω xls.flatten) h_adm p] + let m := n + xl.length + use ss' m, b + split_ands + · use (xl ++ω xls.flatten).extract xl.length m, by grind [LTS.OmegaExecution.extract_mTr] + simp [extract_append_right_right, extract_eq_take, + List.forall_iff_forall_mem, List.forall_mem_iff_getElem] + grind + · have : (ss' n).Decided b := by use p + suffices a.lts.CanReach (ss' n) (ss' m) by grind [Algorithm.decided_stable] + use (xl ++ω xls.flatten).extract n m + grind [LTS.OmegaExecution.extract_mTr] + +end PseudoConsensus + +end Cslib.FLP diff --git a/Cslib/Computability/Distributed/FLP/README.md b/Cslib/Computability/Distributed/FLP/README.md index 7bc8e7bd36..11bf07088d 100644 --- a/Cslib/Computability/Distributed/FLP/README.md +++ b/Cslib/Computability/Distributed/FLP/README.md @@ -1,8 +1,14 @@ -# Impossibility of distributed consensus +
+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
+
+ +# Impossibility of asynchronous distributed consensus This directory contains a formalization of Völzer's proof [Volzer2004] of the famous result in -distributed computing, first proved by Fischer, Lynch and Paterson [FLP1985], that distributed -consensus is impossible in the presence of even a single crash fault. +distributed computing, first proved by Fischer, Lynch and Paterson [FLP1985], that asynchronous +distributed consensus is impossible in the presence of even a single crash fault. ## Lean files @@ -12,8 +18,6 @@ consensus is impossible in the presence of even a single crash fault. 2. `Consensus.lean` defines what it means for a distributed algorithm to solve the consensus problem in a fault-tolerant way and proves some basic properties. -*The following files will appear in future PRs:* - 3. `FairScheduler.lean` contains a technical machinery for constructing "fair executions", which is used in the proof of `PseudoConsensus.of_consensus` in `PseudoConsensus.lean` and in the proof of `OnePseudoConsensus.fair_nonUniform` in `Impossibility.lean`. @@ -28,15 +32,22 @@ consensus is impossible in the presence of even a single crash fault. 6. `OnePseudoConsensus.lean` focuses on 1-tolerant pseudo-consensus algorithms, defines the key notion of "nonuniformity", and proves a number of their properties. +*#7 will appear in a future PR:* + 7. `Impossibility.lean` proves that every 1-tolerant pseudo-consensus algorithms has a fair execution 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..0feba19455 --- /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` +and `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/Languages/Language.lean b/Cslib/Computability/Languages/Language.lean index 0824cb1653..2ff6f64ee3 100644 --- a/Cslib/Computability/Languages/Language.lean +++ b/Cslib/Computability/Languages/Language.lean @@ -18,6 +18,17 @@ as defined and developed in `Mathlib.Computability.Language`. @[expose] public section +namespace List + +variable {α : Type*} + +/-- `[]` is the only list over an empty type. -/ +theorem eq_nil_ofIsEmpty [IsEmpty α] (xl : List α) : xl = [] := by + have hu := List.uniqueOfIsEmpty (α := α) + simp [Unique.eq_default] + +end List + namespace Language open Set List @@ -25,6 +36,17 @@ open scoped Computability variable {α : Type*} {l m : Language α} +/-- `0` and `1` are the only possible languages over an empty type. -/ +theorem eq_zero_or_one_ofIsEmpty [IsEmpty α] (l : Language α) : l = 0 ∨ l = 1 := by + by_cases h : l = 0 + · simp [h] + · right + ext xl + obtain ⟨yl, _⟩ := nonempty_iff_ne_empty.mpr h + obtain ⟨rfl⟩ := eq_nil_ofIsEmpty xl + obtain ⟨rfl⟩ := eq_nil_ofIsEmpty yl + simpa + @[simp] theorem mem_biInf {I : Type*} (s : Set I) (l : I → Language α) (x : List α) : (x ∈ ⨅ i ∈ s, l i) ↔ ∀ i ∈ s, x ∈ l i := @@ -41,6 +63,10 @@ theorem mem_biSup {I : Type*} (s : Set I) (l : I → Language α) (x : List α) theorem le_one_iff_eq : l ≤ 1 ↔ l = 0 ∨ l = 1 := subset_singleton_iff_eq +@[simp, scoped grind =] +theorem mem_singleton (x y : List α) : x ∈ ({y} : Language α) ↔ x = y := + Iff.rfl + @[simp, scoped grind =] theorem mem_sub_one (x : List α) : x ∈ (l - 1) ↔ x ∈ l ∧ x ≠ [] := Iff.rfl diff --git a/Cslib/Computability/Languages/MyhillNerode.lean b/Cslib/Computability/Languages/MyhillNerode.lean index 87a3a61a76..e42d3d3254 100644 --- a/Cslib/Computability/Languages/MyhillNerode.lean +++ b/Cslib/Computability/Languages/MyhillNerode.lean @@ -23,7 +23,7 @@ The Myhill-Nerode theorem has three parts [WikipediaMyhillNerode2026]: (3) The minimal DFA is unique up to unique isomorphism. That is, for any minimal DFA accepting `l`, there exists exactly an isomorphism from it to the - canonical DFA whose states are the equivalence classses of `c_l`, whose + canonical DFA whose states are the equivalence classes of `c_l`, whose state transitions are of the form `⟦ x ⟧ → ⟦ x ++ [a] ⟧` (where `a : α` and `x : List α`), whose initial state is `⟦ [] ⟧`, and whose accepting states are `{ ⟦ x ⟧ | x ∈ l }`. @@ -74,7 +74,7 @@ variable {l : Language α} theorem nerodeCongruenceDA_language_eq (l : Language α) : language (l.NerodeCongruenceDA) = l := by ext x - simp only [NerodeCongruenceDA, language, Acceptor.Accepts, congr_mtr_eq, Set.mem_image] + simp only [NerodeCongruenceDA, language, Acceptor.Accepts, congr_mtr_eq] constructor · rintro ⟨y, hy, heq⟩ have h1 := Quotient.eq.mp heq [] @@ -161,7 +161,7 @@ end Language namespace Cslib.Automata.DA.FinAcc -open Cslib Language Automata DA FinAcc Acceptor +open Cslib Cslib.Language Automata DA FinAcc Acceptor open scoped RightCongruence /-- The minimal DFA accepting `l` has the same number of states as the number of equivalence classes diff --git a/Cslib/Computability/Languages/OmegaLanguage.lean b/Cslib/Computability/Languages/OmegaLanguage.lean index 8b5fbb45c5..3f898b052c 100644 --- a/Cslib/Computability/Languages/OmegaLanguage.lean +++ b/Cslib/Computability/Languages/OmegaLanguage.lean @@ -98,6 +98,12 @@ def equiv : ωLanguage α ≃ Set (ωSequence α) where instance : CompleteAtomicBooleanAlgebra (ωLanguage α) := equiv.completeAtomicBooleanAlgebra +/-- `⊥` is the only possible ω-language over an empty type. -/ +theorem eq_bot_ofIsEmpty [IsEmpty α] (p : ωLanguage α) : p = ⊥ := by + ext xs + exfalso + exact IsEmpty.false xs + set_option linter.tacticAnalysis.verifyGrindOnly false in instance : SetLike (ωLanguage α) (ωSequence α) where coe := ωLanguage.toSet @@ -278,7 +284,8 @@ theorem hmul_bot : l * (⊥ : ωLanguage α) = ⊥ := by @[simp, scoped grind =] theorem one_hmul : (1 : Language α) * p = p := by - simp [hmul_def, Language.one_def, Language.toSet] + simp [hmul_def] + simp [Language.one_def, Language.toSet] theorem hmul_sup : l * (p ⊔ q) = l * p ⊔ l * q := by ext : 1 @@ -304,7 +311,7 @@ theorem le_hmul_congr {l1 l2 : Language α} {p1 p2 : ωLanguage α} (hl : l1 ≤ l1 * p1 ≤ l2 * p2 := by simp only [le_def] intros _ - simp_all only [hmul_def, mem_image2] + simp only [hmul_def, mem_image2] tauto theorem le_omegaPow_congr [Inhabited α] {l1 l2 : Language α} (h : l1 ≤ l2) : l1^ω ≤ l2^ω := by @@ -458,8 +465,10 @@ theorem omegaLim_zero : (0 : Language α)↗ω = ⊥ := by simp [omegaLim_def, bot_def] @[simp, scoped grind =] -theorem map_id (p : ωLanguage α) : map id p = p := - by simp [map] +theorem map_id (p : ωLanguage α) : map id p = p := by + unfold map + change { toSet := id '' p.toSet } = p + simp @[scoped grind =] theorem map_map (g : β → γ) (f : α → β) (p : ωLanguage α) : map g (map f p) = map (g ∘ f) p := by diff --git a/Cslib/Computability/Languages/OmegaRegularLanguage.lean b/Cslib/Computability/Languages/OmegaRegularLanguage.lean index 75e89deff9..644d181d18 100644 --- a/Cslib/Computability/Languages/OmegaRegularLanguage.lean +++ b/Cslib/Computability/Languages/OmegaRegularLanguage.lean @@ -190,8 +190,6 @@ theorem IsRegular.omegaPow [Inhabited Symbol] {l : Language Symbol} use Unit ⊕ State, inferInstance, ⟨na.loop, {inl ()}⟩ exact NA.Buchi.loop_language_eq --- TODO: fix proof to work with backward.isDefEq.respectTransparency -set_option backward.isDefEq.respectTransparency false in /-- An ω-language is regular iff it is the finite union of ω-languages of the form `L * M^ω`, where all `L`s and `M`s are regular languages. -/ theorem IsRegular.eq_fin_iSup_hmul_omegaPow [Inhabited Symbol] (p : ωLanguage Symbol) : @@ -214,8 +212,8 @@ theorem IsRegular.eq_fin_iSup_hmul_omegaPow [Inhabited Symbol] (p : ωLanguage S refine ⟨?_, by grind⟩ rintro ⟨s, h_s, t, h_t, h_mem⟩ use eq.invFun (⟨s, h_s⟩, ⟨t, h_t⟩) - -- The following `simp` is where the `set_option` above is needed. - simpa [mem_def] + have := Equiv.apply_symm_apply eq + simp_all · rintro ⟨n, l, m, _, rfl⟩ rw [← iSup_univ] apply IsRegular.iSup diff --git a/Cslib/Computability/Languages/RegularLanguage.lean b/Cslib/Computability/Languages/RegularLanguage.lean index 6e1bbcc8e0..f97e124b85 100644 --- a/Cslib/Computability/Languages/RegularLanguage.lean +++ b/Cslib/Computability/Languages/RegularLanguage.lean @@ -13,6 +13,7 @@ public import Cslib.Computability.Automata.NA.Concat public import Cslib.Computability.Automata.NA.Loop public import Cslib.Computability.Automata.NA.ToDA public import Mathlib.Computability.DFA +public import Mathlib.Computability.RegularExpressions public import Mathlib.Data.Finite.Sum public import Mathlib.Data.Set.Card @@ -153,27 +154,32 @@ theorem IsRegular.iSup {I : Type*} [Finite I] {s : Set I} {l : I → Language Sy open NA.FinAcc Sum in /-- The concatenation of two regular languages is regular. -/ @[simp] -theorem IsRegular.mul [Inhabited Symbol] {l1 l2 : Language Symbol} +theorem IsRegular.mul {l1 l2 : Language Symbol} (h1 : l1.IsRegular) (h2 : l2.IsRegular) : (l1 * l2).IsRegular := by - rw [IsRegular.iff_nfa] at h1 h2 ⊢ - obtain ⟨State1, h_fin1, nfa1, rfl⟩ := h1 - obtain ⟨State2, h_fin1, nfa2, rfl⟩ := h2 - use Option State1 ⊕ Option State2, inferInstance, - ⟨finConcat nfa1 nfa2, inr '' (some '' nfa2.accept)⟩ - exact finConcat_language_eq - --- TODO: fix proof to work with backward.isDefEq.respectTransparency -set_option backward.isDefEq.respectTransparency false in + obtain (he | hne) := isEmpty_or_nonempty Symbol + · obtain (rfl | rfl) := Language.eq_zero_or_one_ofIsEmpty l1 <;> + obtain (rfl | rfl) := Language.eq_zero_or_one_ofIsEmpty l2 <;> simp + · have := Classical.inhabited_of_nonempty hne + rw [IsRegular.iff_nfa] at h1 h2 ⊢ + obtain ⟨State1, h_fin1, nfa1, rfl⟩ := h1 + obtain ⟨State2, h_fin1, nfa2, rfl⟩ := h2 + use Option State1 ⊕ Option State2, inferInstance, + ⟨finConcat nfa1 nfa2, inr '' (some '' nfa2.accept)⟩ + exact finConcat_language_eq + open NA.FinAcc Sum in /-- The Kleene star of a regular language is regular. -/ @[simp] -theorem IsRegular.kstar [Inhabited Symbol] {l : Language Symbol} +theorem IsRegular.kstar {l : Language Symbol} (h : l.IsRegular) : (l∗).IsRegular := by - by_cases h_l : l = 0 - · simp [h_l] - · rw [IsRegular.iff_nfa] at h ⊢ - obtain ⟨State, h_fin, nfa, rfl⟩ := h - use Unit ⊕ Option State, inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l + obtain (he | hne) := isEmpty_or_nonempty Symbol + · obtain (rfl | rfl) := Language.eq_zero_or_one_ofIsEmpty l <;> simp + · have := Classical.inhabited_of_nonempty hne + by_cases h_l : l = 0 + · simp [h_l] + · rw [IsRegular.iff_nfa] at h ⊢ + obtain ⟨State, h_fin, nfa, rfl⟩ := h + use Unit ⊕ Option State, inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l /-- If a right congruence is of finite index, then each of its equivalence classes is regular. -/ @[simp] @@ -184,4 +190,31 @@ theorem IsRegular.congr_fin_index {Symbol : Type} use Quotient c.eq, inferInstance, ⟨c.toDA, {a}⟩ exact DA.FinAcc.congr_language_eq +/-- The language containing only the one character string `a` is regular. -/ +@[simp] +theorem IsRegular.char (a : Symbol) : ({[a]} : Language Symbol).IsRegular := by + rw [IsRegular.iff_dfa] + classical + let flts := FLTS.mk (fun (s : Fin 3) (x : Symbol) ↦ if (s = 0 ∧ x = a) then 1 else 2) + use Fin 3, inferInstance, ⟨DA.mk flts 0, {1}⟩ + ext xs + induction xs using List.reverseRec with + | nil => grind [Accepts, Language.mem_singleton] + | append_singleton xs x ih => + simp only [mem_language, Accepts, Language.mem_singleton, FLTS.mtr_concat_eq] at ih ⊢ + constructor + · induction xs using List.reverseRec <;> grind + · simp_all [flts, List.append_eq_cons_iff] + +/-- Languages matching regular expressions are regular. -/ +theorem IsRegular.regex {r : RegularExpression Symbol} : + r.matches'.IsRegular := by + induction r with + | zero => simp + | epsilon => simp + | char a => simp [IsRegular.char a] + | plus P Q hP hQ => grind [RegularExpression.matches', IsRegular.add] + | comp P Q hP hQ => grind [RegularExpression.matches', IsRegular.mul] + | star P hP => grind [RegularExpression.matches', IsRegular.kstar] + end Cslib.Language diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Classes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Classes.lean new file mode 100644 index 0000000000..536a22e5d4 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Classes.lean @@ -0,0 +1,321 @@ +/- +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.Order.Monotone.Defs + +import Mathlib.Tactic.Ring +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Cslib.Foundations.Data.Nat.BigO + +/-! +# Complexity classes for deterministic multi-tape Turing machines + +This file defines the resource-bounded complexity classes for deterministic multi-tape Turing +machines on top of `DecidableInTimeAndSpace`. + +## Design + +The general classes `DTIME` and `DSPACE` are defined using a single bound function `ℕ → ℕ` but allow +for `O`-fuzzyness. Some textbooks use exact bounds ([Papadimitriou94]), while others use a +definition similar to this one ([AroraBarak09], [Sipser2013]). The fuzzy definition is justified by +the space and time compression / speedup theorems (which are not proven here) and allow for +easier proofs and simpler theorem statements. Once we have better machinery, we can prove the +compression / speedup theorems and potentially move to exact bounds. + +The `O`-fuzziness is expressed by `Cslib.BoundFun`: bound functions are bundled as monotone +functions that are at least `1`, and the `≤` of `BoundFun` *is* domination (`f ≤ g` means +`f = O(g)`). A language is in `DTIME t` if it is decidable within some bound `t'` with `t' ≤ t`. +Since `t' ≤ t` unfolds to `∀ n, t' n ≤ c * t n`, this is equivalent to the formulation with an +explicit constant, recorded as `mem_DTIME_iff` and `mem_DSPACE_iff`; the additive constant of the +usual `c₁ * t n + c₂` formulation is not needed because bound functions are at least `1`. + +Concrete resource bounds of machines are plain functions `ℕ → ℕ`, and need be neither monotone nor +nonzero; they enter through the monotone envelope `Cslib.BoundFun.ofFun`, see `mem_DTIME_ofFun`. +Compared to the formulation with plain bound functions, degenerate bounds (non-monotone ones, or +ones that vanish) are no longer expressible; this is intended, and the normalised representatives +`BoundFun.linear` (`n + 1`) and `BoundFun.log` (`log₂ n + 1`) define the same classes as `n` and +`log₂ n` do, since they dominate each other up to constants. + +The classes are always relative to an alphabet `Symbol`. + +Bounds such as `2^{O(s)}` are not single bound functions but families of them, and are therefore +given by the O-classes of `Cslib.BoundFun` (`BoundFun.ExpO`, `BoundFun.PolyO`, +`BoundFun.ExpPolyO`). The corresponding complexity classes are `DTIMEOf` and `DSPACEOf`, the unions +of the `DTIME` / `DSPACE` classes of the members. Statements about them mention no constants at +all, and inclusions between them reduce to inclusions in the big-O calculus via `DTIMEOf_mono`. +The named classes below are defined in this way; `P_eq_iUnion` and friends relate them to the +formulation as a union over a family of bounds. + +## Important Declarations + +* `DTIME` - the class of languages decidable in time `O(t(n))` for a bound function `t`. +* `DSPACE` - the class of languages decidable in space `O(s(n))` for a bound function `s`. +* `DTIMEOf`, `DSPACEOf` - the same for a class of bound functions, such as `2^{O(s)}`. +* `mem_DTIME_ofFun`, `mem_DSPACE_ofFun`, `mem_DTIMEOf_ofFun`, `mem_DSPACEOf_ofFun` - membership + from a concrete, plain resource bound. +* `mem_DTIME_iff`, `mem_DSPACE_iff` - the equivalence with the formulation using an explicit + constant, i.e. a bound of the shape `c * t n`. +* `DTIME_mono`, `DSPACE_mono`, `DTIMEOf_mono`, `DSPACEOf_mono` - the classes only depend on their + bound up to `O`. +* `iUnion_DTIME_subset_of_le`, `iUnion_DSPACE_subset_of_le` - the same for unions over a family + of bounds. +* `DTIMEOf_setOf_exists_le`, `DTIMEOf_O`, `DTIMEOf_ExpO` - the bridges between `DTIMEOf` and the + formulation as a union over a family of bounds. + +Some named complexity classes are defined in the `Classes` namespace: + +* `P`, `E`, `EXP` +* `L`, `PSPACE`, `ESPACE`, `EXPSPACE` + +## 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 + +namespace Turing.MultiTapeTM + +variable {Symbol : Type} [Inhabited Symbol] + +/-- Monotonicity of `DecidableInTimeAndSpace` in the time bound. -/ +lemma DecidableInTimeAndSpace.mono_time {L : Language Symbol} {s : ℕ → ℕ} : + Monotone (DecidableInTimeAndSpace L · s) := by + intro t₁ t₂ h hd + obtain ⟨k, sym, state, emb, tm, hcomp⟩ := hd + refine ⟨k, sym, state, emb, tm, fun input => ?_⟩ + obtain ⟨t', ht', s', hs', hcs⟩ := hcomp input + exact ⟨t', ht'.trans (h _), s', hs', hcs⟩ + +/-- Monotonicity of `DecidableInTimeAndSpace` in the space bound. -/ +lemma DecidableInTimeAndSpace.mono_space {L : Language Symbol} {t : ℕ → ℕ} : + Monotone (DecidableInTimeAndSpace L t ·) := by + intro s₁ s₂ h hd + obtain ⟨k, sym, state, emb, tm, hcomp⟩ := hd + refine ⟨k, sym, state, emb, tm, fun input => ?_⟩ + obtain ⟨t', ht', s', hs', hcs⟩ := hcomp input + exact ⟨t', ht', s', hs'.trans (h _), hcs⟩ + +/-- The complexity class of languages decidable in time `O(t)` by a deterministic multi-tape +Turing machine, disregarding the space requirement. -/ +def DTIME (t : BoundFun) := + {L : Language Symbol | ∃ t' : BoundFun, t' ≤ t ∧ ∃ s, DecidableInTimeAndSpace L t' s} + +/-- The complexity class of languages decidable in space `O(s)` by a deterministic multi-tape +Turing machine, for some time bound. -/ +def DSPACE (s : BoundFun) := + {L : Language Symbol | ∃ s' : BoundFun, s' ≤ s ∧ ∃ t, DecidableInTimeAndSpace L t s'} + +/-- Membership in `DTIME`: a machine deciding `L` within some bound function `t'` that is `O(t)`. -/ +lemma mem_DTIME {L : Language Symbol} {t t' : BoundFun} {s : ℕ → ℕ} (h : t' ≤ t) + (hd : DecidableInTimeAndSpace L t' s) : L ∈ DTIME t := ⟨t', h, s, hd⟩ + +/-- Membership in `DSPACE`: a machine deciding `L` within some bound function `s'` that is +`O(s)`. -/ +lemma mem_DSPACE {L : Language Symbol} {s s' : BoundFun} {t : ℕ → ℕ} (h : s' ≤ s) + (hd : DecidableInTimeAndSpace L t s') : L ∈ DSPACE s := ⟨s', h, t, hd⟩ + +/-- Membership in `DTIME` from a plain time bound `T`, via its monotone envelope. This is the form +in which concrete machine bounds are used: no monotonicity of `T` is required. -/ +lemma mem_DTIME_ofFun {L : Language Symbol} {t : BoundFun} {T S : ℕ → ℕ} + (h : BoundFun.ofFun T ≤ t) (hd : DecidableInTimeAndSpace L T S) : L ∈ DTIME t := + mem_DTIME h (hd.mono_time fun n => BoundFun.le_ofFun T n) + +/-- Membership in `DSPACE` from a plain space bound `S`, via its monotone envelope. -/ +lemma mem_DSPACE_ofFun {L : Language Symbol} {s : BoundFun} {S T : ℕ → ℕ} + (h : BoundFun.ofFun S ≤ s) (hd : DecidableInTimeAndSpace L T S) : L ∈ DSPACE s := + mem_DSPACE h (hd.mono_space fun n => BoundFun.le_ofFun S n) + +/-- `DTIME` in terms of an explicit constant: `L ∈ DTIME t` iff `L` is decidable within time +`c * t n` for some constant `c`. -/ +lemma mem_DTIME_iff {L : Language Symbol} {t : BoundFun} : + L ∈ DTIME t ↔ ∃ c : ℕ, ∃ s, DecidableInTimeAndSpace L (fun n => c * t n) s := by + constructor + · rintro ⟨t', ⟨c, hc⟩, s, hd⟩ + exact ⟨c, s, hd.mono_time hc⟩ + · rintro ⟨c, s, hd⟩ + exact mem_DTIME_ofFun (BoundFun.ofFun_le (c := c) fun _ => le_rfl) hd + +/-- `DSPACE` in terms of an explicit constant: `L ∈ DSPACE s` iff `L` is decidable within space +`c * s n` for some constant `c`. -/ +lemma mem_DSPACE_iff {L : Language Symbol} {s : BoundFun} : + L ∈ DSPACE s ↔ ∃ c : ℕ, ∃ t, DecidableInTimeAndSpace L t (fun n => c * s n) := by + constructor + · rintro ⟨s', ⟨c, hc⟩, t, hd⟩ + exact ⟨c, t, hd.mono_space hc⟩ + · rintro ⟨c, t, hd⟩ + exact mem_DSPACE_ofFun (BoundFun.ofFun_le (c := c) fun _ => le_rfl) hd + +/-- `DTIME` only depends on the time bound up to `O`. -/ +lemma DTIME_mono {t₁ t₂ : BoundFun} (h : t₁ ≤ t₂) : + DTIME (Symbol := Symbol) t₁ ⊆ DTIME t₂ := + fun _ ⟨_, ht', _, hd⟩ => mem_DTIME (ht'.trans h) hd + +/-- `DSPACE` only depends on the space bound up to `O`. -/ +lemma DSPACE_mono {s₁ s₂ : BoundFun} (h : s₁ ≤ s₂) : + DSPACE s₁ ⊆ (DSPACE s₂ : Set (Language Symbol)) := + fun _ ⟨_, hs', _, hd⟩ => mem_DSPACE (hs'.trans h) hd + +/-- Lifting a family of dominations to an inclusion of unions of `DTIME` classes. This is the +form in which statements like `2^{O(s)} ⊆ 2^{n^{O(1)}}` are used. -/ +lemma iUnion_DTIME_subset_of_le {ι κ : Sort*} {F : ι → BoundFun} {G : κ → BoundFun} + (h : ∀ i, ∃ j, F i ≤ G j) : + (⋃ i, DTIME (Symbol := Symbol) (F i)) ⊆ ⋃ j, DTIME (G j) := by + refine Set.iUnion_subset fun i => ?_ + obtain ⟨j, hj⟩ := h i + exact (DTIME_mono hj).trans (Set.subset_iUnion (fun j => DTIME (Symbol := Symbol) (G j)) j) + +/-- Lifting a family of dominations to an inclusion of unions of `DSPACE` classes. -/ +lemma iUnion_DSPACE_subset_of_le {ι κ : Sort*} {F : ι → BoundFun} {G : κ → BoundFun} + (h : ∀ i, ∃ j, F i ≤ G j) : + (⋃ i, DSPACE (Symbol := Symbol) (F i)) ⊆ ⋃ j, DSPACE (G j) := by + refine Set.iUnion_subset fun i => ?_ + obtain ⟨j, hj⟩ := h i + exact (DSPACE_mono hj).trans (Set.subset_iUnion (fun j => DSPACE (Symbol := Symbol) (G j)) j) + +/-! ### Classes of bound functions + +A bound such as `2 ^ O(s)` is a whole family of bound functions, not a single one. Such families +are the O-classes of `Cslib.BoundFun` (`BoundFun.ExpO`, `BoundFun.PolyO`, ...), and the complexity +class for such a family is the union of the `DTIME` / `DSPACE` classes of its members. -/ + +/-- The class of languages decidable in time `t` for some bound function `t` in the class `𝒪` of +bound functions. -/ +def DTIMEOf (𝒪 : Set BoundFun) : Set (Language Symbol) := ⋃ t ∈ 𝒪, DTIME t + +/-- The class of languages decidable in space `s` for some bound function `s` in the class `𝒪` of +bound functions. -/ +def DSPACEOf (𝒪 : Set BoundFun) : Set (Language Symbol) := ⋃ s ∈ 𝒪, DSPACE s + +/-- Membership in `DTIMEOf`, from membership in one of the `DTIME` classes it unions. -/ +lemma mem_DTIMEOf {L : Language Symbol} {𝒪 : Set BoundFun} {t : BoundFun} (ht : t ∈ 𝒪) + (h : L ∈ DTIME t) : L ∈ DTIMEOf 𝒪 := Set.mem_biUnion ht h + +/-- Membership in `DSPACEOf`, from membership in one of the `DSPACE` classes it unions. -/ +lemma mem_DSPACEOf {L : Language Symbol} {𝒪 : Set BoundFun} {s : BoundFun} (hs : s ∈ 𝒪) + (h : L ∈ DSPACE s) : L ∈ DSPACEOf 𝒪 := Set.mem_biUnion hs h + +/-- The workhorse for membership in `DTIMEOf`: a machine with plain running time `T` whose monotone +envelope is dominated by a member of `𝒪`. -/ +lemma mem_DTIMEOf_ofFun {L : Language Symbol} {𝒪 : Set BoundFun} {t : BoundFun} {T S : ℕ → ℕ} + (hT : BoundFun.ofFun T ≤ t) (ht : t ∈ 𝒪) (hd : DecidableInTimeAndSpace L T S) : + L ∈ DTIMEOf 𝒪 := mem_DTIMEOf ht (mem_DTIME_ofFun hT hd) + +/-- The workhorse for membership in `DSPACEOf`: a machine with plain space usage `S` whose monotone +envelope is dominated by a member of `𝒪`. -/ +lemma mem_DSPACEOf_ofFun {L : Language Symbol} {𝒪 : Set BoundFun} {s : BoundFun} {T S : ℕ → ℕ} + (hS : BoundFun.ofFun S ≤ s) (hs : s ∈ 𝒪) (hd : DecidableInTimeAndSpace L T S) : + L ∈ DSPACEOf 𝒪 := mem_DSPACEOf hs (mem_DSPACE_ofFun hS hd) + +/-- `DTIMEOf` is monotone in the class of bound functions. This is the form in which inclusions +between complexity classes are proved: they reduce to inclusions in the big-O calculus. -/ +lemma DTIMEOf_mono {𝒪₁ 𝒪₂ : Set BoundFun} (h : 𝒪₁ ⊆ 𝒪₂) : + DTIMEOf (Symbol := Symbol) 𝒪₁ ⊆ DTIMEOf 𝒪₂ := + Set.biUnion_subset_biUnion_left h + +/-- `DSPACEOf` is monotone in the class of bound functions. -/ +lemma DSPACEOf_mono {𝒪₁ 𝒪₂ : Set BoundFun} (h : 𝒪₁ ⊆ 𝒪₂) : + DSPACEOf (Symbol := Symbol) 𝒪₁ ⊆ DSPACEOf 𝒪₂ := + Set.biUnion_subset_biUnion_left h + +/-- The classes of the big-O calculus are of the form `{f | ∃ i, f ≤ F i}`, for which `DTIMEOf` is +the union of the `DTIME` classes of the generating family. -/ +lemma DTIMEOf_setOf_exists_le {ι : Sort*} (F : ι → BoundFun) : + DTIMEOf (Symbol := Symbol) {f | ∃ i, f ≤ F i} = ⋃ i, DTIME (F i) := by + refine Set.Subset.antisymm (Set.iUnion₂_subset fun t ht => ?_) (Set.iUnion_subset fun i => ?_) + · obtain ⟨i, hi⟩ := ht + exact (DTIME_mono hi).trans (Set.subset_iUnion (fun i => DTIME (Symbol := Symbol) (F i)) i) + · exact Set.subset_biUnion_of_mem (u := fun t => DTIME (Symbol := Symbol) t) ⟨i, le_rfl⟩ + +/-- The `DSPACE` analogue of `DTIMEOf_setOf_exists_le`. -/ +lemma DSPACEOf_setOf_exists_le {ι : Sort*} (F : ι → BoundFun) : + DSPACEOf (Symbol := Symbol) {f | ∃ i, f ≤ F i} = ⋃ i, DSPACE (F i) := by + refine Set.Subset.antisymm (Set.iUnion₂_subset fun s hs => ?_) (Set.iUnion_subset fun i => ?_) + · obtain ⟨i, hi⟩ := hs + exact (DSPACE_mono hi).trans (Set.subset_iUnion (fun i => DSPACE (Symbol := Symbol) (F i)) i) + · exact Set.subset_biUnion_of_mem (u := fun s => DSPACE (Symbol := Symbol) s) ⟨i, le_rfl⟩ + +/-- Time `O(t)` is `DTIME t`. -/ +@[simp] lemma DTIMEOf_O (t : BoundFun) : DTIMEOf (Symbol := Symbol) (BoundFun.O t) = DTIME t := + Set.Subset.antisymm (Set.iUnion₂_subset fun _ ht => DTIME_mono ht) + (Set.subset_biUnion_of_mem (u := fun t => DTIME (Symbol := Symbol) t) (BoundFun.mem_O.2 le_rfl)) + +/-- Space `O(s)` is `DSPACE s`. -/ +@[simp] lemma DSPACEOf_O (s : BoundFun) : DSPACEOf (Symbol := Symbol) (BoundFun.O s) = DSPACE s := + Set.Subset.antisymm (Set.iUnion₂_subset fun _ hs => DSPACE_mono hs) + (Set.subset_biUnion_of_mem (u := fun s => DSPACE (Symbol := Symbol) s) + (BoundFun.mem_O.2 le_rfl)) + +/-- Time `2 ^ O(s)`, in terms of the union over the constant in the exponent. -/ +lemma DTIMEOf_ExpO (s : BoundFun) : + DTIMEOf (Symbol := Symbol) (BoundFun.ExpO s) + = ⋃ c, DTIME (BoundFun.exp2 (BoundFun.const c * s)) := + DTIMEOf_setOf_exists_le _ + +/-- Space `2 ^ O(s)`, in terms of the union over the constant in the exponent. -/ +lemma DSPACEOf_ExpO (s : BoundFun) : + DSPACEOf (Symbol := Symbol) (BoundFun.ExpO s) + = ⋃ c, DSPACE (BoundFun.exp2 (BoundFun.const c * s)) := + DSPACEOf_setOf_exists_le _ + +namespace Classes + +open BoundFun + +/-- Deterministic polynomial time. -/ +def P : Set (Language Symbol) := DTIMEOf PolyO + +/-- Deterministic exponential time (linear exponent). -/ +def E : Set (Language Symbol) := DTIMEOf (ExpO linear) + +/-- Deterministic exponential time (polynomial exponent). -/ +def EXP : Set (Language Symbol) := DTIMEOf ExpPolyO + +/-- Deterministic logarithmic space. -/ +def L : Set (Language Symbol) := DSPACE log + +/-- Deterministic polynomial space. -/ +def PSPACE : Set (Language Symbol) := DSPACEOf PolyO + +/-- Deterministic exponential space (linear exponent). -/ +def ESPACE : Set (Language Symbol) := DSPACEOf (ExpO linear) + +/-- Deterministic exponential space (polynomial exponent). -/ +def EXPSPACE : Set (Language Symbol) := DSPACEOf ExpPolyO + +/-- `P` is the union of the classes `DTIME (n ^ k)`. -/ +lemma P_eq_iUnion : P (Symbol := Symbol) = ⋃ k, DTIME (linear ^ k) := DTIMEOf_setOf_exists_le _ + +/-- `E` is the union of the classes `DTIME (2 ^ (c * n))`. -/ +lemma E_eq_iUnion : E (Symbol := Symbol) = ⋃ c, DTIME (exp2 (const c * linear)) := + DTIMEOf_setOf_exists_le _ + +/-- `EXP` is the union of the classes `DTIME (2 ^ (n ^ k))`. -/ +lemma EXP_eq_iUnion : EXP (Symbol := Symbol) = ⋃ k, DTIME (exp2 (linear ^ k)) := + DTIMEOf_setOf_exists_le _ + +/-- `PSPACE` is the union of the classes `DSPACE (n ^ k)`. -/ +lemma PSPACE_eq_iUnion : PSPACE (Symbol := Symbol) = ⋃ k, DSPACE (linear ^ k) := + DSPACEOf_setOf_exists_le _ + +/-- `ESPACE` is the union of the classes `DSPACE (2 ^ (c * n))`. -/ +lemma ESPACE_eq_iUnion : ESPACE (Symbol := Symbol) = ⋃ c, DSPACE (exp2 (const c * linear)) := + DSPACEOf_setOf_exists_le _ + +/-- `EXPSPACE` is the union of the classes `DSPACE (2 ^ (n ^ k))`. -/ +lemma EXPSPACE_eq_iUnion : EXPSPACE (Symbol := Symbol) = ⋃ k, DSPACE (exp2 (linear ^ k)) := + DSPACEOf_setOf_exists_le _ + +end Classes + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean new file mode 100644 index 0000000000..8c2f3a51f0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -0,0 +1,343 @@ +/- +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.TapeLemmas +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Fintype.Prod +public import Mathlib.Data.Fintype.Option +public import Mathlib.Algebra.Order.BigOperators.GroupWithZero.Finset +public import Cslib.Foundations.Data.Nat.BigO + +/-! +# 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`. + +The configuration type `Cfg` is split into the input head position and the *storage* part +(`Storage`), i.e. the state, the work tape contents and head positions. This split can be used +to show the collapse of small space-bounded classes. + + +## Important Definitions + +The key lemmas in this file are: + +* `MultiTapeTM.card_storages_le` bounds the number of *storage configurations* only, disregarding + the input head position. The function used for the bound is `storageBound Symbol State k s`. +* `MultiTapeTM.card_configs_le` additionally tracks the input head position, giving the bound + `(n + 2) * storageBound Symbol State k s` on the number of full configurations of an input of + length `n`. +* `MultiTapeTM.storageBound_mem_ExpO` states that `storageBound` composed with a bound function + lies in the class `2 ^ (O(σ))` of the big-O calculus of `Cslib.BoundFun`. This is where the + machine-specific configuration count enters the calculus. +* `MultiTapeTM.card_configs_le_exp2` restates the configuration bound as + `(n + 2) * a * 2 ^ (O(s))`, so it can be used to time-bound space-bounded machines. + +## Design + +Starting from the all-blank tapes with +every head at `0` and moving by at most one cell per step, a computation in which tape `i` has +visited at most `sᵢ` cells keeps that tape's head position and every non-blank cell within the +per-tape window `[-sᵢ, sᵢ]`. +Hence a storage configuration is determined by finite data over these +windows, and counting it gives the per-tape product `∏ᵢ (2 sᵢ + 1) · (|Symbol|+1)^(2 sᵢ + 1)`. Since +the tapes share the total space budget (`∑ᵢ sᵢ ≤ s`), this collapses to `storageBound`, whose +alphabet exponent is the *total* space (`2s + k`) rather than `k · s` — matching the textbook +`|State| · |Symbol|^{O(s)} · poly(s)` count. The full-configuration bound needed for time-bounding +space-bounded machines then follows by pairing the storage count with the `(n + 2)` possible +input-head positions. + +We lose a factor of `2 * k` by simplifying the windows to `[-sᵢ, sᵢ]` instead of the actually used +area, but this is absorbed by the `O(s)` exponent in the final bound. The `+2` in `(n + 2)` is +needed because the input head is allowed to move one step off the input in either direction by +the model. +-/ + +@[expose] public section + +open Cslib Cslib.BoundFun + +namespace Turing.MultiTapeTM + +variable {k : ℕ} +variable {State Symbol : Type*} +variable {input : List Symbol} +variable {tm : MultiTapeTM k Symbol State} + +/-- The state and work-tape data of a machine, with the cells and head position of tape `i` indexed +by an arbitrary type `ι i`. If you add the input tape position and use `ι i = ℤ`, this is equivalent +to `Cfg` (cf. `Cfg.storage`). +The index set is useful for cardinality arguments if we have a bound on the tape cells that +are actually used. +The input head position is not included because this is useful for arguments below logarithmic +space. -/ +@[ext] +structure Storage (Symbol State : Type*) {k : ℕ} (ι : Fin k → Type*) where + /-- the state of the TM (cf. `Cfg.state`) -/ + state : Option State + /-- the contents of work tape `i` (cf. `Cfg.workTapes`) -/ + workTapes (i : Fin k) : ι i → Option Symbol + /-- the position of the head on work tape `i` (cf. `Cfg.workTapePos`) -/ + workTapePos (i : Fin k) : ι i + +/-- A `Storage` is just a product of its fields; this equivalence is used for counting. -/ +def Storage.equivProd (Symbol State : Type*) (ι : Fin k → Type*) : + Storage Symbol State ι ≃ + Option State × ((i : Fin k) → ι i → Option Symbol) × ((i : Fin k) → ι i) where + toFun x := (x.state, x.workTapes, x.workTapePos) + invFun := fun ⟨state, workTapes, workTapePos⟩ => ⟨state, workTapes, workTapePos⟩ + +instance (Symbol State : Type*) [Fintype Symbol] [Fintype State] + (ι : Fin k → Type*) [∀ i, Fintype (ι i)] [∀ i, DecidableEq (ι i)] : + Fintype (Storage Symbol State ι) := + Fintype.ofEquiv _ (Storage.equivProd Symbol State ι).symm + +/-- A `Storage` over the unrestricted index type `ℤ` for every tape, as extracted from a full +configuration by `Cfg.storage`. -/ +abbrev UnboundedStorage (Symbol State : Type*) (k : ℕ) := + Storage Symbol State (fun _ : Fin k => ℤ) + +/-- This function maps a `Cfg` to `Storage`, using `ℤ` as the index type for the tapes. -/ +def Cfg.storage (c : Cfg k Symbol State input) : UnboundedStorage Symbol State k := + ⟨c.state, c.workTapes, c.workTapePos⟩ + +/-- For a fixed input, a configuration is fully determined by its input-head position together with +its `storage`. Hence counting distinct configurations reduces to counting `(inputPos, storage)` +pairs. -/ +lemma inputPos_storage_injective (input : List Symbol) : + Function.Injective + (fun c : Cfg k Symbol State input => (c.inputPos.val, c.storage)) := by + intro c₁ c₂ h + simp only [Cfg.storage, Prod.mk.injEq, Storage.mk.injEq] at h + obtain ⟨hip, hstate, hwt, hwp⟩ := h + exact Cfg.ext hstate (Fin.ext hip) hwt hwp + + +/-- The window `[-s, s]` of tape positions allotted to a tape that uses `s` cells. -/ +def Storage.window (s : ℕ) : Finset ℤ := Finset.Icc (-(s : ℤ)) s + +@[scoped grind =] +lemma Storage.mem_window {s : ℕ} {z : ℤ} : z ∈ Storage.window s ↔ z.natAbs ≤ s := by + simp only [Storage.window, Finset.mem_Icc] + omega + +@[simp] +lemma Storage.card_window (s : ℕ) : (Storage.window s).card = 2 * s + 1 := by + rw [Storage.window, Int.card_Icc] + omega + +/-- A bounded storage configuration: a `Storage` whose tape `i` is restricted to the finite window +`[-(w i), w i]`. Storage configurations of a computation that visits at most the window of each +tape embed injectively into this finite type (`Storage.toBounded`), so its cardinality bounds the +number of reachable storage configurations. -/ +abbrev BoundedStorage (Symbol State : Type*) {k : ℕ} (w : Fin k → ℕ) := + Storage Symbol State (fun i => Storage.window (w i)) + +/-- A storage fits in the per-tape windows `w`: on each tape `j`, the head position and every +non-blank cell have absolute value `≤ w j`. -/ +structure Storage.FitsIn (x : UnboundedStorage Symbol State k) (w : Fin k → ℕ) : Prop where + /-- the head position on every tape lies within its window -/ + pos_le : ∀ j, (x.workTapePos j).natAbs ≤ w j + /-- every non-blank cell on every tape lies within its window -/ + cell_le : ∀ j z, x.workTapes j z ≠ none → z.natAbs ≤ w j + +/-- Restriction of a storage over `ℤ` to the finite windows `w` (with heads outside their window +clamped to `0`). -/ +def Storage.toBounded (x : UnboundedStorage Symbol State k) (w : Fin k → ℕ) : + BoundedStorage Symbol State w where + state := x.state + workTapes j z := x.workTapes j z.1 + workTapePos j := + if h : x.workTapePos j ∈ Storage.window (w j) then ⟨x.workTapePos j, h⟩ + else ⟨0, Storage.mem_window.mpr (Nat.zero_le _)⟩ + +/-- The restriction is injective on storages that fit in the windows. -/ +lemma Storage.toBounded_injOn (w : Fin k → ℕ) : + Set.InjOn (Storage.toBounded (Symbol := Symbol) (State := State) · w) {x | x.FitsIn w} := by + rintro x ⟨hxp, hxc⟩ y ⟨hyp, hyc⟩ hxy + simp only [Storage.toBounded, Storage.mk.injEq] at hxy + obtain ⟨hstate, htapes, hpos⟩ := hxy + refine Storage.ext hstate (funext₂ fun j z => ?_) (funext fun j => ?_) + · by_cases hz : z ∈ Storage.window (w j) + · exact congrFun (congrFun htapes j) ⟨z, hz⟩ + · grind + · have := congrFun hpos j + grind [Subtype.ext_iff] + +/-- The number of storages over finite position types is the per-tape product of +"cell contents × head position" counts. -/ +lemma card_storage [Fintype Symbol] [Fintype State] + (ι : Fin k → Type*) [∀ i, Fintype (ι i)] [∀ i, DecidableEq (ι i)] : + Fintype.card (Storage Symbol State ι) + = (Fintype.card State + 1) + * ∏ i, Fintype.card (ι i) * (Fintype.card Symbol + 1) ^ Fintype.card (ι i) := by + rw [Fintype.card_congr (Storage.equivProd Symbol State ι)] + simp only [Fintype.card_prod, Fintype.card_option, Fintype.card_pi, Finset.prod_const, + Finset.card_univ, Finset.prod_mul_distrib] + ring + +/-- An upper bound on the number of storage configurations a `k`-tape machine can be in while using +at most `s` cells of total work-tape space, over the given alphabet and state set. The `(2s+1)^k` +factor counts the possible head positions; the dominant factor `(|Symbol|+1)^(2s+k)` uses the +*total* space `s` in the exponent (the `k` tapes share the space budget), matching the textbook +`|State| · |Symbol|^{O(s)} · poly(s)` count. -/ +def storageBound (Symbol State : Type*) [Fintype Symbol] [Fintype State] (k s : ℕ) : ℕ := + (Fintype.card State + 1) * ((2 * s + 1) ^ k * (Fintype.card Symbol + 1) ^ (2 * s + k)) + +/-- `storageBound` composed with a bound function is `2 ^ (O(σ))`: the number of storage +configurations available within space `σ n` lies in the class `BoundFun.ExpO σ`, with the machine's +alphabet, state set and tape count only affecting the (invisible) constant in the exponent. This is +the point where the machine-specific configuration count enters the big-O calculus. + +The proof splits `storageBound` into its three factors with `BoundFun.ofFun_mul_mem_ExpO` and +applies the membership rules of the calculus to each of them: the state count is a constant, the +head positions are a polynomial in `σ` (`BoundFun.ofFun_pow_mem_ExpO`) and the tape contents are a +power of a fixed base with an exponent affine in `σ` (`BoundFun.ofFun_base_pow_mem_ExpO`). -/ +lemma storageBound_mem_ExpO [Fintype Symbol] [Fintype State] (k : ℕ) (σ : BoundFun) : + BoundFun.ofFun (fun n => storageBound Symbol State k (σ n)) ∈ ExpO σ := by + -- The state, a constant. + have hstate : BoundFun.ofFun (fun _ => Fintype.card State + 1) ∈ ExpO σ := + BoundFun.ofFun_const_mem_ExpO .. + -- The head positions of the `k` work tapes, a polynomial in `σ`. + have hheads : BoundFun.ofFun (fun n => (2 * σ n + 1) ^ k) ∈ ExpO σ := + BoundFun.ofFun_pow_mem_ExpO k 3 fun n => by have := σ.one_le_apply n; omega + -- The contents of the work tapes, a power with an exponent affine in `σ`. + have htapes : BoundFun.ofFun (fun n => (Fintype.card Symbol + 1) ^ (2 * σ n + k)) ∈ ExpO σ := + BoundFun.ofFun_base_pow_mem_ExpO _ 2 k fun _ => le_rfl + unfold storageBound + exact BoundFun.ofFun_mul_mem_ExpO hstate (BoundFun.ofFun_mul_mem_ExpO hheads htapes) + +/-- The per-tape product is bounded by `storageBound`: each tape uses at most the total space `s`, +and the tapes together use at most `s`, which collapses the alphabet exponent to `2s + k`. -/ +lemma card_boundedStorage_le [Fintype Symbol] [Fintype State] + (w : Fin k → ℕ) (s : ℕ) (hsum : ∑ i, w i ≤ s) : + Fintype.card (BoundedStorage Symbol State w) ≤ storageBound Symbol State k s := by + have hle : ∀ i, w i ≤ s := fun i => + (Finset.single_le_sum (fun i _ => Nat.zero_le (w i)) (Finset.mem_univ i)).trans hsum + rw [card_storage, storageBound] + simp only [Fintype.card_coe, Storage.card_window] + rw [Finset.prod_mul_distrib, Finset.prod_pow_eq_pow_sum] + have hsc : ∑ i : Fin k, (2 * w i + 1) = 2 * (∑ i, w i) + k := by + simp [two_mul, Finset.sum_add_distrib] + gcongr + · simpa using Finset.prod_le_pow_card Finset.univ (fun i => 2 * w i + 1) (2 * s + 1) + fun i _ => by have := hle i; omega + · omega + · omega + +/-- The storage of any configuration reached within `T` steps fits in the windows given by the +per-tape space usage up to step `T`. -/ +lemma storage_fitsIn + (T : ℕ) + {t : ℕ} + (ht : t ≤ T) : + (tm.configs (tm.initCfg input) t).storage.FitsIn + (fun i => tm.spaceUsedByTape (tm.initCfg input) T i) := by + -- The bounds at step `t` extend to the window at step `T ≥ t` by monotonicity of space usage. + refine ⟨fun j => le_trans ?_ (tm.spaceUsedByTape_mono _ j ht), + fun j z hz => le_trans ?_ (tm.spaceUsedByTape_mono _ j ht)⟩ + · -- The head position at step `t` is visited, and the initial head position is `0`, so the + -- displacement bound is a bound on the position itself. + simpa [Cfg.storage] using tm.natAbs_le_spaceUsedByTape_of_mem_visited + (tm.mem_visitedByTapeHead_self (tm.initCfg input) t j) + · exact content_natAbs_le_spaceUsedByTape t z hz + + +open scoped Classical in +/-- For any multi-tape Turing machine that uses at most space `s` up to step `t`, the number +of storage configurations (configurations disregarding the input head positions) up to step `t` +is at most `storageBound Symbol State k s` (independent of `t`). -/ +theorem card_storages_le + [Fintype Symbol] [Fintype State] + (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 Symbol State k s := by + have hsum : ∑ i, tm.spaceUsedByTape (tm.initCfg input) t i ≤ s := hs + calc ((Finset.range (t + 1)).image + (fun t' => (tm.configs (tm.initCfg input) t').storage)).card + ≤ Fintype.card + (BoundedStorage Symbol State (fun i => tm.spaceUsedByTape (tm.initCfg input) t i)) := by + rw [← Finset.card_univ] + refine Finset.card_le_card_of_injOn + (Storage.toBounded · (fun i => tm.spaceUsedByTape (tm.initCfg input) t i)) + (fun x _ => Finset.mem_univ _) ?_ + refine Set.InjOn.mono ?_ + (Storage.toBounded_injOn (fun i => tm.spaceUsedByTape (tm.initCfg input) t i)) + 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_fitsIn t (by omega) + _ ≤ storageBound Symbol State k s := + card_boundedStorage_le (fun i => tm.spaceUsedByTape (tm.initCfg input) t i) s hsum + + +open scoped Classical in +/-- The number of distinct configurations a multi-tape Turing machine with space bound `s` +can reach is at most `(n + 2) * storageBound Symbol State k s`, where `n` is the input length. +The `(n + 2)` factor accounts for the input-head position; the `storageBound` factor accounts for +everything else (`storage`). -/ +theorem card_configs_le + [Fintype Symbol] [Fintype State] + (t s : ℕ) + (hs : tm.spaceUsed (tm.initCfg input) t ≤ s) : + ((Finset.range (t + 1)).image (tm.configs (tm.initCfg input))).card + ≤ (input.length + 2) * storageBound Symbol State k s := by + -- Counting configurations reduces to counting `(inputPos, storage)` pairs, since the map to such + -- pairs is injective for a fixed input. + rw [← Finset.card_image_of_injective _ (inputPos_storage_injective input), Finset.image_image] + -- The pair image lies in the product of the input-head range with the storage image, so its + -- cardinality is bounded by `(n + 2)` times the storage count from `card_storages_le`. + calc ((Finset.range (t + 1)).image (fun t' => + ((tm.configs (tm.initCfg input) t').inputPos.val, + (tm.configs (tm.initCfg input) t').storage))).card + ≤ (Finset.range (input.length + 2) ×ˢ (Finset.range (t + 1)).image + (fun t' => (tm.configs (tm.initCfg input) t').storage)).card := by + refine Finset.card_le_card fun x hx => ?_ + simp only [Finset.mem_image, Finset.mem_range] at hx + obtain ⟨t, ht, rfl⟩ := hx + simp only [Finset.mem_product, Finset.mem_range, Finset.mem_image] + exact ⟨(tm.configs (tm.initCfg input) t).inputPos.isLt, t, ht, rfl⟩ + _ = (input.length + 2) * ((Finset.range (t + 1)).image + (fun t => (tm.configs (tm.initCfg input) t).storage)).card := by + rw [Finset.card_product, Finset.card_range] + _ ≤ (input.length + 2) * storageBound Symbol State k s := + Nat.mul_le_mul_left _ (card_storages_le t s hs) + +open scoped Classical in +/-- The number of distinct configurations reachable in space `s` is at most `2 ^ (O(s))`, up to the +`(n + 2)` factor for the input-head position: there are a constant `a` and a bound function +`exp2 (const c * s)` (depending only on the machine's alphabet, state set and tape count) that +bound the configuration count for *every* input and step count. This is the form used to +time-bound space-bounded machines; it is the pointwise reading of `storageBound_mem_ExpO`. -/ +theorem card_configs_le_exp2 + [Finite Symbol] [Finite State] (s : BoundFun) : + ∃ a c : ℕ, ∀ (input : List Symbol) (t : ℕ), + tm.spaceUsed (tm.initCfg input) t ≤ s input.length → + ((Finset.range (t + 1)).image (tm.configs (tm.initCfg input))).card + ≤ (input.length + 2) * a * exp2 (const c * s) input.length := by + have : Fintype Symbol := Fintype.ofFinite Symbol + have : Fintype State := Fintype.ofFinite State + obtain ⟨c, a, ha⟩ := storageBound_mem_ExpO (Symbol := Symbol) (State := State) k s + refine ⟨a, c, fun input t hs => ?_⟩ + have hpt : storageBound Symbol State k (s input.length) + ≤ a * exp2 (const c * s) input.length := + (BoundFun.le_ofFun (fun n => storageBound Symbol State k (s n)) input.length).trans + (ha input.length) + calc ((Finset.range (t + 1)).image (tm.configs (tm.initCfg input))).card + ≤ (input.length + 2) * storageBound Symbol State k (s input.length) := + tm.card_configs_le t _ hs + _ ≤ (input.length + 2) * (a * exp2 (const c * s) input.length) := by gcongr + _ = (input.length + 2) * a * exp2 (const c * s) input.length := by ring + +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..345377caa9 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -0,0 +1,577 @@ +/- +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: the internal state, the work tape contents and head positions +* `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. +-/ +@[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 → ℤ +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. + +The addition is performed in `ℤ` before clamping. Performing it in `Fin (n + 2)` would wrap an +outward boundary move to the opposite end of the input. -/ +@[scoped grind =] +def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : Fin (n + 2) := + let p := ((pos.val : ℤ) + (m.cast : ℤ)).toNat + if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩ + +@[simp] +lemma moveInputPos_zero {n : ℕ} (pos : Fin (n + 2)) : + moveInputPos pos 0 = pos := by + apply Fin.ext + simp [moveInputPos, pos.isLt] + +@[simp] +lemma moveInputPos_leftBoundary {n : ℕ} : + moveInputPos (0 : Fin (n + 2)) (-1) = 0 := by + apply Fin.ext + simp [moveInputPos] + +@[simp] +lemma moveInputPos_rightBoundary {n : ℕ} : + moveInputPos (⟨n + 1, by omega⟩ : Fin (n + 2)) 1 = ⟨n + 1, by omega⟩ := by + unfold moveInputPos + rw [dif_neg (by simp; omega)] + +/-- A left move away from the left input boundary decrements the native input position. -/ +lemma moveInputPos_neg_of_ne_left {n : ℕ} (p : Fin (n + 2)) (h : p ≠ 0) : + moveInputPos p .neg = ⟨p.val - 1, by have := p.isLt; omega⟩ := by + have hp : 0 < p.val := Nat.pos_of_ne_zero (fun hz => h (Fin.ext hz)) + unfold moveInputPos + apply Fin.ext + rw [dif_pos] <;> simp <;> omega + +/-- A right move away from the right input boundary increments the native input position. -/ +lemma moveInputPos_pos_of_ne_right {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n + 1) : + moveInputPos p .pos = ⟨p.val + 1, by have := p.isLt; omega⟩ := by + unfold moveInputPos + rw [dif_pos] + · apply Fin.ext + simp + · simp + 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, 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 + } + +/-- The symbol (optionally) output when executing one step starting from configuration `cfg`. -/ +def outputSymbol (cfg : Cfg k Symbol State input) : Option Symbol := + match cfg.state with + | none => none + | some q => (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).outS + +/-- 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 + +lemma configs_succ_eq_step {cfg : Cfg k Symbol State input} {t : ℕ} : + tm.configs cfg (t + 1) = tm.configs (tm.step cfg) t := by + simp [configs, Function.iterate_succ_apply] + +lemma configs_succ_eq_step' {cfg : Cfg k Symbol State input} {t : ℕ} : + tm.configs cfg (t + 1) = tm.step (tm.configs cfg t) := by + simp [configs, Function.iterate_succ_apply'] + +/-- Any number of steps run from a halting configuration results in the same configuration. -/ +@[simp, scoped grind =] +lemma iter_step_eq_of_halt {cfg : 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] + +@[simp] +lemma outputSymbol_of_halt {cfg : Cfg k Symbol State input} (h_halt : cfg.state = none) : + tm.outputSymbol cfg = none := by + simp [outputSymbol, 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 + +/-- A step changes the contents of a work tape at most at the current head position. -/ +lemma step_workTapes_eq_of_ne + (cfg : Cfg k Symbol State input) + (j : Fin k) + (z : ℤ) + (hz : z ≠ cfg.workTapePos j) : + (tm.step cfg).workTapes j z = cfg.workTapes j z := by + unfold step + cases hst : cfg.state with + | none => simp_all + | some q => + rcases hw : ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions j).1 <;> simp_all + +end Cfg + +section Space +/-! Now we define space usage and add some helper lemmas. -/ + +/-- The set of positions visited by the head of work tape `i` in the computation starting from +configuration `cfg` up to step `t`. -/ +def visitedByTapeHead (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : Finset ℤ := + (Finset.range (t + 1)).image fun t' => (tm.configs cfg t').workTapePos i + +/-- +The number of work tape cells touched by the head of tape `i` in the computation starting from +configuration `cfg` up to step `t`. +-/ +def spaceUsedByTape (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : ℕ := + (tm.visitedByTapeHead cfg t i).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 + +/-- Each tape's space usage is bounded by the total space used. -/ +lemma spaceUsedByTape_le_spaceUsed (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : + tm.spaceUsedByTape cfg t i ≤ tm.spaceUsed cfg t := + Finset.single_le_sum (fun _ _ => Nat.zero_le _) (Finset.mem_univ i) + +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₂ + +/-- The string output by the Turing machine `tm` starting in configuration `cfg₀`, executing for +`t` steps. It is the concatenation of the symbols (optionally) emitted at each of the first `t` +steps. -/ +def outputString + (tm : MultiTapeTM k Symbol State) + (cfg₀ : Cfg k Symbol State input) (t : ℕ) : List Symbol := + (List.range t).flatMap fun t' => (tm.outputSymbol (tm.configs cfg₀ t')).toList + +/-- The output produced in `t + 1` steps is the output produced in `t` steps followed by the symbol +(optionally) emitted at step `t`. -/ +lemma outputString_succ + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) : + tm.outputString cfg (t + 1) = + tm.outputString cfg t ++ (tm.outputSymbol (tm.configs cfg t)).toList := by + simp [outputString, List.range_succ, List.flatMap_append] + +/-- From a halting configuration, a TM does not output anything. -/ +lemma outputString_halt + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) + (h_halt : cfg.state = none) + (t : ℕ) : + tm.outputString cfg t = [] := by + induction t with + | zero => simp [outputString] + | succ t ih => + have : tm.configs cfg t = cfg := by + simp [configs, iter_step_eq_of_halt, h_halt] + rw [outputString_succ, ih, this] + simp [outputSymbol, h_halt] + +lemma outputString_add_eq_append + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t₁ t₂ : ℕ) : + tm.outputString cfg (t₁ + t₂) = + tm.outputString cfg t₁ ++ tm.outputString (tm.configs cfg t₁) t₂ := by + induction t₂ with + | zero => simp [outputString] + | succ t ih => + rw [show (t₁ + (t + 1)) = (t₁ + t) + 1 by omega] + simp [outputString_succ, ih, configs, ← Function.iterate_add_apply, Nat.add_comm] + +/-- The output does not change after the machine has halted. -/ +lemma outputString_eq_of_halt + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.configs cfg τ).state = none) : + tm.outputString cfg t = tm.outputString cfg τ := by + conv_lhs => rw [← Nat.sub_add_cancel hle, Nat.add_comm] + rw [outputString_add_eq_append, outputString_halt _ _ hhalt] + simp + +/-- 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 := + (tm.configs (tm.initCfg input) t).state = none ∧ + tm.outputString (tm.initCfg input) t = output ∧ + 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₁ + +/-- Running `a + d` steps equals running `a` steps from the configuration reached after `d`. -/ +lemma configs_add (cfg : Cfg k Symbol State input) (a d : ℕ) : + tm.configs cfg (a + d) = tm.step^[a] (tm.configs cfg d) := by + unfold configs; rw [Function.iterate_add_apply] + +/-- Once a machine has halted at step `m`, its configuration is unchanged at any later step `n`. -/ +lemma halt_mono (cfg : Cfg k Symbol State input) {m n : ℕ} (h : m ≤ n) + (hm : (tm.configs cfg m).state = none) : + tm.configs cfg n = tm.configs cfg m := by + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le h + rw [Nat.add_comm, tm.configs_add, tm.iter_step_eq_of_halt hm] + +/-- If a deterministic machine revisits a non-halting configuration, it never halts: revisiting a +configuration makes the run periodic, so if some step were halting, the frozen halting +configuration would still be around at the next return to the repeated (non-halting) +configuration. -/ +lemma not_halts_of_repeat_nonhalt (cfg : Cfg k Symbol State input) + {t₁ t₂ : ℕ} (hne : t₁ ≠ t₂) + (heq : tm.configs cfg t₁ = tm.configs cfg t₂) + (hnh : (tm.configs cfg t₂).state ≠ none) : + ∀ t, (tm.configs cfg t).state ≠ none := by + wlog hlt : t₁ < t₂ generalizing t₁ t₂ + · exact this hne.symm heq.symm (heq ▸ hnh) (by omega) + intro t ht + -- The run returns to `configs t₁` every `t₂ - t₁` steps. + have hperiod : ∀ n, tm.configs cfg (t₁ + n * (t₂ - t₁)) = tm.configs cfg t₁ := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [show t₁ + (n + 1) * (t₂ - t₁) = (t₂ - t₁) + (t₁ + n * (t₂ - t₁)) by grind, + tm.configs_add, ih, ← tm.configs_add, show t₂ - t₁ + t₁ = t₂ by omega, ← heq] + -- A halting step `t` freezes the run, so the return to `configs t₁` after step `t` + -- would make `configs t₁` halting as well — contradiction. + have hle : t ≤ t₁ + t * (t₂ - t₁) := + (Nat.le_mul_of_pos_right t (by omega)).trans (Nat.le_add_left _ _) + have h₁ : (tm.configs cfg t₁).state = none := by + rw [← hperiod t, tm.halt_mono cfg hle ht] + exact ht + rw [heq] at h₁ + exact hnh h₁ + +open scoped Classical in +/-- A deterministic machine that halts does so within a number of steps bounded by the number of +distinct configurations it visits. If it is halted by step `T₀`, then it is already halted at some +step `τ` no larger than the count of distinct configurations reached within `T₀` steps: otherwise +the first `card + 1` configurations would be non-halting and, being more numerous than the distinct +configurations available, two would coincide, making the machine loop forever by +`not_halts_of_repeat_nonhalt`. Together with `card_configs_le` this turns a space bound into a +time bound. -/ +lemma exists_halt_le_card_image (tm : MultiTapeTM k Symbol State) (input : List Symbol) {T₀ : ℕ} + (h : (tm.configs (tm.initCfg input) T₀).state = none) : + ∃ τ ≤ ((Finset.range (T₀ + 1)).image (tm.configs (tm.initCfg input))).card, + τ ≤ T₀ ∧ (tm.configs (tm.initCfg input) τ).state = none := by + classical + set f := tm.configs (tm.initCfg input) with hf + have hex : ∃ m, (f m).state = none := ⟨T₀, h⟩ + have hm0h : (f (Nat.find hex)).state = none := Nat.find_spec hex + have hfind : Nat.find hex ≤ T₀ := Nat.find_le h + refine ⟨Nat.find hex, ?_, hfind, hm0h⟩ + have hnh : ∀ x ∈ Finset.range (Nat.find hex), (f x).state ≠ none := fun x hx => + Nat.find_min hex (Finset.mem_range.1 hx) + have hinj : Set.InjOn f (Finset.range (Nat.find hex)) := by + intro x _ y hy hxy + by_contra hne + exact tm.not_halts_of_repeat_nonhalt (tm.initCfg input) hne hxy (hnh y (Finset.mem_coe.1 hy)) + (Nat.find hex) hm0h + have hsub : (Finset.range (Nat.find hex)).image f ⊆ (Finset.range (T₀ + 1)).image f := + Finset.image_subset_image (by + intro x hx; simp only [Finset.mem_range] at hx ⊢; omega) + calc Nat.find hex = ((Finset.range (Nat.find hex)).image f).card := by + rw [Finset.card_image_of_injOn hinj, Finset.card_range] + _ ≤ ((Finset.range (T₀ + 1)).image f).card := Finset.card_le_card hsub + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/SpaceInTime.lean b/Cslib/Computability/Machines/Turing/MultiTape/SpaceInTime.lean new file mode 100644 index 0000000000..c334a2bcac --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/SpaceInTime.lean @@ -0,0 +1,120 @@ +/- +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.ConfigBound +public import Cslib.Computability.Machines.Turing.MultiTape.Classes + +import Mathlib.Tactic.Ring + +/-! +# From space bounds to time bounds + +A deterministic machine that decides a language in space `s` cannot repeat a configuration before +halting, so the number of steps is bounded by the number of reachable configurations. Combined with +the configuration count of `ConfigBound`, this yields the inclusion +`DSPACE(s) ⊆ DTIME(2^{O(s)})`. + +Two forms are provided: + +* `space_subset_time_general` makes no assumption on `s` and keeps the input-length factor + `BoundFun.linear`, which counts the read-only input-head positions. This factor is essential in + general: for `s = O(1)` the class is the regular languages, decided in `Θ(n)` time, so the + constant base `2 ^ (c * s n)` cannot absorb it. +* `space_subset_time` is the textbook statement `DSPACE(s) ⊆ DTIME(2^{O(s)})`, valid under the + assumption `s(n) ≥ log n`, here `BoundFun.log ≤ s`, under which the input-length factor is + absorbed into the exponential. + +Both are stated with `DTIMEOf` over an O-class of bound functions (`BoundFun.ExpO s` is `2^{O(s)}`, +`{BoundFun.linear} * BoundFun.ExpO s` is `n · 2^{O(s)}`), so that the constant hidden in the +exponent of `2^{O(s)}` does not appear in the statements, nor in the proofs: the machine-dependent +constants are introduced once by `storageBound_mem_ExpO` and absorbed by the closure properties of +the O-classes. + +Two inclusions for specific complexity classes are derived from this: + +* `logspace_subset_p` shows `L ⊆ P` +* `pspace_subset_exp` shows `PSPACE ⊆ EXP` + +-/ + +@[expose] public section + +open Cslib Cslib.BoundFun + +open scoped Pointwise + +namespace Turing.MultiTapeTM + +open scoped Classical in +/-- A Turing machine that computes `output` in `t` steps using space at most `σ` already computes +it within `(input.length + 2) * storageBound Symbol State k σ` steps, using no more space. -/ +lemma ComputesInTimeAndSpace.truncate + {Symbol State : Type} [Fintype Symbol] [Fintype State] + {k : ℕ} + {tm : MultiTapeTM k Symbol State} + {input output : List Symbol} + {t s σ : ℕ} + (h : tm.ComputesInTimeAndSpace input output t s) + (hσ : s ≤ σ) : + ∃ t' ≤ (input.length + 2) * storageBound Symbol State k σ, + ∃ s' ≤ s, tm.ComputesInTimeAndSpace input output t' s' := by + obtain ⟨hhalt, hout, hspace⟩ := h + obtain ⟨τ, hτcard, hτle, hτhalt⟩ := exists_halt_le_card_image tm input hhalt + rw [tm.outputString_eq_of_halt (tm.initCfg input) hτle hτhalt] at hout + exact ⟨τ, hτcard.trans (card_configs_le t σ (hspace.trans_le hσ)), + tm.spaceUsed (tm.initCfg input) τ, (spaceUsed_mono tm _ hτle).trans hspace.le, + hτhalt, hout, rfl⟩ + +/-- General form of the space-to-time inclusion, making no assumption on `s`. The time bound lies +in the class `{linear} * ExpO s`, i.e. it is `n · 2^{O(s)}`: the linear factor accounts for the +read-only input-head positions and cannot be dropped in general, since for `s = O(1)` the class is +the regular languages, which need `Θ(n)` time. -/ +theorem space_subset_time_general + {Symbol : Type} [Inhabited Symbol] + (s : BoundFun) : + DSPACE s ⊆ DTIMEOf (Symbol := Symbol) ({linear} * ExpO s) := by + rintro L ⟨s', hs', tBound, kk, sym, state, emb, tm, hcomp⟩ + set g := BoundFun.ofFun (fun n => storageBound (Fin sym) (Fin state) kk (s' n)) + refine mem_DTIMEOf_ofFun (S := ⇑s') (t := linear * g) + (T := fun n => (n + 2) * storageBound (Fin sym) (Fin state) kk (s' n)) ?_ ?_ + ⟨kk, sym, state, emb, tm, fun input => ?_⟩ + · -- The running time is at most `(n + 2)` times the number of storage configurations. + calc BoundFun.ofFun (fun n => (n + 2) * storageBound (Fin sym) (Fin state) kk (s' n)) + ≤ BoundFun.ofFun (fun n => n + 2) * g := BoundFun.ofFun_mul_le .. + _ ≤ linear * g := by gcongr; exact BoundFun.ofFun_add_const_le_linear 2 + · -- That bound is `n · 2^{O(s)}`, since the machine runs in space `s' ≤ s`. + exact Set.mul_mem_mul rfl (ExpO_subset_ExpO hs' (storageBound_mem_ExpO ..)) + · -- Truncate the computation to the configuration-count bound. + obtain ⟨t, -, σ, hσ, hcomp'⟩ := hcomp input + obtain ⟨t', ht', σ', hσ', hcs⟩ := hcomp'.truncate (σ := s' input.length) hσ + exact ⟨t', by simpa using ht', σ', hσ'.trans hσ, hcs⟩ + +/-- The textbook space-to-time inclusion `DSPACE(s) ⊆ DTIME(2^{O(s)})`, under the standard +assumption `s(n) ≥ log n`, here expressed as `BoundFun.log ≤ s`. It follows from +`space_subset_time_general` by absorbing the input-length factor into the exponential. -/ +theorem space_subset_time + {Symbol : Type} [Inhabited Symbol] (s : BoundFun) (hs : log ≤ s) : + DSPACE s ⊆ DTIMEOf (Symbol := Symbol) (ExpO s) := + (space_subset_time_general s).trans (DTIMEOf_mono (singleton_linear_mul_ExpO_subset hs)) + +open Classes + +/-- The inclusion `L ⊆ P`: every log-space decidable language is decidable in polynomial time, +since `2^{O(log n)}` is polynomial. -/ +theorem logspace_subset_p {Symbol : Type} [Inhabited Symbol] : + L (Symbol := Symbol) ⊆ P := + (space_subset_time log le_rfl).trans (DTIMEOf_mono ExpO_log_subset_PolyO) + +/-- The inclusion `PSPACE ⊆ EXP`: for a polynomially bounded space bound `s`, the time bound +`n · 2^{O(s)}` of `space_subset_time_general` is `2^{poly(n)}`. -/ +theorem pspace_subset_exp {Symbol : Type} [Inhabited Symbol] : + PSPACE (Symbol := Symbol) ⊆ EXP := + Set.iUnion₂_subset fun s hs => (space_subset_time_general s).trans + (DTIMEOf_mono (singleton_linear_mul_ExpO_subset_ExpPolyO hs)) + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean new file mode 100644 index 0000000000..269ff1704e --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -0,0 +1,144 @@ +/- +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 + +/-! +# Tape head visitation and space-usage lemmas + +This file collects lemmas about the set of positions visited by a work-tape head +(`MultiTapeTM.visitedByTapeHead`) and the resulting space-usage measures +(`MultiTapeTM.spaceUsedByTape`, `MultiTapeTM.spaceUsed`) that are not needed to state the core +definitions in `Deterministic.lean`, but are reusable building blocks for counting and bounding +arguments elsewhere (e.g. `ConfigBound.lean`). + +The key geometric facts are `MultiTapeTM.natAbs_le_spaceUsedByTape_of_mem_visited` and +`MultiTapeTM.content_natAbs_le_spaceUsedByTape`: starting from the all-blank tapes with every head +at `0` and moving by at most one cell per step, a computation in which tape `i` has visited at most +`sᵢ` cells keeps that tape's head position and every non-blank cell within `sᵢ` of the origin. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} +variable {State Symbol : Type*} +variable {input : List Symbol} +variable {tm : MultiTapeTM k Symbol State} +variable {cfg : Cfg k Symbol State input} + +lemma mem_visitedByTapeHead {t : ℕ} {i : Fin k} {z : ℤ} : + z ∈ tm.visitedByTapeHead cfg t i ↔ ∃ t' < t + 1, (tm.configs cfg t').workTapePos i = z := by + simp [visitedByTapeHead] + +lemma mem_visitedByTapeHead_self (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : + (tm.configs cfg t).workTapePos i ∈ tm.visitedByTapeHead cfg t i := + tm.mem_visitedByTapeHead.mpr ⟨t, by omega, rfl⟩ + +/-- The set of positions visited by a tape head is monotone in the number of steps. -/ +lemma visitedByTapeHead_mono (cfg : Cfg k Symbol State input) (i : Fin k) + {t t' : ℕ} (h : t ≤ t') : + tm.visitedByTapeHead cfg t i ⊆ tm.visitedByTapeHead cfg t' i := by + apply Finset.image_subset_image + grind + +/-- Discrete intermediate value: Starting from configuration `cfg`, every position between the +initial head position of tape `i` and the one after `t` steps is part of the "visited set" at +step `t`. -/ +lemma uIcc_subset_visitedByTapeHead (cfg : Cfg k Symbol State input) (i : Fin k) (t : ℕ) : + Finset.uIcc (cfg.workTapePos i) ((tm.configs cfg t).workTapePos i) + ⊆ tm.visitedByTapeHead cfg t i := by + induction t with + | zero => simpa [configs] using tm.mem_visitedByTapeHead_self cfg 0 i + | succ t ih => + intro z hz + have hstep : |(tm.configs cfg (t + 1)).workTapePos i - (tm.configs cfg t).workTapePos i| ≤ 1 := + configs_succ_eq_step' (tm := tm) ▸ tm.workTapePos_step_le _ i + have hmono := tm.visitedByTapeHead_mono cfg i (Nat.le_succ t) + have hself := tm.mem_visitedByTapeHead_self cfg (t + 1) i + grind [Finset.mem_uIcc] + +/-- If a work tape cell is changed after `t` steps, it must have been visited by the tape head. -/ +lemma mem_visitedByTapeHead_of_workTapes_ne + (j : Fin k) + (t : ℕ) + (z : ℤ) + (h : (tm.configs cfg t).workTapes j z ≠ cfg.workTapes j z) : + z ∈ tm.visitedByTapeHead cfg t j := by + induction t with + | zero => exact absurd (by simp [configs]) h + | succ t ih => + rw [configs_succ_eq_step'] at h + by_cases hz : z = (tm.configs cfg t).workTapePos j + · exact hz ▸ tm.visitedByTapeHead_mono cfg j (Nat.le_succ t) + (tm.mem_visitedByTapeHead_self cfg t j) + · rw [tm.step_workTapes_eq_of_ne _ j z hz] at h + exact tm.visitedByTapeHead_mono cfg j (Nat.le_succ t) (ih h) + +/-- Every position visited by the head of tape `i` lies within `spaceUsedByTape … i` of the +head's starting position: by the discrete intermediate value property, the whole interval between +the two positions has been visited, and `spaceUsedByTape` counts the visited positions. -/ +lemma natAbs_le_spaceUsedByTape_of_mem_visited + {i : Fin k} + {z : ℤ} + {t : ℕ} + (hz : z ∈ tm.visitedByTapeHead cfg t i) : + (z - cfg.workTapePos i).natAbs ≤ tm.spaceUsedByTape cfg t i := by + obtain ⟨t', ht', rfl⟩ := tm.mem_visitedByTapeHead.mp hz + have h1 := Finset.card_le_card + ((tm.uIcc_subset_visitedByTapeHead cfg i t').trans + (tm.visitedByTapeHead_mono cfg i (show t' ≤ t by omega))) + rw [Int.card_uIcc] at h1 + unfold spaceUsedByTape + omega + +/-- Every non-blank cell on work tape `i` lies within `spaceUsedByTape … i t` of the origin. -/ +lemma content_natAbs_le_spaceUsedByTape + {i : Fin k} + (t : ℕ) + (z : ℤ) + (h : (tm.configs (tm.initCfg input) t).workTapes i z ≠ none) : + z.natAbs ≤ tm.spaceUsedByTape (tm.initCfg input) t i := by + -- The work tapes start out blank, so any non-blank cell has been visited by the head; the + -- initial head position is `0`, so the displacement bound is a bound on the position itself. + simpa using tm.natAbs_le_spaceUsedByTape_of_mem_visited + (tm.mem_visitedByTapeHead_of_workTapes_ne i t z h) + +/-- 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 + _ ≤ (Finset.range (t + 1)).card := Finset.card_image_le + _ = t + 1 := Finset.card_range _ + +/-- 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] + +/-- The space used by a single tape is monotone in the number of steps. -/ +lemma spaceUsedByTape_mono + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) + (i : Fin k) : + Monotone (tm.spaceUsedByTape cfg · i) := by + intro t t' h + exact Finset.card_le_card (tm.visitedByTapeHead_mono cfg i h) + +/-- The total space used is monotone in the number of steps. -/ +lemma spaceUsed_mono (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) : + Monotone (tm.spaceUsed cfg ·) := by + intro t t' h + exact Finset.sum_le_sum (fun i _ => spaceUsedByTape_mono tm cfg i h) + +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..29f379d5ac 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} @@ -317,8 +318,7 @@ private theorem map_toCompCfg_right_step : cases cfg2 with | mk state BiTape => cases state with - | none => - simp only [step, toCompCfg_right, Option.map_none, compComputer] + | none => rfl | some q => generalize hM : tm2.tr q BiTape.head = result obtain ⟨⟨wr, dir⟩, nextState⟩ := result @@ -503,4 +503,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/README.md b/Cslib/Computability/README.md new file mode 100644 index 0000000000..f2ab58842f --- /dev/null +++ b/Cslib/Computability/README.md @@ -0,0 +1,35 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+ +# Computability + +This directory hosts **formal developments in computability and neighbouring areas**. Its scope includes automata, complexity classes, formal languages over finite and infinite words, and other machine models. + +## Principles + +### Multiple computational models + +There is a plethora of computational models in the literature, some of which are very near to each other (e.g., Turing machines and Wang B-machines). Depending on the aim, one can be more convenient than the other. +In general, computability can be studied through different kinds of objects. + +These representations can coexist when they serve different purposes. A central goal is to make their tradeoffs explicit and to connect them where possible. + +### Reuse of common infrastructure + +The [Foundations](../Foundations) directory offers abstractions that are directly useful for computability-theoretic developments and should be reused as much as possible. Examples already present in this directory include the use of labelled transition systems for automata and distributed algorithms, tape structures for Turing machines, and general relation-theoretic tools for machine semantics. + +This approach enables: +1. Reusing and transferring constructions and results across different models. +2. Applying CSLib's [logics](../Logics) to reason about computational models. +3. Developing connections between computability models and other areas (like the constructions of automata based on transition systems). + +### Separation from languages + +Some of the developments here are close to [Languages](../Languages), but are placed here instead because the emphasis is on formal languages over words and models typically linked to computability studies. + +## Plans and notes + +- We plan on expanding this directory with more machine models and associated results, including equivalence results, closure properties, and other metatheory. +- We plan on clarifying and formalising connections between language-theoretic, automata-theoretic, machine-based, and distributed perspectives on computation. 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/Computability/URM/StandardForm.lean b/Cslib/Computability/URM/StandardForm.lean index f1abcf344b..51a288b6bc 100644 --- a/Cslib/Computability/URM/StandardForm.lean +++ b/Cslib/Computability/URM/StandardForm.lean @@ -217,8 +217,9 @@ theorem eval_toStandardForm {p : Program} {inputs : List ℕ} : · simp only [Part.map_Dom] exact Halts.toStandardForm_iff · intro hp hq - simp only [Part.map_get, Function.comp_apply, Regs.output, - evalState_toStandardForm_regs hp hq] + have := Part.map_get (fun x : State => x.regs.output) (evalState p inputs) hp + have := Part.map_get (fun x : State => x.regs.output) (evalState p.toStandardForm inputs) hq + simp_all [Function.comp_def, evalState_toStandardForm_regs hp hq] /-- A program is equivalent to its standard form. -/ theorem toStandardForm_equiv (p : Program) : p.toStandardForm ≈ p := diff --git a/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean index bd0de00d3b..0c227bdd84 100644 --- a/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean +++ b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean @@ -174,7 +174,7 @@ private theorem privacyCorrectionPolynomial_degree_lt (r := fun i : s => (secret₀ - secret₁) / params.point i) (points_injOn_subtype (F := F) params s)) ?_ - simpa using hcard + simp [hcard] private noncomputable def privacyCorrection (params : Params F Party) (s : Finset Party) @@ -270,11 +270,10 @@ noncomputable def schemeWith (params : Params F Party) (sampler : TailSampler pa (Polynomial.sharingPolynomial secretValue (Polynomial.tailPolynomial params.threshold coeffs)).degree < Fintype.card s := by - simpa using - (lt_of_lt_of_le hdeg₀ (by exact_mod_cast hs) : - (Polynomial.sharingPolynomial secretValue - (Polynomial.tailPolynomial params.threshold coeffs)).degree < - s.card) + simp [(lt_of_lt_of_le hdeg₀ (by exact_mod_cast hs) : + (Polynomial.sharingPolynomial secretValue + (Polynomial.tailPolynomial params.threshold coeffs)).degree < + s.card)] have hx : Function.Injective (fun i : s => params.point i) := by intro i j hij exact Subtype.ext (params.point_injective hij) diff --git a/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean b/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean index 4cb4ced4f8..3ee93ac1ed 100644 --- a/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean +++ b/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean @@ -126,7 +126,7 @@ theorem reconstruct_eq_constantCoeff_of_eval_eq (s := Finset.univ) (v := x) hx.injOn - (by simpa using hdeg) + (by simp [hdeg]) simpa [reconstruct] using congrArg _root_.Polynomial.constantCoeff hp.symm /-- Reconstruction succeeds on the values of a Shamir sharing polynomial once diff --git a/Cslib/Crypto/README.md b/Cslib/Crypto/README.md new file mode 100644 index 0000000000..75ffac5366 --- /dev/null +++ b/Cslib/Crypto/README.md @@ -0,0 +1,26 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+ +# Crypto + +This directory hosts **cryptographic definitions, primitives, protocol models, and related security metatheory**. Its scope includes both basic cryptographic notions and larger developments such as security protocols. + +We aim at supporting both abstract security reasoning and concrete protocol developments, while making explicit the relations between them. To this end, this part of CSLib has very important relationships with [Languages](../Languages) and [Logics](../Logics), explained in the remainder. + +## Principles + +### Integration with languages + +Whenever appropriate, cryptographic primitives should be developed so that they compose well with CSLib's [languages](../Languages) that offer a way to integrate a computational substrate. This is common, for example, in choreographic programming languages and many process calculi. + +The aim is to build end-to-end models where cryptographic operations appear inside larger communicating or computational systems. + +To this end, we expect to leverage the combination of `Crypto` and [Languages](../Languages) to define and formally reason about security protocols. CSLib's common semantics APIs connecting [Languages](../Languages) and [Logics](../Logics) should enable such reasoning. + +## Plans and notes + +- We plan on developing applied calculi and logics for modelling and reasoning about security protocols. +- We plan on developing a comprehensive library of primitives and foundational protocols, together with their proofs of correctness. +- We plan on supporting downstream efforts on the development of secure digital infrastructures (including implementation of complex secure applications and systems). diff --git a/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean b/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean index 41cb0180dc..6d0712db97 100644 --- a/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean +++ b/Cslib/Foundations/Combinatorics/InfiniteGraphRamsey.lean @@ -29,12 +29,10 @@ open Function Set theorem infinite_pigeonhole_principle {X Y : Type*} [Finite Y] (f : X → Y) {s : Set X} (h_inf : s.Infinite) : ∃ y, ∃ t, t.Infinite ∧ t ⊆ s ∧ ∀ x ∈ t, f x = y := by have := h_inf.to_subtype - obtain ⟨y, h_inf'⟩ := Finite.exists_infinite_fiber (s.restrict f) + obtain ⟨y, h_inf'⟩ := Finite.exists_infinite_fiber (s.domRestrict f) have h_inf_iff := Equiv.infinite_iff <| Equiv.subtypeSubtypeEquivSubtypeInter (· ∈ s) (fun x ↦ f x = y) - simp only [coe_eq_subtype, mem_preimage, restrict_apply, mem_singleton_iff, h_inf_iff] at h_inf' - have h_inf'' := (infinite_coe_iff (s := { x | x ∈ s ∧ f x = y })).mp h_inf' - use y, {x | x ∈ s ∧ f x = y} + use y, {x | x ∈ s ∧ f x = y}, infinite_coe_iff.mp <| h_inf_iff.mp h_inf' grind /-- An `InfVSet` consists of a set of vertices and a proof that the set is infinite. -/ @@ -69,8 +67,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..09d550b8bc 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. @@ -184,11 +186,11 @@ theorem map_bind (f : β → γ) (x : FreeM F α) (c : α → FreeM F β) : @[simp] theorem id_map : ∀ x : FreeM F α, map id x = x | .pure a => rfl - | .liftBind op cont => by simp_all [map, id_map] + | .liftBind op cont => by simp [map, id_map] theorem comp_map (h : β → γ) (g : α → β) : ∀ x : FreeM F α, map (h ∘ g) x = map h (map g x) | .pure a => rfl - | .liftBind op cont => by simp_all [map, comp_map] + | .liftBind op cont => by simp [map, comp_map] instance : LawfulFunctor (FreeM F) where map_const := rfl 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/Nat/BigO.lean b/Cslib/Foundations/Data/Nat/BigO.lean new file mode 100644 index 0000000000..7cb7f6fd20 --- /dev/null +++ b/Cslib/Foundations/Data/Nat/BigO.lean @@ -0,0 +1,669 @@ +/- +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.Init +public import Mathlib.Algebra.Order.Monoid.Unbundled.Pow +public import Mathlib.Data.Nat.Log +public import Mathlib.Data.Finset.Lattice.Fold +public import Mathlib.Data.Finset.Range +public import Mathlib.Algebra.Group.Pointwise.Set.Basic + +import Mathlib.Tactic.GCongr +import Mathlib.Tactic.Ring + +/-! +# A big-O calculus for natural number bound functions + +Complexity theory is full of statements of the shape "the running time is `O(f)`". This file +provides a calculus for such bounds that is meant to be used with the resource bounds of Turing +machines, in `Cslib.Computability.Machines.Turing.MultiTape.Classes`. + +## Design + +Bound functions are *bundled*: a `BoundFun` is a monotone function `ℕ → ℕ` that is at least `1`. +Both assumptions are harmless for resource bounds (a machine reading its input already takes at +least one step, and resource bounds are traditionally assumed to be monotone), and both buy a lot: + +* Since `f ≥ 1`, domination `∃ c, ∀ n, f n ≤ c * g n` needs neither an additive constant nor an + eventuality threshold: constants and finitely many exceptional arguments are absorbed by the + multiplicative constant. So there is a *single* relation, and it is registered as the `≤` of a + `Preorder BoundFun`. **`f ≤ g` therefore means `f = O(g)`, not `∀ n, f n ≤ g n`.** +* Since bound functions are bundled, the calculus is an algebra on `BoundFun` (`*`, `+`, `^`, + `exp2`) rather than on lambda terms. Goals are lambda-free, `calc` works, and the covariance + instances `MulLeftMono`/`MulRightMono` make Mathlib's generic ordered-algebra lemmas + (`mul_le_mul'`, `pow_le_pow_left'`, `add_le_add`) and `gcongr` apply out of the box. +* Since bound functions are monotone, a plain function `F : ℕ → ℕ` (a concrete running time, which + need be neither monotone nor nonzero) is turned into a bound function by its monotone envelope + `BoundFun.ofFun`. `BoundFun.le_ofFun` and `BoundFun.ofFun_le` are the interface: a pointwise + bound `∀ n, F n ≤ c * g n` gives `ofFun F ≤ g` with no monotonicity side goal. + +The atoms are `BoundFun.const c` (the constant `c + 1`), `BoundFun.linear` (`n + 1`), +`BoundFun.log` (`Nat.log 2 n + 1`) and `BoundFun.exp2 e` (`2 ^ e n`). All of them are normalised by +a `+ 1` so that they are at least `1`; this does not change the class of dominated functions, +since all constants are equivalent (`BoundFun.const_le`) and `n + 1` dominates `n`. + +Note that `exp2` is *not* monotone for `≤`: `e₁ ≤ e₂` only bounds `e₁` by `c * e₂`, and +`2 ^ (c * e₂ n)` is not `O(2 ^ e₂ n)`. The correct rules are `BoundFun.exp2_le_exp2` (pointwise +comparison of exponents) and `BoundFun.exp2_le_exp2_of_le_add` (pointwise comparison up to an +additive constant in the exponent, which the multiplicative constant absorbs). + +For the same reason, `2 ^ O(s)` is not of the form `O(g)` for a single bound function `g`: it is a +genuine *family*. Such families are therefore named once and for all as sets of bound functions +(`BoundFun.ExpO`, `BoundFun.PolyO`, `BoundFun.ExpPolyO`), and the calculus is lifted to them +(`BoundFun.ExpO_subset_ExpO`, `BoundFun.mul_mem_ExpO`, ...). Statements about these classes mention +no constants at all, and the exponent constant of `2 ^ O(s)` is absorbed once, in +`BoundFun.ExpO_subset_ExpO`. + +## Main results + +* `BoundFun`, its algebra (`CommMonoid`, `Add`, `exp2`) and the `Preorder` whose `≤` is + domination. +* `BoundFun.ofFun`, `BoundFun.le_ofFun`, `BoundFun.ofFun_le`: the entry point for plain functions. +* Base facts such as `BoundFun.one_le`, `BoundFun.const_le`, `BoundFun.le_mul_right`, + `BoundFun.log_le_linear`, `BoundFun.linear_le_exp2_linear`, `BoundFun.exp2_log_le_linear`. +* `BoundFun.exp2_add`, `BoundFun.exp2_const_mul`: the exponential algebra, as equalities. +* Absorption facts such as `BoundFun.linear_mul_exp2_le`, `BoundFun.exp2_const_mul_log_le` and + `BoundFun.exp2_const_mul_pow_le`. +* The O-classes `BoundFun.O`, `BoundFun.ExpO`, `BoundFun.PolyO` and `BoundFun.ExpPolyO`, together + with their closure properties. These are sets of bound functions, which is what allows statements + such as `2 ^ O(s)` to be made without mentioning any constant. +* The `bigO` tactic, which normalises the exponential algebra, descends with `gcongr` and closes + the resulting leaves with the base facts. +-/ + +@[expose] public section + +namespace Cslib + +/-- A bound function: a monotone function `ℕ → ℕ` that is at least `1`. See the module +documentation for why these assumptions are made. -/ +structure BoundFun where + /-- The underlying function. -/ + toFun : ℕ → ℕ + /-- Bound functions are monotone. -/ + monotone' : Monotone toFun + /-- Bound functions are at least `1`. -/ + one_le_apply' : 1 ≤ toFun 0 + +namespace BoundFun + +instance : CoeFun BoundFun fun _ => ℕ → ℕ := ⟨toFun⟩ + +@[simp] theorem coe_mk (f : ℕ → ℕ) (hm hp) : ⇑(mk f hm hp) = f := rfl + +@[ext] theorem ext {f g : BoundFun} (h : ∀ n, f n = g n) : f = g := by + cases f; cases g; simpa using funext h + +/-- Bound functions are monotone. -/ +theorem monotone (f : BoundFun) : Monotone ⇑f := f.monotone' + +/-- Bound functions are at least `1` everywhere. -/ +theorem one_le_apply (f : BoundFun) (n : ℕ) : 1 ≤ f n := + f.one_le_apply'.trans (f.monotone (Nat.zero_le n)) + +/-- Bound functions are positive. -/ +theorem pos_apply (f : BoundFun) (n : ℕ) : 0 < f n := f.one_le_apply n + +/-! ### Algebra -/ + +/-- The pointwise product of bound functions. -/ +protected def mul (f g : BoundFun) : BoundFun := + ⟨fun n => f n * g n, fun _ _ h => Nat.mul_le_mul (f.monotone h) (g.monotone h), + Nat.one_le_iff_ne_zero.2 (Nat.mul_ne_zero (f.pos_apply 0).ne' (g.pos_apply 0).ne')⟩ + +/-- The constant bound function `1`. -/ +protected def one : BoundFun := ⟨fun _ => 1, monotone_const, le_rfl⟩ + +/-- The pointwise `k`-th power of a bound function. -/ +protected def pow (f : BoundFun) (k : ℕ) : BoundFun := + ⟨fun n => f n ^ k, fun _ _ h => Nat.pow_le_pow_left (f.monotone h) k, + Nat.one_le_pow _ _ (f.pos_apply 0)⟩ + +instance : CommMonoid BoundFun where + mul := BoundFun.mul + one := BoundFun.one + npow k f := f.pow k + mul_assoc _ _ _ := by ext n; exact Nat.mul_assoc .. + one_mul _ := by ext n; exact Nat.one_mul .. + mul_one _ := by ext n; exact Nat.mul_one .. + mul_comm _ _ := by ext n; exact Nat.mul_comm .. + npow_zero _ := by ext n; exact pow_zero .. + npow_succ _ _ := by ext n; exact pow_succ .. + +/-- The pointwise sum of bound functions. -/ +instance : Add BoundFun := + ⟨fun f g => ⟨fun n => f n + g n, fun _ _ h => Nat.add_le_add (f.monotone h) (g.monotone h), + (f.one_le_apply 0).trans (Nat.le_add_right ..)⟩⟩ + +@[simp] theorem mul_apply (f g : BoundFun) (n : ℕ) : (f * g) n = f n * g n := rfl +@[simp] theorem one_apply (n : ℕ) : (1 : BoundFun) n = 1 := rfl +@[simp] theorem pow_apply (f : BoundFun) (k n : ℕ) : (f ^ k) n = f n ^ k := rfl +@[simp] theorem add_apply (f g : BoundFun) (n : ℕ) : (f + g) n = f n + g n := rfl + +/-! ### Atoms -/ + +/-- The constant bound function with value `c + 1`. The `+ 1` normalises the value to be at least +`1`; since all constants dominate each other (`const_le`), this is no loss. -/ +def const (c : ℕ) : BoundFun := ⟨fun _ => c + 1, monotone_const, Nat.le_add_left ..⟩ + +/-- The bound function `n + 1`, the normalised form of the identity. -/ +def linear : BoundFun := ⟨fun n => n + 1, fun _ _ h => Nat.add_le_add_right h 1, Nat.le_refl 1⟩ + +/-- The bound function `Nat.log 2 n + 1`, the normalised binary logarithm. It agrees with +`Nat.log2 n + 1` by `Nat.log2_eq_log_two`. -/ +def log : BoundFun := + ⟨fun n => Nat.log 2 n + 1, fun _ _ h => Nat.add_le_add_right (Nat.log_mono_right h) 1, + Nat.le_add_left ..⟩ + +/-- The bound function `2 ^ e n`. -/ +def exp2 (e : BoundFun) : BoundFun := + ⟨fun n => 2 ^ e n, fun _ _ h => Nat.pow_le_pow_right (by omega) (e.monotone h), + Nat.one_le_two_pow⟩ + +@[simp] theorem const_apply (c n : ℕ) : const c n = c + 1 := rfl +@[simp] theorem linear_apply (n : ℕ) : linear n = n + 1 := rfl +@[simp] theorem log_apply (n : ℕ) : log n = Nat.log 2 n + 1 := rfl +@[simp] theorem exp2_apply (e : BoundFun) (n : ℕ) : exp2 e n = 2 ^ e n := rfl + +/-! ### Domination -/ + +/-- Domination of bound functions is the `≤` of a `Preorder`: `f ≤ g` means `f = O(g)`, i.e. +`f n ≤ c * g n` for some constant `c` and all `n`. Since bound functions are at least `1`, no +additive constant and no eventuality threshold are needed. -/ +instance : Preorder BoundFun where + le f g := ∃ c, ∀ n, f n ≤ c * g n + le_refl _ := ⟨1, fun n => by simp⟩ + le_trans _ _ _ := by + rintro ⟨a, ha⟩ ⟨b, hb⟩ + refine ⟨a * b, fun n => (ha n).trans ?_⟩ + calc _ ≤ a * (b * _) := by gcongr; exact hb n + _ = a * b * _ := by ring + +theorem le_def {f g : BoundFun} : f ≤ g ↔ ∃ c, ∀ n, f n ≤ c * g n := Iff.rfl + +/-- Introduction rule for domination. -/ +theorem le_of_forall_le_mul {f g : BoundFun} {c : ℕ} (h : ∀ n, f n ≤ c * g n) : f ≤ g := ⟨c, h⟩ + +/-- A pointwise inequality is a domination. -/ +theorem le_of_forall_le {f g : BoundFun} (h : ∀ n, f n ≤ g n) : f ≤ g := + le_of_forall_le_mul (c := 1) fun n => by simpa using h n + +/-- Elimination rule for domination. -/ +theorem exists_le_mul {f g : BoundFun} (h : f ≤ g) : ∃ c, ∀ n, f n ≤ c * g n := h + +instance : MulLeftMono BoundFun := + ⟨fun f _ _ h => by + obtain ⟨c, hc⟩ := h + refine ⟨c, fun n => ?_⟩ + simp only [mul_apply] + calc f n * _ ≤ f n * (c * _) := by gcongr; exact hc n + _ = c * (f n * _) := by ring⟩ + +instance : MulRightMono BoundFun := + ⟨fun f _ _ h => by + obtain ⟨c, hc⟩ := h + refine ⟨c, fun n => ?_⟩ + simp only [mul_apply] + calc _ * f n ≤ c * _ * f n := by gcongr; exact hc n + _ = c * (_ * f n) := by ring⟩ + +instance : AddLeftMono BoundFun := + ⟨fun f g₁ g₂ (h : g₁ ≤ g₂) => by + obtain ⟨c, hc⟩ := h + refine ⟨c + 1, fun n => ?_⟩ + have h1 := hc n + have h2 : (c + 1) * (f n + g₂ n) = c * g₂ n + (f n + c * f n + g₂ n) := by ring + simp only [add_apply] + omega⟩ + +instance : AddRightMono BoundFun := + ⟨fun f g₁ g₂ (h : g₁ ≤ g₂) => by + obtain ⟨c, hc⟩ := h + refine ⟨c + 1, fun n => ?_⟩ + have h1 := hc n + have h2 : (c + 1) * (g₂ n + f n) = c * g₂ n + (f n + c * f n + g₂ n) := by ring + simp only [Function.swap, add_apply] + omega⟩ + +/-! ### Base facts -/ + +/-- Every bound function dominates the constant `1`. -/ +@[simp] theorem one_le (f : BoundFun) : 1 ≤ f := + le_of_forall_le fun n => f.one_le_apply n + +/-- Constants are dominated by `1`. -/ +theorem const_le_one (c : ℕ) : const c ≤ 1 := + le_of_forall_le_mul (c := c + 1) fun _ => by simp + +/-- Every constant is dominated by every bound function: constants are the bottom of the order. -/ +@[simp] theorem const_le (c : ℕ) (f : BoundFun) : const c ≤ f := (const_le_one c).trans (one_le f) + +/-- A product dominates its left factor. -/ +@[simp] theorem le_mul_right (f g : BoundFun) : f ≤ f * g := + le_of_forall_le fun n => Nat.le_mul_of_pos_right _ (g.pos_apply n) + +/-- A product dominates its right factor. -/ +@[simp] theorem le_mul_left (f g : BoundFun) : g ≤ f * g := + le_of_forall_le fun n => Nat.le_mul_of_pos_left _ (f.pos_apply n) + +/-- A sum is dominated by any common upper bound; sums are suprema for `≤`. -/ +theorem add_le {f g h : BoundFun} (h₁ : f ≤ h) (h₂ : g ≤ h) : f + g ≤ h := by + obtain ⟨a, ha⟩ := h₁ + obtain ⟨b, hb⟩ := h₂ + refine ⟨a + b, fun n => ?_⟩ + have := ha n + have := hb n + have : (a + b) * h n = a * h n + b * h n := by ring + simp only [add_apply] + omega + +/-- A sum dominates its left summand. -/ +@[simp] theorem le_add_right (f g : BoundFun) : f ≤ f + g := + le_of_forall_le fun _ => Nat.le_add_right .. + +/-- A sum dominates its right summand. -/ +@[simp] theorem le_add_left (f g : BoundFun) : g ≤ f + g := + le_of_forall_le fun _ => Nat.le_add_left .. + +/-- Constant factors can be dropped. -/ +theorem const_mul_le_of_le {f g : BoundFun} {c : ℕ} (h : f ≤ g) : const c * f ≤ g := + calc const c * f ≤ 1 * f := by gcongr; exact const_le_one c + _ = f := one_mul f + _ ≤ g := h + +/-- A product is dominated by a bound of its left factor if the right factor is constant. -/ +theorem mul_le_of_le_of_le_one {f g h : BoundFun} (h₁ : f ≤ h) (h₂ : g ≤ 1) : f * g ≤ h := + calc f * g ≤ h * 1 := mul_le_mul' h₁ h₂ + _ = h := mul_one h + +/-- A bound function is dominated by its powers. -/ +theorem le_pow_of_le {f g : BoundFun} {k : ℕ} (h : f ≤ g) : f ≤ g ^ (k + 1) := + h.trans <| le_of_forall_le fun n => Nat.le_self_pow (by omega) _ + +/-- Powers grow with the exponent. -/ +theorem pow_le_pow_exp (f : BoundFun) {k l : ℕ} (h : k ≤ l) : f ^ k ≤ f ^ l := + le_of_forall_le fun n => Nat.pow_le_pow_right (f.one_le_apply n) h + +/-! ### The exponential -/ + +/-- The exponential turns sums into products. -/ +theorem exp2_add (e₁ e₂ : BoundFun) : exp2 (e₁ + e₂) = exp2 e₁ * exp2 e₂ := by + ext n; exact pow_add .. + +/-- A constant factor in the exponent becomes a power. -/ +theorem exp2_const_mul (c : ℕ) (e : BoundFun) : exp2 (const c * e) = exp2 e ^ (c + 1) := by + ext n; rw [exp2_apply, mul_apply, const_apply, pow_apply, exp2_apply, ← pow_mul, Nat.mul_comm] + +/-- Two exponentials with a constant in the exponent multiply to a single one: the constants add +(the `+ 1` accounts for the normalisation of `const`). -/ +theorem exp2_const_mul_mul (a b : ℕ) (e : BoundFun) : + exp2 (const a * e) * exp2 (const b * e) = exp2 (const (a + b + 1) * e) := by + ext n + simp only [mul_apply, exp2_apply, const_apply, ← pow_add] + ring_nf + +/-- The exponential is monotone for the *pointwise* order on exponents. It is not monotone for +domination of exponents. -/ +theorem exp2_le_exp2 {e₁ e₂ : BoundFun} (h : ∀ n, e₁ n ≤ e₂ n) : exp2 e₁ ≤ exp2 e₂ := + le_of_forall_le fun n => Nat.pow_le_pow_right (by omega) (h n) + +/-- An additive constant in the exponent is absorbed by the multiplicative constant of `≤`. -/ +theorem exp2_le_exp2_of_le_add {e₁ e₂ : BoundFun} {K : ℕ} (h : ∀ n, e₁ n ≤ e₂ n + K) : + exp2 e₁ ≤ exp2 e₂ := + le_of_forall_le_mul (c := 2 ^ K) fun n => + calc 2 ^ e₁ n ≤ 2 ^ (e₂ n + K) := Nat.pow_le_pow_right (by omega) (h n) + _ = 2 ^ K * 2 ^ e₂ n := by rw [pow_add]; ring + +/-- A constant exponent gives a constant. -/ +@[simp] theorem exp2_const_le_one (c : ℕ) : exp2 (const c) ≤ 1 := + le_of_forall_le_mul (c := 2 ^ (c + 1)) fun _ => by simp + +/-- `log₂ n ≤ n`. -/ +@[simp] theorem log_le_linear : log ≤ linear := + le_of_forall_le fun n => Nat.add_le_add_right (Nat.log_le_self 2 n) 1 + +/-- `n + 1 ≤ 2 ^ (log₂ n + 1)`. -/ +@[simp] theorem linear_le_exp2_log : linear ≤ exp2 log := + le_of_forall_le fun n => Nat.lt_pow_succ_log_self (by omega) n + +/-- `2 ^ (log₂ n + 1) = O(n)`. -/ +@[simp] theorem exp2_log_le_linear : exp2 log ≤ linear := + le_of_forall_le_mul (c := 2) fun n => by + rcases Nat.eq_zero_or_pos n with rfl | hn + · simp + · calc 2 ^ (Nat.log 2 n + 1) = 2 * 2 ^ Nat.log 2 n := by rw [pow_succ]; ring + _ ≤ 2 * n := by gcongr; exact Nat.pow_log_le_self 2 hn.ne' + _ ≤ 2 * (n + 1) := by gcongr; omega + +/-- `n + 1 ≤ 2 ^ (n + 1)`. -/ +@[simp] theorem linear_le_exp2_linear : linear ≤ exp2 linear := + le_of_forall_le fun n => by + calc n + 1 ≤ 2 ^ n := Nat.lt_two_pow_self + _ ≤ 2 ^ (n + 1) := Nat.pow_le_pow_right (by omega) (by omega) + +/-! ### Plain functions -/ + +/-- The monotone envelope of a plain function: `ofFun F n` is `1` plus the maximum of `F` on +`[0, n]`. This is the way a concrete resource bound (which is in general neither monotone nor +nonzero) enters the calculus. -/ +def ofFun (F : ℕ → ℕ) : BoundFun := + ⟨fun n => (Finset.range (n + 1)).sup F + 1, + fun _ _ h => + Nat.add_le_add_right + (Finset.sup_mono (Finset.range_subset_range.2 (Nat.add_le_add_right h 1))) 1, + Nat.le_add_left ..⟩ + +/-- A function is bounded by its monotone envelope. -/ +theorem le_ofFun (F : ℕ → ℕ) (n : ℕ) : F n ≤ ofFun F n := by + have := Finset.le_sup (f := F) (Finset.self_mem_range_succ n) + simp only [ofFun] + omega + +/-- The key intro rule: a pointwise bound of a plain function by a constant multiple of a bound +function dominates the whole monotone envelope, with no monotonicity side goal. -/ +theorem ofFun_le {F : ℕ → ℕ} {g : BoundFun} {c : ℕ} (h : ∀ n, F n ≤ c * g n) : ofFun F ≤ g := by + refine le_of_forall_le_mul (c := c + 1) fun n => ?_ + have hsup : (Finset.range (n + 1)).sup F ≤ c * g n := by + refine Finset.sup_le fun m hm => (h m).trans ?_ + gcongr + exact g.monotone (by simpa [Nat.lt_succ_iff] using Finset.mem_range.1 hm) + have h1 : 1 ≤ g n := g.one_le_apply n + have : (c + 1) * g n = c * g n + g n := by ring + simp only [ofFun] + omega + +/-- The envelope of a constant function is constant. -/ +theorem ofFun_const_le (a : ℕ) : ofFun (fun _ => a) ≤ 1 := ofFun_le (c := a) fun _ => by simp + +/-- The envelope of a product is dominated by the product of the envelopes. -/ +theorem ofFun_mul_le (F G : ℕ → ℕ) : ofFun (fun n => F n * G n) ≤ ofFun F * ofFun G := by + refine le_of_forall_le fun n => ?_ + have hsup : (Finset.range (n + 1)).sup (fun n => F n * G n) + ≤ (Finset.range (n + 1)).sup F * (Finset.range (n + 1)).sup G := + Finset.sup_le fun m hm => Nat.mul_le_mul (Finset.le_sup hm) (Finset.le_sup hm) + simp only [ofFun, mul_apply] + have hring : ((Finset.range (n + 1)).sup F + 1) * ((Finset.range (n + 1)).sup G + 1) + = (Finset.range (n + 1)).sup F * (Finset.range (n + 1)).sup G + + ((Finset.range (n + 1)).sup F + (Finset.range (n + 1)).sup G + 1) := by ring + omega + +/-- Bridge from a plain exponential bound to the `exp2` algebra: a bound of the shape +`a * 2 ^ (c * e n)` is `O(2 ^ ((c + 1) * e n))`, which is `exp2 (const c * e)`. -/ +theorem ofFun_le_exp2_const_mul {F : ℕ → ℕ} {e : BoundFun} {a c : ℕ} + (h : ∀ n, F n ≤ a * 2 ^ (c * e n)) : ofFun F ≤ exp2 (const c * e) := + ofFun_le (c := a) fun n => (h n).trans <| Nat.mul_le_mul_left a <| + Nat.pow_le_pow_right (by omega) (Nat.mul_le_mul_right _ (Nat.le_succ c)) + +/-- The envelope of `n + k` is linear: additive constants are absorbed. -/ +theorem ofFun_add_const_le_linear (k : ℕ) : ofFun (fun n => n + k) ≤ linear := + ofFun_le (c := k + 1) fun n => by + have h : (k + 1) * linear n = n + k + (k * n + 1) := by simp only [linear_apply]; ring + rw [h] + exact Nat.le_add_right .. + +/-! ### Absorption facts -/ + +/-- A linear factor is absorbed by an exponential whose exponent dominates the logarithm: this is +the standard hypothesis `s(n) ≥ log n` of the space-to-time theorem. -/ +theorem linear_mul_exp2_le {s : BoundFun} {d : ℕ} (hd : ∀ n, log n ≤ d * s n) (c : ℕ) : + linear * exp2 (const c * s) ≤ exp2 (const (c + d) * s) := by + refine le_of_forall_le fun n => ?_ + have hlin : n + 1 ≤ 2 ^ (d * s n) := + (Nat.lt_pow_succ_log_self (b := 2) (by omega) n).trans_le + (Nat.pow_le_pow_right (by omega) (hd n)) + simp only [mul_apply, linear_apply, exp2_apply, const_apply] + calc (n + 1) * 2 ^ ((c + 1) * s n) ≤ 2 ^ (d * s n) * 2 ^ ((c + 1) * s n) := by gcongr + _ = 2 ^ ((c + d + 1) * s n) := by rw [← pow_add]; ring_nf + +/-- `2 ^ (c · log n)` is polynomial. The `bigO` tactic, defined below, closes this goal as well. -/ +theorem exp2_const_mul_log_le (c : ℕ) : exp2 (const c * log) ≤ linear ^ (c + 1) := by + rw [exp2_const_mul] + gcongr + exact exp2_log_le_linear + +private theorem mul_pow_le_pow_succ_add (c m k : ℕ) : + c * m ^ k ≤ m ^ (k + 1) + c ^ (k + 1) := by + rcases le_or_gt c m with h | h + · calc c * m ^ k ≤ m * m ^ k := by gcongr + _ = m ^ (k + 1) := by ring + _ ≤ m ^ (k + 1) + c ^ (k + 1) := Nat.le_add_right .. + · calc c * m ^ k ≤ c * c ^ k := by gcongr; omega + _ = c ^ (k + 1) := by ring + _ ≤ m ^ (k + 1) + c ^ (k + 1) := Nat.le_add_left .. + +/-- A constant factor in a polynomial exponent is absorbed by the next power. -/ +theorem exp2_const_mul_pow_le (c k : ℕ) : + exp2 (const c * linear ^ (k + 1)) ≤ exp2 (linear ^ (k + 2)) := + exp2_le_exp2_of_le_add (K := (c + 1) ^ (k + 2)) fun n => by + simpa using mul_pow_le_pow_succ_add (c + 1) (n + 1) (k + 1) + +/-! ### O-classes + +`2 ^ O(s)` is not a single bound function but a *family*, so the statements about it are about a +set of bound functions. The classes below are the ones that occur in complexity theory; they are +all lower sets for domination, and closed under products, which is what makes the constants of the +underlying calculus invisible in statements about them. -/ + +/-- The class `O(g)` of bound functions dominated by `g`. -/ +def O (g : BoundFun) : Set BoundFun := {f | f ≤ g} + +/-- The class `2 ^ O(s)` of bound functions dominated by `2 ^ (c * s)` for some constant `c`. -/ +def ExpO (s : BoundFun) : Set BoundFun := {f | ∃ c, f ≤ exp2 (const c * s)} + +/-- The class `poly(n) = n ^ O(1)` of polynomially bounded bound functions. -/ +def PolyO : Set BoundFun := {f | ∃ k, f ≤ linear ^ k} + +/-- The class `2 ^ poly(n)` of bound functions with a polynomial exponent. -/ +def ExpPolyO : Set BoundFun := {f | ∃ k, f ≤ exp2 (linear ^ k)} + +@[simp] theorem mem_O {f g : BoundFun} : f ∈ O g ↔ f ≤ g := Iff.rfl +@[simp] theorem mem_ExpO {f s : BoundFun} : f ∈ ExpO s ↔ ∃ c, f ≤ exp2 (const c * s) := Iff.rfl +@[simp] theorem mem_PolyO {f : BoundFun} : f ∈ PolyO ↔ ∃ k, f ≤ linear ^ k := Iff.rfl +@[simp] theorem mem_ExpPolyO {f : BoundFun} : f ∈ ExpPolyO ↔ ∃ k, f ≤ exp2 (linear ^ k) := Iff.rfl + +/-! #### Lower-closedness -/ + +/-- `O(g)` is a lower set for domination. -/ +theorem mem_O_of_le {f g e : BoundFun} (h : f ≤ g) (hg : g ∈ O e) : f ∈ O e := h.trans hg + +/-- `2 ^ O(s)` is a lower set for domination. -/ +theorem mem_ExpO_of_le {f g s : BoundFun} (h : f ≤ g) (hg : g ∈ ExpO s) : f ∈ ExpO s := + let ⟨c, hc⟩ := hg; ⟨c, h.trans hc⟩ + +/-- `poly(n)` is a lower set for domination. -/ +theorem mem_PolyO_of_le {f g : BoundFun} (h : f ≤ g) (hg : g ∈ PolyO) : f ∈ PolyO := + let ⟨k, hk⟩ := hg; ⟨k, h.trans hk⟩ + +/-- `2 ^ poly(n)` is a lower set for domination. -/ +theorem mem_ExpPolyO_of_le {f g : BoundFun} (h : f ≤ g) (hg : g ∈ ExpPolyO) : f ∈ ExpPolyO := + let ⟨k, hk⟩ := hg; ⟨k, h.trans hk⟩ + +/-- `O` is monotone. -/ +theorem O_subset_O {g₁ g₂ : BoundFun} (h : g₁ ≤ g₂) : O g₁ ⊆ O g₂ := fun _ hf => hf.trans h + +/-- Any dominated bound function generates a subclass. -/ +theorem O_subset_ExpO {g s : BoundFun} (h : g ∈ ExpO s) : O g ⊆ ExpO s := + fun _ hf => mem_ExpO_of_le hf h + +/-- **The `O` in the exponent absorbs domination of the exponent**: this is the lemma that makes +the constant of a space bound invisible in `2 ^ O(s)`. -/ +theorem ExpO_subset_ExpO {s₁ s₂ : BoundFun} (h : s₁ ≤ s₂) : ExpO s₁ ⊆ ExpO s₂ := by + rintro f ⟨c, hf⟩ + obtain ⟨d, hd⟩ := h + refine ⟨(c + 1) * d, hf.trans (exp2_le_exp2 fun n => ?_)⟩ + simp only [mul_apply, const_apply] + calc (c + 1) * s₁ n ≤ (c + 1) * (d * s₂ n) := by gcongr; exact hd n + _ = (c + 1) * d * s₂ n := by ring + _ ≤ ((c + 1) * d + 1) * s₂ n := by gcongr; omega + +/-! #### Closure under multiplication -/ + +/-- `1` is in `2 ^ O(s)`. -/ +theorem one_mem_ExpO (s : BoundFun) : (1 : BoundFun) ∈ ExpO s := ⟨0, one_le _⟩ + +/-- `2 ^ O(s)` is closed under products, since the exponents add. -/ +theorem mul_mem_ExpO {f g s : BoundFun} (hf : f ∈ ExpO s) (hg : g ∈ ExpO s) : f * g ∈ ExpO s := + let ⟨a, ha⟩ := hf + let ⟨b, hb⟩ := hg + ⟨a + b + 1, by rw [← exp2_const_mul_mul]; exact mul_le_mul' ha hb⟩ + +/-! #### Membership in `2 ^ O(s)` + +These are the rules by which concrete bounds enter `2 ^ O(σ)`. Together they cover the shapes that +occur in configuration counts: constants, polynomials in `σ` and powers of a fixed base with an +exponent that is affine in `σ`. Each of them provides the constant in the exponent, so consumers +never have to exhibit one. -/ + +/-- Polynomials in `σ` are `2 ^ O(σ)`: this is the textbook `poly(s) ⊆ 2^{O(s)}`. -/ +theorem pow_mem_ExpO (k : ℕ) (σ : BoundFun) : σ ^ k ∈ ExpO σ := by + refine ⟨k, le_of_forall_le fun n => ?_⟩ + simp only [pow_apply, exp2_apply, mul_apply, const_apply] + calc σ n ^ k ≤ (2 ^ σ n) ^ k := Nat.pow_le_pow_left Nat.lt_two_pow_self.le k + _ = 2 ^ (k * σ n) := by rw [← pow_mul, Nat.mul_comm] + _ ≤ 2 ^ ((k + 1) * σ n) := Nat.pow_le_pow_right (by omega) + (Nat.mul_le_mul_right _ (Nat.le_succ k)) + +/-- A plain function that is `O(σ)` pointwise has all its powers in `2 ^ O(σ)`. -/ +theorem ofFun_pow_mem_ExpO {F : ℕ → ℕ} {σ : BoundFun} (k c : ℕ) (h : ∀ n, F n ≤ c * σ n) : + ofFun (fun n => F n ^ k) ∈ ExpO σ := + mem_ExpO_of_le + (ofFun_le (c := c ^ k) fun n => by + calc F n ^ k ≤ (c * σ n) ^ k := Nat.pow_le_pow_left (h n) k + _ = c ^ k * (σ ^ k) n := by simp only [pow_apply, mul_pow]) + (pow_mem_ExpO k σ) + +/-- A power of a fixed base with an exponent that is affine in `σ` is `2 ^ O(σ)`: the change of +base only costs a factor in the exponent. -/ +theorem ofFun_base_pow_mem_ExpO {F : ℕ → ℕ} {σ : BoundFun} (B a b : ℕ) + (h : ∀ n, F n ≤ a * σ n + b) : ofFun (fun n => B ^ F n) ∈ ExpO σ := by + refine ⟨B * a, ofFun_le_exp2_const_mul (a := 2 ^ (B * b)) fun n => ?_⟩ + calc B ^ F n ≤ (2 ^ B) ^ F n := Nat.pow_le_pow_left Nat.lt_two_pow_self.le _ + _ ≤ (2 ^ B) ^ (a * σ n + b) := Nat.pow_le_pow_right Nat.one_le_two_pow (h n) + _ = 2 ^ (B * b) * 2 ^ (B * a * σ n) := by rw [← pow_mul, ← pow_add]; ring_nf + +/-- A constant is `2 ^ O(σ)`. -/ +theorem ofFun_const_mem_ExpO (a : ℕ) (σ : BoundFun) : ofFun (fun _ => a) ∈ ExpO σ := + mem_ExpO_of_le (ofFun_const_le a) (one_mem_ExpO σ) + +/-- Products of plain functions in `2 ^ O(σ)` are in `2 ^ O(σ)`. This is the form in which a +configuration count is decomposed into its factors. -/ +theorem ofFun_mul_mem_ExpO {F G : ℕ → ℕ} {σ : BoundFun} (hF : ofFun F ∈ ExpO σ) + (hG : ofFun G ∈ ExpO σ) : ofFun (fun n => F n * G n) ∈ ExpO σ := + mem_ExpO_of_le (ofFun_mul_le F G) (mul_mem_ExpO hF hG) + +/-- `1` is polynomially bounded. -/ +theorem one_mem_PolyO : (1 : BoundFun) ∈ PolyO := ⟨0, by simp⟩ + +/-- Powers of `linear` are polynomially bounded. -/ +theorem pow_linear_mem_PolyO (k : ℕ) : linear ^ k ∈ PolyO := ⟨k, le_rfl⟩ + +/-- `poly(n)` is closed under products. -/ +theorem mul_mem_PolyO {f g : BoundFun} (hf : f ∈ PolyO) (hg : g ∈ PolyO) : f * g ∈ PolyO := + let ⟨k, hk⟩ := hf + let ⟨l, hl⟩ := hg + ⟨k + l, by rw [pow_add]; exact mul_le_mul' hk hl⟩ + +/-- `linear` has a polynomial exponential bound. -/ +theorem linear_mem_ExpPolyO : linear ∈ ExpPolyO := ⟨1, by rw [pow_one]; simp⟩ + +/-- `2 ^ poly(n)` is closed under products. -/ +theorem mul_mem_ExpPolyO {f g : BoundFun} (hf : f ∈ ExpPolyO) (hg : g ∈ ExpPolyO) : + f * g ∈ ExpPolyO := by + obtain ⟨k, hk⟩ := hf + obtain ⟨l, hl⟩ := hg + refine ⟨max k l + 1, (mul_le_mul' hk hl).trans ?_⟩ + rw [← exp2_add] + refine exp2_le_exp2_of_le_add (K := 2) fun n => ?_ + simp only [add_apply, pow_apply, linear_apply] + rcases Nat.eq_zero_or_pos n with rfl | hn + · simp + · have h₁ : (n + 1) ^ k ≤ (n + 1) ^ max k l := + Nat.pow_le_pow_right (by omega) (le_max_left ..) + have h₂ : (n + 1) ^ l ≤ (n + 1) ^ max k l := + Nat.pow_le_pow_right (by omega) (le_max_right ..) + have h₃ : 2 * (n + 1) ^ max k l ≤ (n + 1) ^ (max k l + 1) := by + calc 2 * (n + 1) ^ max k l ≤ (n + 1) * (n + 1) ^ max k l := by gcongr; omega + _ = (n + 1) ^ (max k l + 1) := by rw [pow_succ]; ring + omega + +/-! #### Interaction of the classes -/ + +/-- `2 ^ O(log n)` is polynomial. -/ +theorem ExpO_log_subset_PolyO : ExpO log ⊆ PolyO := + fun _ ⟨c, hc⟩ => ⟨c + 1, hc.trans (exp2_const_mul_log_le c)⟩ + +/-- `2 ^ O(s)` is `2 ^ poly(n)` for a polynomially bounded `s`. -/ +theorem ExpO_subset_ExpPolyO {s : BoundFun} (hs : s ∈ PolyO) : ExpO s ⊆ ExpPolyO := by + obtain ⟨k, c₁, h₁⟩ := hs + rintro f ⟨c, hf⟩ + refine ⟨k + 1, hf.trans (exp2_le_exp2_of_le_add (K := ((c + 1) * c₁) ^ (k + 1)) fun n => ?_)⟩ + simp only [mul_apply, const_apply, pow_apply, linear_apply] + calc (c + 1) * s n ≤ (c + 1) * (c₁ * (n + 1) ^ k) := by gcongr; simpa using h₁ n + _ = (c + 1) * c₁ * (n + 1) ^ k := by ring + _ ≤ (n + 1) ^ (k + 1) + ((c + 1) * c₁) ^ (k + 1) := mul_pow_le_pow_succ_add .. + +/-- A linear factor is absorbed by `2 ^ O(s)` if `s` dominates the logarithm. -/ +theorem linear_mul_mem_ExpO {f s : BoundFun} (h : log ≤ s) (hf : f ∈ ExpO s) : + linear * f ∈ ExpO s := + let ⟨d, hd⟩ := h + let ⟨c, hc⟩ := hf + ⟨c + d, (mul_le_mul' le_rfl hc).trans (linear_mul_exp2_le hd c)⟩ + +end BoundFun + +open scoped Pointwise + +namespace BoundFun + +/-- A linear factor is absorbed by `2 ^ O(s)` if `s` dominates the logarithm. This is the set-level +form of `BoundFun.linear_mul_mem_ExpO`, as used for the space-to-time theorem. -/ +theorem singleton_linear_mul_ExpO_subset {s : BoundFun} (h : log ≤ s) : + {linear} * ExpO s ⊆ ExpO s := by + rw [Set.singleton_mul] + rintro _ ⟨f, hf, rfl⟩ + exact linear_mul_mem_ExpO h hf + +/-- A linear factor times `2 ^ O(s)` for a polynomially bounded `s` is `2 ^ poly(n)`. -/ +theorem singleton_linear_mul_ExpO_subset_ExpPolyO {s : BoundFun} (hs : s ∈ PolyO) : + {linear} * ExpO s ⊆ ExpPolyO := by + rw [Set.singleton_mul] + rintro _ ⟨f, hf, rfl⟩ + exact mul_mem_ExpPolyO linear_mem_ExpPolyO (ExpO_subset_ExpPolyO hs hf) + +/-! ### The `bigO` tactic + +`bigO` normalises the exponential algebra, descends into the structure of the goal with `gcongr` +and the sup/constant rules, and closes the leaves with the base facts, which are `simp` lemmas. -/ + +end BoundFun + +open BoundFun in +/-- Prove a domination goal `f ≤ g` between bound functions (`f = O(g)`). The tactic normalises +the exponential algebra (`exp2_add`, `exp2_const_mul`), descends with `gcongr` and the rules for +sums and constant factors, and discharges the leaves with `simp` using the base facts of the +calculus, or with hypotheses from the context. -/ +syntax "bigO" : tactic + +open BoundFun in +macro_rules + | `(tactic| bigO) => + `(tactic| + focus + (try simp only [BoundFun.exp2_add, BoundFun.exp2_const_mul, mul_one, one_mul, mul_pow, + pow_one, pow_zero] + first + | done + | assumption + | (simp; done) + | (refine BoundFun.add_le ?_ ?_ <;> bigO) + | (refine BoundFun.const_mul_le_of_le ?_ <;> bigO) + | (refine BoundFun.le_pow_of_le ?_ <;> bigO) + | (refine BoundFun.mul_le_of_le_of_le_one ?_ ?_ <;> bigO) + | (gcongr <;> bigO))) + +end Cslib diff --git a/Cslib/Foundations/Data/Nat/Segment.lean b/Cslib/Foundations/Data/Nat/Segment.lean index 01ec8fae8b..ebb139383d 100644 --- a/Cslib/Foundations/Data/Nat/Segment.lean +++ b/Cslib/Foundations/Data/Nat/Segment.lean @@ -45,7 +45,7 @@ theorem infinite_strictMono {ns : Set ℕ} (h : ns.Infinite) : /-- There is a gap between two successive occurrences of a predicate `p : ℕ → Prop`, assuming `p` (as a set) is infinite. -/ -theorem nth_succ_gap {p : ℕ → Prop} (hf : (setOf p).Infinite) (n : ℕ) : +theorem nth_succ_gap {p : ℕ → Prop} (hf : (ofPred p).Infinite) (n : ℕ) : ∀ k < nth p (n + 1) - nth p n, k > 0 → ¬ p (k + nth p n) := by classical intro k h_k1 h_k0 h_p_k @@ -222,12 +222,12 @@ theorem segment'_eq_segment (hm : StrictMono f) : ({x ∈ Finset.range (k + 1) | x ∈ range f}) by grind [BijOn.finsetCard_eq, Finset.coe_filter] refine ⟨fun n ↦ n + f 0, ?_, ?_, ?_⟩ - · intro n; simp only [mem_range, Finset.mem_range, mem_setOf_eq] + · intro n; simp only [mem_range, Finset.mem_range] rintro ⟨h_n, i, rfl⟩ have := StrictMono.monotone hm <| zero_le i refine ⟨?_, i, ?_⟩ <;> omega · grind [injOn_of_injective, Injective] - · intro n; simp only [mem_range, Finset.mem_range, mem_setOf_eq, mem_image] + · intro n; simp only [mem_range, Finset.mem_range, mem_ofPred_eq, mem_image] rintro ⟨h_n, i, rfl⟩ have := StrictMono.monotone hm <| zero_le i grind diff --git a/Cslib/Foundations/Data/OmegaSequence/Flatten.lean b/Cslib/Foundations/Data/OmegaSequence/Flatten.lean index 4d7a6f76c1..32cc620122 100644 --- a/Cslib/Foundations/Data/OmegaSequence/Flatten.lean +++ b/Cslib/Foundations/Data/OmegaSequence/Flatten.lean @@ -88,7 +88,7 @@ theorem cumLen_segment_one_add {ls : ωSequence (List α)} (h_ls : ∀ k, (ls k) symm apply Set.BijOn.finsetCard_eq (fun n ↦ n + (ls 0).length) refine ⟨?_, by grind [injOn_of_injective, Injective], ?_⟩ <;> - ( intro k; simp only [Set.mem_range, Finset.coe_filter, Finset.mem_range, Set.mem_setOf_eq, + ( intro k; simp only [Set.mem_range, Finset.coe_filter, Finset.mem_range, Set.mem_ofPred_eq, le_add_iff_nonneg_left, _root_.zero_le, and_true] ) · rintro ⟨h_k, i, rfl⟩ refine ⟨?_, 1 + i, ?_⟩ <;> grind [cumLen_one_add_drop] @@ -123,10 +123,10 @@ theorem append_flatten [Inhabited α] {ls : ωSequence (List α)} (h_ls : ∀ k, (n : ℕ) : (ls.take n).flatten ++ω (ls.drop n).flatten = ls.flatten := by induction n generalizing ls <;> grind [tail_eq_drop, take_succ] -/-- The length of `(ls.take n).flatten` is `ls.cumLen n`. -/ -@[simp, nolint simpNF, scoped grind =] -theorem length_flatten_take {ls : ωSequence (List α)} (n : ℕ) : - (ls.take n).flatten.length = ls.cumLen n := by +/-- The sum of `List.map List.length (take n ls)` is `ls.cumLen n`. -/ +@[simp, scoped grind =] +theorem map_length_take_sum {ls : ωSequence (List α)} (n : ℕ) : + (List.map List.length (take n ls)).sum = ls.cumLen n := by induction n <;> grind [take_succ'] /-- `In fact, (ls.take n).flatten` is `ls.flatten.take (ls.cumLen n)` @@ -137,7 +137,7 @@ theorem flatten_take_drop [Inhabited α] (ls.drop n).flatten = ls.flatten.drop (ls.cumLen n) := by apply append_left_right_injective · rw [append_flatten h_ls n, append_take_drop (ls.cumLen n) ls.flatten] - · rw [length_flatten_take, length_take] + · simp theorem flatten_take [Inhabited α] {ls : ωSequence (List α)} (h_ls : ∀ k, (ls k).length > 0) (n : ℕ) : diff --git a/Cslib/Foundations/Data/OmegaSequence/Init.lean b/Cslib/Foundations/Data/OmegaSequence/Init.lean index 3c54d06ecf..0013a221ae 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 @@ -32,6 +32,9 @@ variable (m n : ℕ) (x y : List α) (a b : ωSequence α) instance [Inhabited α] : Inhabited (ωSequence α) := ⟨ωSequence.const default⟩ +instance [h : IsEmpty α] : IsEmpty (ωSequence α) where + false xs := IsEmpty.false (xs 0) + @[simp, scoped grind =] protected theorem eta (s : ωSequence α) : head s ::ω tail s = s := by apply DFunLike.ext 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/Set/Saturation.lean b/Cslib/Foundations/Data/Set/Saturation.lean index 32e9806dbf..c502ef193b 100644 --- a/Cslib/Foundations/Data/Set/Saturation.lean +++ b/Cslib/Foundations/Data/Set/Saturation.lean @@ -38,7 +38,7 @@ theorem saturates_compl (hs : Saturates f s) : Saturates f sᶜ := by theorem saturates_eq_biUnion (hs : Saturates f s) (hc : ⋃ i, f i = univ) : s = ⋃ i ∈ {i | (f i ∩ s).Nonempty}, f i := by ext x - simp only [mem_setOf_eq, mem_iUnion, exists_prop] + simp only [mem_iUnion] constructor · intro h_x obtain ⟨i, _⟩ := mem_iUnion.mp <| univ_subset_iff.mpr hc <| mem_univ x 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/README.md b/Cslib/Foundations/README.md new file mode 100644 index 0000000000..c99a262fd0 --- /dev/null +++ b/Cslib/Foundations/README.md @@ -0,0 +1,32 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+ +# Foundations + +This directory covers **common foundations** for the rest of CSLib and downstream developments. As such, it acts as its fulcrum of integration through common concepts and APIs. This directory includes also additional results about foundational data objects defined in Mathlib, such as `Nat` and `Set`. + +Please browse the subdirectories for details. + +The foundational approach to semantics spans multiple directories and has a large role; it is explained below. + +## Semantics + +A recurring aspect that cuts across different areas is semantics. Examples of such areas include concurrency theory, computational models, logics, modelling languages, programming languages, and security protocols. + +Most of the APIs for semantics provided in `Foundations` are in the [Semantics](Semantics) directory. An example of an exception is the [Relation](Relation) directory, which sits at the top level. + +The vision is to provide common abstractions that can be reused throughout CSLib. Beyond providing reusable definitions, having common APIs for semantics is important for multiple reasons. The next list covers some illustrative examples. + +- The modular use of modal and dynamic logics to reason about programs. +- The sharing of semantic metatheory, such as behavioural equivalences for labelled transition systems (bisimulation, trace equivalence, etc.) and common definitions like confluence. +- The development of provably-correct compilers between languages based on these abstractions, supporting for example proofs of bisimilarity or full abstraction. +- The elicitation of connections between different domains, including computability, crypto, logic, programming languages, etc. + +### Plans + +- Many modules are still missing, for example facilities for probabilistic operational semantics, derivatives and antiderivatives for transition systems, logical relations, etc. We plan to develop develop a comprehensive library. +- We plan on building general frameworks that give important metatheoretical properties about the semantics of objects that respect certain properties (e.g., rule formats, GSOS) for free (or at least in principled ways rather than doing it from scratch). +- We plan both on developing constructions that embed different semantic models into each other and to prove separation results between them. +- We plan on pushing towards building formal connections between different domains based on a semantic approach. 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..888e64c462 --- /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 accessible 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..ae62ed778e 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 transition 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..700ddf0c3b 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 mimicked 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 mimicked 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 preserved 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/Foundations/Syntax/HasWellFormed.lean b/Cslib/Foundations/Syntax/HasWellFormed.lean index 94ca81629c..1dd2a6330f 100644 --- a/Cslib/Foundations/Syntax/HasWellFormed.lean +++ b/Cslib/Foundations/Syntax/HasWellFormed.lean @@ -20,6 +20,6 @@ class HasWellFormed (α : Type u) where wf (x : α) : Prop /-- Notation for well-formedness. -/ -notation x:max "✓" => HasWellFormed.wf x +macro x:term:max noWs "✓" : term => `(HasWellFormed.wf $x) 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..86a22cec2a 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 @@ -58,44 +59,43 @@ inductive ParallelReduction : SKI → SKI → Prop | par ⦃a a' b b' : SKI⦄ : ParallelReduction a a' → ParallelReduction b b' → ParallelReduction (a ⬝ b) (a' ⬝ b') -/-- The inclusion `⭢ₚ ⊆ ↠` -/ -theorem mRed_of_parallelReduction {a a' : SKI} (h : a ⭢ₚ a') : a ↠ a' := by +/-- The inclusion `(· ⭢ₚ ·) ≤ (· ↠ ·)`. -/ +theorem ParallelReduction.le_reflTransGen_red : + (· ⭢ₚ ·) ≤ (· ↠ ·) := by + intro a a' h cases h case refl => exact Relation.ReflTransGen.refl case par a a' b b' ha hb => apply parallel_mRed - · exact mRed_of_parallelReduction ha - · exact mRed_of_parallelReduction hb - case red_I => exact Relation.ReflTransGen.single (red_I a') - case red_K b => exact Relation.ReflTransGen.single (red_K a' b) - case red_S a b c => exact Relation.ReflTransGen.single (red_S a b c) - -/-- The inclusion `⭢ ⊆ ⭢ₚ` -/ -theorem parallelReduction_of_red {a a' : SKI} (h : a ⭢ a') : a ⭢ₚ a' := by + · exact ha.le_reflTransGen_red + · exact hb.le_reflTransGen_red + case red_I => exact Relation.ReflTransGen.single (Red.red_I a') + case red_K b => exact Relation.ReflTransGen.single (Red.red_K a' b) + case red_S a b c => exact Relation.ReflTransGen.single (Red.red_S a b c) + +/-- The inclusion `(· ⭢ ·) ≤ (· ⭢ₚ ·)`. -/ +theorem Red.le_parallelReduction : + (· ⭢ ·) ≤ (· ⭢ₚ ·) := by + intro a a' h cases h case red_S => apply ParallelReduction.red_S case red_K => apply ParallelReduction.red_K case red_I => apply ParallelReduction.red_I case red_head a a' b h => apply ParallelReduction.par - · exact parallelReduction_of_red h + · exact h.le_parallelReduction · exact ParallelReduction.refl b case red_tail a b b' h => apply ParallelReduction.par · exact ParallelReduction.refl a - · exact parallelReduction_of_red h + · exact h.le_parallelReduction -/-- The inclusions of `mRed_of_parallelReduction` and -`parallelReduction_of_red` imply that `⭢` and `⭢ₚ` have the same reflexive-transitive -closure. -/ +/-- The relations `⭢` and `⭢ₚ` have the same reflexive-transitive closure. -/ theorem reflTransGen_parallelReduction_mRed : ReflTransGen ParallelReduction = ReflTransGen Red := by - ext a b - constructor - · apply Relation.reflTransGen_of_isTrans_reflexive - exact @mRed_of_parallelReduction - · apply Relation.reflTransGen_of_isTrans_reflexive - exact fun a a' h => Relation.ReflTransGen.single (parallelReduction_of_red h) + apply le_antisymm + · exact reflTransGen_le_of_le ParallelReduction.le_reflTransGen_red + · exact ReflTransGen.mono Red.le_parallelReduction /-! Irreducibility for the (partially applied) primitive combinators. 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..1e0be09d13 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean @@ -30,7 +30,7 @@ variable {Var : Type*} [DecidableEq Var] [HasFresh Var] namespace LambdaCalculus.LocallyNameless.Fsub -open Term Ty Ty.Wf Env.Wf Sub Context List Binding +open Term Ty Ty.Wf Env.Wf Fsub.Sub Context List Binding /-- The typing relation. -/ inductive Typing : Env Var → Term Var → Ty Var → Prop @@ -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..b55058f31a 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 @@ -59,7 +58,6 @@ def semanticMap : Ty Base → Set (Term Var) | .base _ => { t | SN FullBeta t ∧ LC t } | .arrow τ₁ τ₂ => { t | ∀ s, s ∈ semanticMap τ₁ → app t s ∈ semanticMap τ₂ } -set_option linter.tacticAnalysis.verifyGrindOnly false in /-- The sets constructed by semanticMap are saturated -/ lemma semanticMap_saturated (τ : Ty Base) : @Saturated Var (semanticMap τ) := by induction τ with @@ -68,11 +66,11 @@ lemma semanticMap_saturated (τ : Ty Base) : @Saturated Var (semanticMap τ) := constructor · let x : Var := fresh {} have := ih₁.neutal_lc (fvar x) (.fvar x) (.fvar x) - grind only [semanticMap, usr Set.mem_setOf_eq, cases LC] + grind [cases LC] · grind [sn_app_left (Var := Var) (N := fvar <| fresh {})] · grind · intro M N P _ _ _ s _ - grind [ih₂.multiApp M N (s :: P)] + grind [ih₂.multiApp M N (P ++ [s]), multiApp_tail] /-- The `entailsContext` predicate ensures that each variable in the context is mapped to a term in the corresponding semantic map. -/ 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..a896d8825b 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 @@ -77,17 +77,14 @@ variable [HasFresh Var] [DecidableEq Var] /-- The right side of a reduction is locally closed. -/ @[scoped grind →] -lemma step_lc_r (step : M ⭢βᶠ M') : LC M' := by - induction step - case abs => constructor; assumption - all_goals grind +lemma step_lc_r (step : M ⭢βᶠ M') : LC M' := Xi.step_lc_r (by grind) step lemma steps_lc_or_rfl {M M' : Term Var} (redex : M ↠βᶠ M') : (LC M ∧ LC M') ∨ M = M' := by grind /-- 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 +92,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 +156,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 +187,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..21d6826046 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 -/ @@ -72,8 +73,10 @@ lemma para_lc_r (step : M ⭢ₚ N) : LC N := by all_goals grind omit [HasFresh Var] [DecidableEq Var] in -/-- A single β-reduction implies a single parallel reduction. -/ -lemma step_to_para (step : M ⭢βᶠ N) : M ⭢ₚ N := by +/-- The inclusion `(· ⭢βᶠ ·) ≤ (· ⭢ₚ ·)`. -/ +lemma FullBeta.le_parallel : + ((· ⭢βᶠ ·) : Term Var → Term Var → Prop) ≤ (· ⭢ₚ ·) := by + intro M N step induction step with | base h => cases h with | beta abs_lc _ => @@ -83,8 +86,10 @@ lemma step_to_para (step : M ⭢βᶠ N) : M ⭢ₚ N := by | _ => grind open FullBeta in -/-- A single parallel reduction implies a multiple β-reduction. -/ -lemma para_to_redex (para : M ⭢ₚ N) : M ↠βᶠ N := by +/-- The inclusion `(· ⭢ₚ ·) ≤ (· ↠βᶠ ·)`. -/ +lemma Parallel.le_reflTransGen_fullBeta : + ((· ⭢ₚ ·) : Term Var → Term Var → Prop) ≤ (· ↠βᶠ ·) := by + intro M N para induction para case fvar => constructor case app L L' R R' l_para m_para redex_l redex_m => @@ -104,11 +109,12 @@ lemma para_to_redex (para : M ⭢ₚ N) : M ↠βᶠ N := by _ ↠βᶠ m'.abs.app n' := by grind _ ⭢βᶠ m' ^ n' := by grind -/-- Multiple parallel reduction is equivalent to multiple β-reduction. -/ -theorem parachain_iff_redex : M ↠ₚ N ↔ M ↠βᶠ N := by - refine Iff.intro ?chain_redex ?redex_chain <;> intros h <;> induction h <;> try rfl - case redex_chain redex chain => exact ReflTransGen.tail chain (step_to_para redex) - case chain_redex para redex => exact ReflTransGen.trans redex (para_to_redex para) +/-- Multiple parallel reduction is equal to multiple β-reduction. -/ +theorem reflTransGen_parallel_fullBeta : + ((· ↠ₚ ·) : Term Var → Term Var → Prop) = (· ↠βᶠ ·) := by + apply le_antisymm + · exact reflTransGen_le_of_le Parallel.le_reflTransGen_fullBeta + · exact ReflTransGen.mono FullBeta.le_parallel /-- Parallel reduction respects substitution. -/ @[scoped grind .] @@ -135,7 +141,7 @@ lemma para_open_out (L : Finset Var) (mem : ∀ x, x ∉ L → (M ^ fvar x) ⭢ -- adapted from https://github.com/ElifUskuplu/Stlc_deBruijn/blob/main/Stlc/confluence.lean /-- Parallel reduction has the diamond property. -/ -theorem para_diamond : Diamond (@Parallel Var) := by +theorem parallel_diamond : Diamond ((· ⭢ₚ ·) : Term Var → Term Var → Prop) := by intros t t1 t2 tpt1 revert t2 induction tpt1 <;> intros t2 tpt2 @@ -174,7 +180,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 @@ -198,16 +204,15 @@ theorem para_diamond : Diamond (@Parallel Var) := by apply Parallel.beta (free_union Var) <;> grind /-- Parallel reduction is confluent. -/ -theorem para_confluence : Confluent (@Parallel Var) := - para_diamond.toConfluent +theorem confluent_parallel : Confluent ((· ⭢ₚ ·) : Term Var → Term Var → Prop) := + parallel_diamond.toConfluent /-- β-reduction is confluent. -/ -theorem confluence_beta : Confluent (@FullBeta Var) := by - have eq : ReflTransGen (@Parallel Var) = ReflTransGen (@FullBeta Var) := by - ext - exact parachain_iff_redex - rw [Confluent, ←eq] - exact para_confluence +@[wikidata Q1308502] +theorem confluent_fullBeta : Confluent ((· ⭢βᶠ ·) : Term Var → Term Var → Prop) := by + change Diamond ((· ↠βᶠ ·) : Term Var → Term Var → Prop) + rw [← reflTransGen_parallel_fullBeta] + exact confluent_parallel end LambdaCalculus.LocallyNameless.Untyped.Term diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean index 989142ac67..074d34a3ff 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 confluent_fullBeta · 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/MultiApp.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean index d7016d7dc4..8773906467 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean @@ -28,7 +28,7 @@ namespace LambdaCalculus.LocallyNameless.Untyped.Term @[simp, scoped grind =] def multiApp (f : Term Var) : List (Term Var) → Term Var | [] => f -| a :: as => Term.app (multiApp f as) a +| a :: as => multiApp (app f a) as /-- A list of arguments performs a single reduction step @@ -45,18 +45,23 @@ inductive ListFullBeta : List (Term Var) → List (Term Var) → Prop where variable {M M' : Term Var} {Ns Ns' : List (Term Var)} +lemma multiApp_tail {N} : (M.multiApp (Ns ++ [N])) = (M.multiApp Ns).app N:= by + induction Ns generalizing M with + | nil => grind + | cons head tail ih => rw [List.cons_append]; apply ih + /-- A term resulting from a multi-application is locally closed if and only if the leftmost term and all arguments applied to it are locally closed -/ @[scoped grind ←] lemma multiApp_lc : LC (M.multiApp Ns) ↔ LC M ∧ (∀ N ∈ Ns, LC N) := by - induction Ns with grind [cases LC] + induction Ns generalizing M with grind [cases LC] /-- Just like ordinary beta reduction, the left-hand side of a multi-application step is locally closed -/ @[scoped grind ←] lemma step_multiApp_l (steps : M ⭢βᶠ M') (lc_Ns : ∀ N ∈ Ns, LC N) : M.multiApp Ns ⭢βᶠ M'.multiApp Ns := by - induction Ns <;> grind + induction Ns generalizing M M' with grind /-- Congruence lemma for multi reduction of the left most term of a multi-application -/ lemma steps_multiApp_l (steps : M ↠βᶠ M') (lc_Ns : ∀ N ∈ Ns, LC N) : @@ -66,12 +71,18 @@ lemma steps_multiApp_l (steps : M ↠βᶠ M') (lc_Ns : ∀ N ∈ Ns, LC N) : /-- Congruence lemma for single reduction of one of the arguments of a multi-application -/ @[scoped grind ←] lemma step_multiApp_r (steps : Ns ⭢lβᶠ Ns') (lc_M : LC M) : M.multiApp Ns ⭢βᶠ M.multiApp Ns' := by - induction steps <;> grind + induction steps generalizing M <;> grind /-- Congruence lemma for multiple reduction of one of the arguments of a multi-application -/ lemma steps_multiApp_r (steps : Ns ↠lβᶠ Ns') (lc_M : LC M) : M.multiApp Ns ↠βᶠ M.multiApp Ns' := by induction steps <;> grind +lemma listFullBeta_cons_r (h : Ns ⭢lβᶠ Ns') (h_lc : ∀ M ∈ l, LC M) : (l ++ Ns) ⭢lβᶠ (l ++ Ns') := by + induction l using List.reverseRecOn generalizing Ns Ns' with grind + +lemma listFullBeta_cons_l (h : Ns ⭢lβᶠ Ns') (h_lc : ∀ M ∈ l, LC M) : (Ns ++ l) ⭢lβᶠ (Ns' ++ l) := by + induction h with grind + set_option linter.tacticAnalysis.verifyGrindOnly false in /-- If a term (λ M) N P_1 ... P_n reduces in a single step to Q, then Q must be one of the following forms: @@ -86,16 +97,19 @@ lemma invert_abs_multiApp_st {Ps} {M N Q : Term Var} (∃ N', N ⭢βᶠ N' ∧ Q = multiApp (M.abs.app N') Ps) ∨ (∃ Ps', Ps ⭢lβᶠ Ps' ∧ Q = multiApp (M.abs.app N) Ps') ∨ (Q = multiApp (M ^ N) Ps) := by - induction Ps generalizing M N Q with + induction Ps using List.reverseRecOn generalizing M N Q with | nil => grind only [cases Xi, multiApp] - | cons P Ps ih => - generalize Heq : (M.abs.app N).multiApp Ps = Q' - have : ∀ P', Q'.app P' = (M.abs.app N).multiApp (P' :: Ps) := by grind - rw [multiApp, Heq] at h_red + | append_singleton Ps P ih => + rw [multiApp_tail] at h_red cases h_red with - | base => cases Ps <;> grind - | appR => grind [→ ListFullBeta.cons] - | appL => grind + | @appL _ _ P' _ P_P' => + have : (Ps ++ [P]) ⭢lβᶠ Ps ++ [P'] := by apply listFullBeta_cons_r (.step P_P' ?_) <;> grind + grind [multiApp_tail] + | appR _ h => + have {Ps'} (h : Ps ⭢lβᶠ Ps') : (Ps ++ [P]) ⭢lβᶠ Ps' ++ [P] := listFullBeta_cons_l h (by grind) + grind [multiApp_tail] + | base => induction Ps using List.reverseRecOn with grind [multiApp_tail] + /-- If a term (λ M) N P₁ ... Pₙ reduces in multiple steps to Q, then either Q if of the form 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..ea45ee0e86 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. -/ @@ -123,20 +124,21 @@ lemma sn_abs_app_multiApp [DecidableEq Var] [HasFresh Var] {Ps} {M N : Term Var} (sn_N : SN FullBeta N) (sn_MNPs : SN FullBeta (multiApp (M ^ N) Ps)) (lc_N : LC N) (lc_MNPs : LC (multiApp (M ^ N) Ps)) : SN FullBeta (multiApp (M.abs.app N) Ps) := by - induction Ps with + induction Ps using List.reverseRecOn with | nil => apply sn_app · grind [sn_abs] · exact sn_N · grind [→ steps_open_cong_abs, open_abs_lc, sn_steps] - | cons P Ps ih => + | append_singleton Ps P ih => + rw [multiApp_tail] apply sn_app - · cases lc_MNPs with grind [sn_app_left] - · grind [sn_app_right] + · grind [cases LC, multiApp_tail, sn_app_left] + · grind [multiApp_tail, sn_app_right] · intro Q' P' hstep1 hstep2 have ⟨M', N', Ps', h_M_red, h_N_red, h_Ps_red, h_cases⟩ := invert_abs_multiApp_mst hstep1 rcases h_cases with h_P | ⟨h_st1, h_st2⟩ - · cases Ps' with grind + · induction Ps' using List.reverseRecOn with grind [multiApp_tail] · have innerSteps : (M ^ N).multiApp Ps ↠βᶠ (M' ^ N').multiApp Ps' := by trans · exact steps_multiApp_r h_Ps_red (by grind) @@ -144,15 +146,15 @@ lemma sn_abs_app_multiApp [DecidableEq Var] [HasFresh Var] {Ps} {M N : Term Var} · apply steps_open_cong_abs M M' N N' <;> grind [open_abs_lc] · grind [multiApp_steps_lc] refine sn_steps ?_ sn_MNPs + rw [multiApp_tail] · calc ((M ^ N).multiApp Ps).app P _ ↠βᶠ ((M ^ N).multiApp Ps).app P' := by grind _ ↠βᶠ Q'.abs.app P' := redex_app_l_cong (.trans innerSteps h_st2) (by grind) _ ↠βᶠ Q' ^ P' := by rw [Relation.reflTransGen_iff_eq_or_transGen] at ⊢ innerSteps h_st2 right - cases lc_MNPs refine Relation.TransGen.single (Xi.base (Beta.beta ?_ ?_)) - all_goals grind only [→ step_lc_r] + all_goals grind end LambdaCalculus.LocallyNameless.Untyped.Term diff --git a/Cslib/Languages/README.md b/Cslib/Languages/README.md new file mode 100644 index 0000000000..eb6722ccdc --- /dev/null +++ b/Cslib/Languages/README.md @@ -0,0 +1,29 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+ +# Languages + +This directory hosts **modelling and programming languages** formalised in CSLib and their properties. Their components can include syntax, semantics, typing and other reasoning disciplines, execution facilities (compilers, interpreters, etc.), behavioural theories, supporting metatheory, etc. +We are interested in many kinds of languages, from foundational calculi to applied programming frameworks. + +The focus is not only on individual languages in isolation, but also on exposing them through reusable abstractions from [Foundations](../Foundations), such as contexts, substitution, congruence, reduction systems, and labelled transition systems. + +## Principles + +### Reuse of common infrastructure + +The [Foundations](../Foundations) directory offers useful modules for language development, which should be used as much as possible. +These modules include support for syntax (like contexts and congruence relations), semantics (like transition systems), compiler correctness (like behavioural relations), and more. + +### Multiple representations are welcome + +Different representations can coexist when they serve different purposes. For example `LambdaCalculus` currently contains both named and locally nameless developments. The goal is to make tradeoffs explicit and to connect them where possible. + +## Plans and notes + +- We expect this directory to grow with many more languages, as well as connections between languages, logics, and other reasoning techniques. +- A recurring issue is how to handle binders. We still need to develop general facilities for this. Leveraging multiple representations of languages, we also plan on formally exploring the connection between standard pen & paper definitions and convenient formal representations, for example the relation between α-equivalence and techniques based on de Brujin indices. +- We aim at providing reusable infrastructure for defining languages and provably-correct compilers. +- Some topics that are often associated with languages also appear elsewhere in CSLib when a more general placement is preferrable. For example, automata and formal languages over words are in [Computability](../Computability), while reusable semantic infrastructure lives in [Foundations](../Foundations). 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/LinearLogic/CLL/EtaExpansion.lean b/Cslib/Logics/LinearLogic/CLL/EtaExpansion.lean index 9aa98ab04a..1148ef3ef9 100644 --- a/Cslib/Logics/LinearLogic/CLL/EtaExpansion.lean +++ b/Cslib/Logics/LinearLogic/CLL/EtaExpansion.lean @@ -109,11 +109,8 @@ private lemma Proof.expand_onlyAtomicAxioms_dual {a : Proposition Atom} : induction a with | one => simp +contextual [dual, expand, onlyAtomicAxioms] | bot => - intro h - rw [←h] - congr 1 - · grind - · simp [dual, expand, rwConclusion, Logic.InferenceSystem.rwConclusion] + #adaptation_note /-- see https://github.com/leanprover/lean4/pull/13484/ -/ + grind [expand, dual.eq_def] | _ => grind [Proposition.expand, Proposition.dual_inj] open Proposition Proof in diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean index 25cd8138e7..c5233c24c5 100644 --- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean +++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean @@ -196,14 +196,8 @@ lemma coe_mk {X : Set P} {h : isFact X} : ((⟨X, h⟩ : Fact P) : Set P) = X := @[simp] lemma closed (F : Fact P) : isFact (F : Set P) := F.property /-- In any phase space, `{1}⫠ = ⊥`. -/ -lemma orth_one_eq_bot : - ({(1 : P)} : Set P)⫠ = (PhaseSpace.bot : Set P) := by - ext m; constructor - · intro hm - simpa [orthogonal, mem_setOf, mul_one] using hm 1 (by simp) - · intro hm x hx - rcases hx with rfl - simpa [orthogonal, mem_setOf, mul_one] using hm +lemma orth_one_eq_bot : ({(1 : P)} : Set P)⫠ = (PhaseSpace.bot : Set P) := by + simp_all /-- The fact given by the dual of G. -/ @[simps!] def dualFact (G : Set P) : Fact P := Fact.mkDual (G⫠) G rfl @@ -638,14 +632,9 @@ lemma par_semi_distrib_plus : ((G ⅋ H) ⊕ (G ⅋ K) : Fact P) ≤ G ⅋ (H @[simp] lemma top_par : (⊤ ⅋ G : Fact P) = ⊤ := by refine SetLike.coe_injective ?_ - rw [coe_top] - rw [Set.eq_univ_iff_forall] - intro x - simp only [parr, dualFact, mkDual, mkSubset, coe_mk, coe_top] - rw [PhaseSpace.orthogonal_def, Set.mem_setOf_eq] - intro w hw + rw [coe_top, Set.eq_univ_iff_forall] + intro x w hw rcases Set.mem_mul.mp hw with ⟨y, hy, z, hz, rfl⟩ - rw [PhaseSpace.orthogonal_def, Set.mem_setOf_eq] at hy rw [mul_left_comm] exact hy (x * z) (Set.mem_univ _) @@ -679,7 +668,7 @@ lemma valid_with {G H : Fact P} : (G & H).IsValid ↔ G.IsValid ∧ H.IsValid := end Fact -open Fact +open PhaseSpace.Fact /-! ## Interpretation of propositions -/ diff --git a/Cslib/Logics/Modal/Basic.lean b/Cslib/Logics/Modal/Basic.lean index a627923676..048c650e86 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`. @@ -135,7 +145,7 @@ This result proves that the definition is correct. -/ theorem Satisfies.box_iff_forall {m : Model World Atom} : ⇓Modal[m,w ⊨ □φ] ↔ ∀ w', m.r w w' → ⇓Modal[m,w' ⊨ φ] := by grind [Proposition.box] -/-- The theory of a world in a model is the set of all propositions that it satifies. -/ +/-- The theory of a world in a model is the set of all propositions that it satisfies. -/ abbrev theory (m : Model World Atom) (w : World) : Set (Proposition Atom) := {φ | ⇓Modal[m,w ⊨ φ]} @@ -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_ofPred_eq, = impl_iff_impl, + =_ derivation_def, = not_satisfies, Satisfies, = box_iff_forall] /-- 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/Cube.lean b/Cslib/Logics/Modal/Cube.lean index 98e825014c..765193ac0d 100644 --- a/Cslib/Logics/Modal/Cube.lean +++ b/Cslib/Logics/Modal/Cube.lean @@ -45,7 +45,8 @@ def Five World Atom := logic {m : Model World Atom | Relation.RightEuclidean m.r /-- The modal logic K45. -/ @[scoped grind =] -def K45 World Atom := (K World Atom) ∪ (Four World Atom) ∪ (Five World Atom) +def K45 World Atom := + logic {m : Model World Atom | IsTrans World m.r ∧ Relation.RightEuclidean m.r} /-- The modal logic D. -/ @[scoped grind =] @@ -53,60 +54,68 @@ def D World Atom := logic {m : Model World Atom | Relation.Serial m.r} /-- The modal logic D4. -/ @[scoped grind =] -def D4 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom) +def D4 World Atom := + logic {m : Model World Atom | Relation.Serial m.r ∧ IsTrans World m.r} /-- The modal logic D5. -/ @[scoped grind =] -def D5 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Five World Atom) +def D5 World Atom := + logic {m : Model World Atom | Relation.Serial m.r ∧ Relation.RightEuclidean m.r} /-- The modal logic D45. -/ @[scoped grind =] -def D45 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom) ∪ (Five World Atom) +def D45 World Atom := + logic {m : Model World Atom | + Relation.Serial m.r ∧ IsTrans World m.r ∧ Relation.RightEuclidean m.r} /-- The modal logic DB. -/ @[scoped grind =] -def DB World Atom := (K World Atom) ∪ (D World Atom) ∪ (B World Atom) +def DB World Atom := + logic {m : Model World Atom | Relation.Serial m.r ∧ Std.Symm m.r} /-- The modal logic TB. -/ @[scoped grind =] -def TB World Atom := (K World Atom) ∪ (T World Atom) ∪ (B World Atom) +def TB World Atom := + logic {m : Model World Atom | Std.Refl m.r ∧ Std.Symm m.r} /-- The modal logic KB5. -/ @[scoped grind =] -def KB5 World Atom := (K World Atom) ∪ (B World Atom) ∪ (Five World Atom) +def KB5 World Atom := + logic {m : Model World Atom | Std.Symm m.r ∧ Relation.RightEuclidean m.r} /-- The modal logic S4. -/ @[scoped grind =] -def S4 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom) +def S4 World Atom := + logic {m : Model World Atom | Std.Refl m.r ∧ IsTrans World m.r} /-- The modal logic S5. -/ @[scoped grind =] -def S5 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom) ∪ (Five World Atom) +def S5 World Atom := + logic {m : Model World Atom | + Std.Refl m.r ∧ IsTrans World m.r ∧ Relation.RightEuclidean m.r} section Order /-! ## Ordering of Modal Logics -This section proves the essential inclusions of modal logics. - -The other inclusions in the Modal Cube can be derived from the properties of `⊆` and `∪`, as shown -in `k_subset_t`. +This section proves the essential inclusions of modal logics. Inclusions among compound logics +follow by forgetting frame conditions in their defining model classes. -/ open scoped Proposition open Set theorem k_subset_d : K World Atom ⊆ D World Atom := by - grind only [subset_def, D, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid] + grind only [subset_def, D, K, = ofPred_true, = logic, mem_ofPred_eq, = Proposition.valid] theorem k_subset_b : K World Atom ⊆ B World Atom := by - grind only [subset_def, B, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid] + grind only [subset_def, B, K, = ofPred_true, = logic, mem_ofPred_eq, = Proposition.valid] theorem k_subset_four : K World Atom ⊆ Four World Atom := by - grind only [subset_def, Four, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid] + grind only [subset_def, Four, K, = ofPred_true, = logic, mem_ofPred_eq, = Proposition.valid] theorem k_subset_five : K World Atom ⊆ Five World Atom := by - grind only [subset_def, Five, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid] + grind only [subset_def, Five, K, = ofPred_true, = logic, mem_ofPred_eq, = Proposition.valid] open scoped Relation in theorem d_subset_t : D World Atom ⊆ T World Atom := by 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/Logics/README.md b/Cslib/Logics/README.md new file mode 100644 index 0000000000..5837889a01 --- /dev/null +++ b/Cslib/Logics/README.md @@ -0,0 +1,46 @@ +
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+ +# Logic + +CSLib offers **formal logics** for defining specifications and reasoning about programs and systems. Each subdirectory focuses on a specific logic or framework. + +Shared foundations can be found in [Foundations/Logic](../Foundations/Logic). + +## Principles + +### Operators + +Please instantiate and use the typeclasses for logical operators (connectives, modalities, etc.) found in [Foundations/Logic](../Foundations/Logic). + +### Inference system and logical equivalence + +We adopt a unified approach to proof systems and semantics, whereby they instantiate `InferenceSystem`. See [linear logic](LinearLogic) and [modal logic](Modal) for examples. + +When defining logical equivalence for a given inference system, instantiate `LogicalEquivalence`. This class also acts as a check that you use the correct APIs. + +### Proof relevance in proof systems + +A recurring choice when defining a proof system (like a sequent calculus) is whether they should go into `Prop` (proof irrelevance) or a `Type` (proof relevance). +The default choice is to use a `Type` -- at the appropriate universe level, polymorphic if it has type parameters. This makes it easy to define computations on derivations, e.g., to compute their height, display them, or make tools that show how they can be transformed. + +### Fragments + +To define a fragment of a proof system, you can use a predicate. See [MLL](LinearLogic/CLL/MLL.lean) for an example. + +### Notation for judgements + +To avoid notation clashes in the notation for judgements, use a wrapper tag that clearly describes the logic. For example, in modal logic this is `Modal[m,w ⊨ φ]`. + +## Plans and notes + +### Logical equivalence + +We plan on leveraging the common infrastructure of `InferenceSystem`, `LogicalEquivalence`, and similar to build common interfaces for manipulating proofs. +If any of these APIs do not suit your needs, we are interested in expanding them or creating new ones that can cover your use cases. + +### Notation + +We will explore alternative approaches to dealing with notation clashes. An example of a current shortcoming is the necessity of prefixing dynamic logic modalities with a `d`, because they use common notation such as `[...]`. One way of doing this could be to establish typeclasses/syntax also for judgemental notation, such as `m,w ⊨ φ`, and make it accessible within a tag like `Logic`, giving for example `Logic[m,w ⊨ φ]`. This would then scope the notation for propositions only to `φ`. diff --git a/Cslib/MachineLearning/PACLearning/Defs.lean b/Cslib/MachineLearning/PACLearning/Defs.lean index e51ceff1fd..2bbb32303e 100644 --- a/Cslib/MachineLearning/PACLearning/Defs.lean +++ b/Cslib/MachineLearning/PACLearning/Defs.lean @@ -516,9 +516,7 @@ theorem error_map_eq_hypothesisError (P : Measure α) (h c : Set α) (measurable_to_bool (by convert hc using 1; ext x; simp [decide_eq_true_eq])) 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] - by_cases hx : x ∈ h <;> by_cases hcx : x ∈ c <;> simp_all + by_cases hx : x ∈ h <;> simp_all [symmDiff_def] · convert (hh.prod (measurableSet_singleton false)).union (hh.compl.prod (measurableSet_singleton true)) using 1 ext ⟨x, b⟩; cases b <;> simp 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/Cslib/MachineLearning/PACLearning/VersionSpace.lean b/Cslib/MachineLearning/PACLearning/VersionSpace.lean index 37f8072cf0..ee8a7c9c2e 100644 --- a/Cslib/MachineLearning/PACLearning/VersionSpace.lean +++ b/Cslib/MachineLearning/PACLearning/VersionSpace.lean @@ -82,7 +82,7 @@ theorem versionSpace_empty_sample (C : ConceptClass α β) (S : LabeledSample α β 0) : VersionSpace C S = C := by ext h - refine ⟨fun hh => hh.1, fun hh => ⟨hh, fun i => i.elim0⟩⟩ + exact ⟨fun hh => hh.1, fun hh => ⟨hh, fun i => i.elim0⟩⟩ /-- *Version space reindexing.* For any reindexing `f : Fin m → Fin n`, the version space on `S` is contained in the version space on the reindexed sample @@ -153,31 +153,8 @@ theorem mem_versionSpace_iff_empiricalError_zero unfold empiricalError empiricalMeasure error rcases Nat.eq_zero_or_pos m with hm | hm · subst hm - rw [dif_pos rfl] - simp only [Measure.coe_zero, Pi.zero_apply] - exact iff_of_true (fun i => i.elim0) trivial - · have hm_ne : m ≠ 0 := Nat.pos_iff_ne_zero.mp hm - have hm_inv_ne : (m : ℝ≥0∞)⁻¹ ≠ 0 := - ENNReal.inv_ne_zero.mpr (ENNReal.natCast_ne_top m) - rw [dif_neg hm_ne, Measure.smul_apply, Measure.finsetSum_apply] - simp only [Measure.dirac_apply, Set.indicator, Set.mem_setOf_eq, Pi.one_apply, - smul_eq_mul] - rw [mul_eq_zero] - constructor - · intro hh - right - apply Finset.sum_eq_zero - intro i _ - rw [if_neg] - intro hne - exact hne (hh i) - · rintro (h1 | h2) - · exact absurd h1 hm_inv_ne - · intro i - have hi := (Finset.sum_eq_zero_iff.mp h2) i (Finset.mem_univ i) - by_contra hne - rw [if_pos hne] at hi - exact one_ne_zero hi + simp + · simp_all [Nat.pos_iff_ne_zero] /-- The empirical 0-1 error equals the empirical miscount divided by the sample size. -/ @@ -189,8 +166,7 @@ theorem empiricalError_eq_div [DecidableEq β] have hm_ne : m ≠ 0 := hm.ne' unfold empiricalError empiricalMeasure error empiricalMiscount rw [dif_neg hm_ne, Measure.smul_apply, Measure.finsetSum_apply] - simp only [Measure.dirac_apply, Set.indicator, Set.mem_setOf_eq, Pi.one_apply, - smul_eq_mul] + simp only [Measure.dirac_apply, Set.indicator, Set.mem_ofPred_eq, Pi.one_apply, smul_eq_mul] rw [Finset.sum_boole, ← ENNReal.div_eq_inv_mul] /-! ### Consistent Learners -/ @@ -299,8 +275,7 @@ theorem ae_mem_versionSpace_of_realizable have hsub : {S : Fin m → α × β | ¬ c ∈ VersionSpace C S} ⊆ (Set.univ.pi (fun _ : Fin m => {p : α × β | p.2 = c p.1}))ᶜ := by intro S hS hcontra - simp only [Set.mem_pi, Set.mem_univ, true_implies, Set.mem_setOf_eq] at hcontra - exact hS ⟨hc, fun i => (hcontra i).symm⟩ + exact hS ⟨hc, by simp_all⟩ have hcompl : (Measure.pi (fun _ : Fin m => P.map (fun x : α => (x, c x)))) ((Set.univ.pi (fun _ : Fin m => {p : α × β | p.2 = c p.1}))ᶜ) = 0 := by rw [prob_compl_eq_one_sub (MeasurableSet.univ_pi fun _ => hG), diff --git a/Cslib/MachineLearning/PACLearning/VersionSpaceLattice.lean b/Cslib/MachineLearning/PACLearning/VersionSpaceLattice.lean new file mode 100644 index 0000000000..80ce34a2b4 --- /dev/null +++ b/Cslib/MachineLearning/PACLearning/VersionSpaceLattice.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Dhruv Gupta. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dhruv Gupta +-/ + +module + +public import Cslib.MachineLearning.PACLearning.VersionSpace +public import Mathlib.Data.Fin.Tuple.Basic +public import Mathlib.Data.Set.Card +public import Mathlib.Data.Set.Finite.Powerset + +/-! # Version Space Lattice + +The collection of all version spaces of a concept +class is a ∩-closed family with top `C`, the *version space lattice* of Mitchell (1982). + +## Main definitions + +- `VersionSpaces C`: the family of all version spaces of `C`, over samples of every size. + +## Main results + +- `versionSpace_append`: the version space of an appended sample is the intersection of + the version spaces. +- `self_mem_versionSpaces`, `inter_mem_versionSpaces`: the family contains `C` (top) and + is closed under intersection. +- `versionSpaces_subset_powerset`, `versionSpaces_finite`, `versionSpaces_ncard_le`: every + member is a subset of `C` and for a finite class the family is finite of size at most + `2 ^ C.ncard`. + +## References + +* [Mitchell1977] +* [Mitchell1982] +* [Mitchell1997] +-/ + +@[expose] public section + +open Set + +namespace Cslib.MachineLearning.PACLearning + +variable {α : Type*} {β : Type*} + +/-- *The version-space meet law.* The version space of an appended sample is the +intersection of the version spaces of the two parts: constraints accumulate by +intersection. -/ +theorem versionSpace_append {m n : ℕ} (C : ConceptClass α β) + (S : LabeledSample α β m) (T : LabeledSample α β n) : + VersionSpace C (Fin.append S T) = VersionSpace C S ∩ VersionSpace C T := by + ext h + constructor + · intro hh + refine ⟨⟨hh.1, fun i => ?_⟩, hh.1, fun i => ?_⟩ + · have hi := hh.2 (Fin.castAdd n i) + rwa [Fin.append_left] at hi + · have hi := hh.2 (Fin.natAdd m i) + rwa [Fin.append_right] at hi + · rintro ⟨⟨hC, hS⟩, ⟨-, hT⟩⟩ + refine ⟨hC, fun i => ?_⟩ + refine Fin.addCases (fun j => ?_) (fun j => ?_) i + · rw [Fin.append_left] + exact hS j + · rw [Fin.append_right] + exact hT j + +/-- The family of all version spaces of a concept class, over labeled samples of every +size. -/ +def VersionSpaces (C : ConceptClass α β) : Set (ConceptClass α β) := + {V | ∃ (m : ℕ) (S : LabeledSample α β m), V = VersionSpace C S} + +/-- Membership in the version-space family unfolds to a witnessing sample. -/ +theorem mem_versionSpaces_iff {C V : ConceptClass α β} : + V ∈ VersionSpaces C ↔ ∃ (m : ℕ) (S : LabeledSample α β m), V = VersionSpace C S := + Iff.rfl + +/-- The whole class is a version space (of the empty sample) which means the family has top `C`. -/ +theorem self_mem_versionSpaces (C : ConceptClass α β) : C ∈ VersionSpaces C := + ⟨0, Fin.elim0, (versionSpace_empty_sample C Fin.elim0).symm⟩ + +/-- The version-space family is closed under intersection (append the witnessing +samples). -/ +theorem inter_mem_versionSpaces {C U V : ConceptClass α β} + (hU : U ∈ VersionSpaces C) (hV : V ∈ VersionSpaces C) : + U ∩ V ∈ VersionSpaces C := by + obtain ⟨m, S, rfl⟩ := hU + obtain ⟨n, T, rfl⟩ := hV + exact ⟨m + n, Fin.append S T, (versionSpace_append C S T).symm⟩ + +/-- Every version space is a subset of the class: the family lives in the powerset +of `C`. -/ +theorem versionSpaces_subset_powerset (C : ConceptClass α β) : + VersionSpaces C ⊆ 𝒫 C := by + rintro V ⟨m, S, rfl⟩ + exact versionSpace_subset C S + +/-- A finite concept class has finitely many version spaces. -/ +theorem versionSpaces_finite {C : ConceptClass α β} (hC : C.Finite) : + (VersionSpaces C).Finite := + hC.finite_subsets.subset (versionSpaces_subset_powerset C) + +/-- A finite concept class has at most `2 ^ C.ncard` version spaces: the lattice embeds +in the powerset. -/ +theorem versionSpaces_ncard_le {C : ConceptClass α β} (hC : C.Finite) : + (VersionSpaces C).ncard ≤ 2 ^ C.ncard := + (ncard_le_ncard (versionSpaces_subset_powerset C) hC.finite_subsets).trans_eq + (ncard_powerset C hC) + +end Cslib.MachineLearning.PACLearning diff --git a/Cslib/Probability/PMF.lean b/Cslib/Probability/PMF.lean index d20be22be2..8393eb2291 100644 --- a/Cslib/Probability/PMF.lean +++ b/Cslib/Probability/PMF.lean @@ -39,7 +39,7 @@ the Mathlib module instead. namespace Cslib.Probability.PMF -open PMF ENNReal +open ENNReal universe u v variable {α : Type u} {β : Type v} diff --git a/CslibTests.lean b/CslibTests.lean index 12bc0e4611..35ca7b3a57 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -1,15 +1,17 @@ -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.BigO +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.HasWellFormed +import CslibTests.ImportWithMathlib +import CslibTests.LTS +import CslibTests.LambdaCalculus +import CslibTests.MLL +import CslibTests.Modal +import CslibTests.Reduction diff --git a/CslibTests/BigO.lean b/CslibTests/BigO.lean new file mode 100644 index 0000000000..b9658469fa --- /dev/null +++ b/CslibTests/BigO.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +import Cslib.Foundations.Data.Nat.BigO + +/-! +# Tests for the big-O calculus + +These examples exercise the algebra of `Cslib.BoundFun`, the `≤` order (which is domination, not +pointwise inequality) and the `bigO` tactic. +-/ + +open Cslib Cslib.BoundFun + +open scoped Pointwise + +section Calculus + +variable (f g h : BoundFun) (c k : ℕ) + +/-- Transitivity in a `calc` block. -/ +example : log ≤ exp2 linear := + calc log ≤ linear := log_le_linear + _ ≤ exp2 linear := linear_le_exp2_linear + +/-- Constants are absorbed. -/ +example : const c ≤ f := by bigO + +/-- Additive constants are absorbed. -/ +example : (linear + const k) * f ≤ linear * f := by bigO + +/-- Constant factors are absorbed. -/ +example : const c * (f + const k) ≤ f := by bigO + +/-- Polynomial normalisation. -/ +example : const 5 * linear ^ 2 + const 3 * linear + const 7 ≤ linear ^ 2 := by bigO + +/-- `2 ^ (c · log n)` is polynomial. -/ +example : exp2 (const c * log) ≤ linear ^ (c + 1) := by bigO + +/-- Products and powers are congruences for domination. -/ +example (h₁ : f ≤ g) : f * exp2 log ≤ g * linear := by gcongr; exact exp2_log_le_linear + +example (h₁ : f ≤ g) : f ^ k ≤ g ^ k := by gcongr + +/-- The exponential turns sums into products. -/ +example : exp2 (linear + linear) = exp2 linear * exp2 linear := exp2_add .. + +/-- Exponentials are compared through their exponents, pointwise. -/ +example : exp2 log ≤ exp2 linear := exp2_le_exp2 fun n => by + simpa using Nat.log_le_self 2 n + +/-- A polynomial factor in the exponent is absorbed by the next power. -/ +example : exp2 (const c * linear ^ (k + 1)) ≤ exp2 (linear ^ (k + 2)) := exp2_const_mul_pow_le c k + +/-- The absorption of a linear factor into an exponential. -/ +example (s : BoundFun) (d : ℕ) (hd : ∀ n, log n ≤ d * s n) : + linear * exp2 (const c * s) ≤ exp2 (const (c + d) * s) := linear_mul_exp2_le hd c + +end Calculus + +section OfFun + +/-- Plain functions enter the calculus through their monotone envelope. -/ +example (F : ℕ → ℕ) (h : ∀ n, F n ≤ 3 * (n + 1)) : ofFun F ≤ linear := ofFun_le h + +/-- The envelope dominates the function pointwise. -/ +example (F : ℕ → ℕ) (n : ℕ) : F n ≤ ofFun F n := le_ofFun F n + +/-- A concrete non-monotone running time. -/ +example : ofFun (fun n => if n % 2 = 0 then 5 * n else 2) ≤ linear := + ofFun_le (c := 5) fun n => by simp only [linear_apply]; split <;> omega + +end OfFun + +section OClasses + +variable (f g : BoundFun) (c k : ℕ) + +/-- Membership in `poly(n)`. -/ +example : linear ^ 3 * const 5 ∈ PolyO := mem_PolyO_of_le (by bigO) (pow_linear_mem_PolyO 3) + +/-- `2 ^ O(s)` is closed under products. -/ +example (s : BoundFun) (hf : f ∈ ExpO s) (hg : g ∈ ExpO s) : f * g ∈ ExpO s := mul_mem_ExpO hf hg + +/-- A chain of class inclusions: `2 ^ O(log n) ⊆ poly(n)`, and the classes are lower sets. -/ +example (h : f ≤ g) (hg : g ∈ ExpO log) : f ∈ PolyO := + ExpO_log_subset_PolyO (mem_ExpO_of_le h hg) + +/-- The `O` in the exponent absorbs a domination of the exponent. -/ +example (s₁ s₂ : BoundFun) (h : s₁ ≤ s₂) : ExpO s₁ ⊆ ExpO s₂ := ExpO_subset_ExpO h + +/-- A linear factor is absorbed by `2 ^ O(s)` when `s` dominates the logarithm. -/ +example (s : BoundFun) (h : log ≤ s) : {linear} * ExpO s ⊆ ExpO s := + singleton_linear_mul_ExpO_subset h + +/-- `2 ^ O(n ^ k)` is `2 ^ poly(n)`. -/ +example : ExpO (linear ^ k) ⊆ ExpPolyO := ExpO_subset_ExpPolyO (pow_linear_mem_PolyO k) + +/-- Polynomials in `s` are `2 ^ O(s)`. -/ +example : linear ^ 4 ∈ ExpO linear := pow_mem_ExpO 4 linear + +/-- A power of a fixed base with an affine exponent is `2 ^ O(s)`. -/ +example : ofFun (fun n => 5 ^ (3 * n + 2)) ∈ ExpO linear := + ofFun_base_pow_mem_ExpO 5 3 2 fun n => by simp only [linear_apply]; omega + +/-- Products of plain functions are handled factor by factor. -/ +example : ofFun (fun n => 7 * (2 * (n + 1) + 1) ^ 3) ∈ ExpO linear := + ofFun_mul_mem_ExpO (ofFun_const_mem_ExpO 7 linear) + (ofFun_pow_mem_ExpO 3 3 fun n => by simp only [linear_apply]; omega) + +end OClasses diff --git a/CslibTests/DFA.lean b/CslibTests/DFA.lean index 09ccd69d70..c48ee1c1bb 100644 --- a/CslibTests/DFA.lean +++ b/CslibTests/DFA.lean @@ -15,12 +15,12 @@ open Cslib.Automata inductive Floor where | one | two -deriving DecidableEq, Fintype +deriving DecidableEq inductive Direction where | up | down -deriving DecidableEq, Fintype +deriving DecidableEq def elevator : DA Floor Direction where tr 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/HasWellFormed.lean b/CslibTests/HasWellFormed.lean new file mode 100644 index 0000000000..e408cb3d2b --- /dev/null +++ b/CslibTests/HasWellFormed.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 Sean D. Stoneburner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sean D. Stoneburner +-/ +import Cslib.Algorithms.Lean.TimeM +import Cslib.Foundations.Syntax.HasWellFormed + +open Cslib.Algorithms.Lean + +/-! +# Syntax Collision Test +This file tests that the `✓` prefix macro from `TimeM` does not collide with +the `✓` postfix notation from `HasWellFormed` across line breaks. +-/ + +def testParserCollision (n : Nat) : TimeM Nat Nat := do + let m := n + ✓ return m + +-- Ensure the postfix notation still functions correctly when attached without whitespace +variable {α : Type*} [Cslib.HasWellFormed α] (x : α) + +/-- info: Cslib.HasWellFormed.wf x : Prop -/ +#guard_msgs in +#check x✓ diff --git a/CslibTests/Modal.lean b/CslibTests/Modal.lean new file mode 100644 index 0000000000..002acd9bf5 --- /dev/null +++ b/CslibTests/Modal.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Logics.Modal.Cube + +namespace Cslib.Logic.Modal + +open scoped Proposition + +variable {World Atom : Type*} {φ : Proposition Atom} + +-- Compound modal logics contain conjunctions of the axioms validated by their combined frame +-- conditions. Defining them as unions of the individual logics loses these conjunctions. + +example : ((◇◇φ → ◇φ) ∧ (◇φ → □◇φ) : Proposition Atom) ∈ K45 World Atom := by + intro m h w + letI : IsTrans World m.r := h.1 + letI : Relation.RightEuclidean m.r := h.2 + exact ⟨Satisfies.four φ, Satisfies.five φ⟩ + +example : ((□φ → ◇φ) ∧ (◇◇φ → ◇φ) : Proposition Atom) ∈ D4 World Atom := by + intro m h w + letI : Relation.Serial m.r := h.1 + letI : IsTrans World m.r := h.2 + exact ⟨Satisfies.d φ, Satisfies.four φ⟩ + +example : ((□φ → ◇φ) ∧ (◇φ → □◇φ) : Proposition Atom) ∈ D5 World Atom := by + intro m h w + letI : Relation.Serial m.r := h.1 + letI : Relation.RightEuclidean m.r := h.2 + exact ⟨Satisfies.d φ, Satisfies.five φ⟩ + +example : + Proposition.and (□φ → ◇φ) (Proposition.and (◇◇φ → ◇φ) (◇φ → □◇φ)) ∈ + D45 World Atom := by + intro m h w + letI : Relation.Serial m.r := h.1 + letI : IsTrans World m.r := h.2.1 + letI : Relation.RightEuclidean m.r := h.2.2 + exact ⟨Satisfies.d φ, Satisfies.four φ, Satisfies.five φ⟩ + +example : ((□φ → ◇φ) ∧ (φ → □◇φ) : Proposition Atom) ∈ DB World Atom := by + intro m h w + letI : Relation.Serial m.r := h.1 + letI : Std.Symm m.r := h.2 + exact ⟨Satisfies.d φ, Satisfies.b φ⟩ + +example : ((φ → ◇φ) ∧ (φ → □◇φ) : Proposition Atom) ∈ TB World Atom := by + intro m h w + letI : Std.Refl m.r := h.1 + letI : Std.Symm m.r := h.2 + exact ⟨Satisfies.t φ, Satisfies.b φ⟩ + +example : ((φ → □◇φ) ∧ (◇φ → □◇φ) : Proposition Atom) ∈ KB5 World Atom := by + intro m h w + letI : Std.Symm m.r := h.1 + letI : Relation.RightEuclidean m.r := h.2 + exact ⟨Satisfies.b φ, Satisfies.five φ⟩ + +example : ((φ → ◇φ) ∧ (◇◇φ → ◇φ) : Proposition Atom) ∈ S4 World Atom := by + intro m h w + letI : Std.Refl m.r := h.1 + letI : IsTrans World m.r := h.2 + exact ⟨Satisfies.t φ, Satisfies.four φ⟩ + +example : + Proposition.and (φ → ◇φ) (Proposition.and (◇◇φ → ◇φ) (◇φ → □◇φ)) ∈ + S5 World Atom := by + intro m h w + letI : Std.Refl m.r := h.1 + letI : IsTrans World m.r := h.2.1 + letI : Relation.RightEuclidean m.r := h.2.2 + exact ⟨Satisfies.t φ, Satisfies.four φ, Satisfies.five φ⟩ + +end Cslib.Logic.Modal 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/ORGANISATION.md b/ORGANISATION.md index a2c4edfca6..33e522ef9d 100644 --- a/ORGANISATION.md +++ b/ORGANISATION.md @@ -1,6 +1,8 @@ # Code organisation -This document gives an overview of how the codebase is structured, in terms of directories. +This document gives an overview of how the codebase is structured, in terms of directories. + +For more details about the high-level principles that govern these directories, please refer to their internal `README.md` files when present. **Note** that this organisation is still under active discussion and is subject to change. diff --git a/lake-manifest.json b/lake-manifest.json index 99fff5ea9d..7f68c00423 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "rev": "169c26b52a38b704fad2c009372d76844a059bdf", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab", + "inputRev": "169c26b52a38b704fad2c009372d76844a059bdf", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "744117af710b1c0400cd297c9ce91f8d0ad3a347", + "rev": "b1c4a69a7e247ab7df20460212001673d74f08c0", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "c5d5b8fe6e5158def25cd28eb94e4141ad97c843", + "rev": "0498c7c070c143a3bf7379f4d99a2c63bb9d9715", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "99c763c8a96d3d44fb4994e96eaa51ca4568449d", + "rev": "18a90119a5d316358fde6c86e0ca24e59212e32c", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,50 +45,50 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "1537e3fc7e680d64e06fe5fb95c4c9edee7941c2", + "rev": "b1436dc749e722c9920036b52cdc43b3451d0b69", "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": "57d3325be72a842920813bcb40f96a6f7393c185", "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": "ee41917ae11d38479fb8fb24745f7ca4bf0a784d", "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": "2c810760f0a0c4536b397dbe30ca9b2f2f467366", "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": "da07ca808b6718cb2aed14dba154e5a08b8f8ecf", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0-rc2", + "inputRev": "v4.33.0-rc1", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 79a2ff1a8b..a1fe432a2a 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,16 +18,14 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "d90090f647cae4f4ad4da99c0ac8bab2ca8c34ab" +rev = "169c26b52a38b704fad2c009372d76844a059bdf" [[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..fd85b262bf 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.31.0-rc2 +leanprover/lean4:v4.33.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} +} diff --git a/scripts/bench/README.md b/scripts/bench/README.md index 2eca796a48..12285bbd05 100644 --- a/scripts/bench/README.md +++ b/scripts/bench/README.md @@ -5,13 +5,13 @@ It is built around [radar](github.com/leanprover/radar) and benchmark results can be viewed on the [Lean FRO radar instance](https://radar.lean-lang.org/repos/cslib). -To execute the entire suite, run `scripts/bench/run` in the repo root. -To execute an individual benchmark, run `scripts/bench//run` in the repo root. -All scripts output their measurements into the file `measurements.jsonl`. +To execute the benchmark suite, run `scripts/bench/run` from the repo root. +All measurements will be placed into `measurements.jsonl` in the repo root. Radar sums any duplicated measurements with matching metrics. -To post-process the `measurements.jsonl` file this way in-place, -run `scripts/bench/combine.py` in the repo root after executing the benchmark suite. +To post-process the `measurements.jsonl` file this way, +run `scripts/bench/combine.py measurements.jsonl -o measurements_combined.jsonl` +in the repo root after executing the benchmark suite. The `*.py` symlinks exist only so the python files are a bit nicer to edit in text editors that rely on the file ending. @@ -23,3 +23,10 @@ To add a benchmark to the suite, follow these steps: 1. Create a new folder containing a `run` script and a `README.md` file describing the benchmark, as well as any other files required for the benchmark. 2. Edit `scripts/bench/run` to call the `run` script of your new benchmark. + +The following environment variables are available to an individual benchmark's `run` script: + +- `ROOT_DIR`: absolute path to the root of the repo +- `BENCH_DIR`: absolute path to this directory (`scripts/bench`). +- `OUTPUT_FILE`: absolute path to the `measurements.jsonl` file + that benchmarks should append their measurements to diff --git a/scripts/bench/build/README.md b/scripts/bench/build/README.md index 5292e925d2..7a37466b5d 100644 --- a/scripts/bench/build/README.md +++ b/scripts/bench/build/README.md @@ -1,6 +1,6 @@ # The `build` benchmark -This benchmark executes a complete build of cslib and collects global and per-module metrics. +This benchmark executes a complete build and collects global and per-module metrics. The following metrics are collected by a wrapper around the entire build process: @@ -9,7 +9,7 @@ The following metrics are collected by a wrapper around the entire build process - `build//task-clock` - `build//wall-clock` -The following metrics are collected from `leanc --profile` and summed across all modules: +The following metrics are collected from `lean --profile` and summed across all modules: - `build/profile///wall-clock` @@ -18,10 +18,15 @@ The following metrics are collected from `lakeprof report`: - `build/lakeprof/longest build path//wall-clock` - `build/lakeprof/longest rebuild path//wall-clock` +The following metrics are collected from a combination of `lakeprof report` and the per-module instructions: + +- `build/lakeprof/longest build path//instructions` +- `build/lakeprof/longest rebuild path//instructions` + The following metrics are collected individually for each module: - `build/module///lines` - `build/module///instructions` -If the file `build_upload_lakeprof_report` is present in the repo root, -the lakeprof report will be uploaded once the benchmark run concludes. +If the `LAKEPROF_UPLOAD_URL` environment variable is set, +the lakeprof report will be uploaded to that URL prefix once the benchmark run concludes. diff --git a/scripts/bench/build/fake-root/bin/lean b/scripts/bench/build/fake-root/bin/lean index 8d2b778e65..2ce14c08b2 100755 --- a/scripts/bench/build/fake-root/bin/lean +++ b/scripts/bench/build/fake-root/bin/lean @@ -2,22 +2,29 @@ import argparse import json +import os import re import subprocess import sys from pathlib import Path -NAME = "build" -REPO = Path() -BENCH = REPO / "scripts" / "bench" -OUTFILE = REPO / "measurements.jsonl" +# Global paths +BENCH_DIR = Path(os.environ["BENCH_DIR"]) +WRAPPER_OUT = Path(os.environ["WRAPPER_OUT"]) +WRAPPER_PREFIX = Path(os.environ["WRAPPER_PREFIX"]) +# Other config +BENCHMARK = "build" -def save_result(metric: str, value: float, unit: str | None = None) -> None: +sys.path.append(str(BENCH_DIR)) +import measure # noqa: E402 + + +def save_measurement(metric: str, value: float, unit: str | None = None) -> None: data = {"metric": metric, "value": value} if unit is not None: data["unit"] = unit - with open(OUTFILE, "a+") as f: + with open(WRAPPER_OUT, "a") as f: f.write(f"{json.dumps(data)}\n") @@ -27,15 +34,6 @@ def run(*command: str) -> None: sys.exit(result.returncode) -def run_stderr(*command: str) -> str: - result = subprocess.run(command, capture_output=True, encoding="utf-8") - if result.returncode != 0: - print(result.stdout, end="", file=sys.stdout) - print(result.stderr, end="", file=sys.stderr) - sys.exit(result.returncode) - return result.stderr - - def get_module(setup: Path) -> str: with open(setup) as f: return json.load(f)["name"] @@ -44,33 +42,33 @@ def get_module(setup: Path) -> str: def count_lines(module: str, path: Path) -> None: with open(path) as f: lines = sum(1 for _ in f) - save_result(f"{NAME}/module/{module}//lines", lines) + save_measurement(f"{BENCHMARK}/module/{module}//lines", lines) def run_lean(module: str) -> None: - stderr = run_stderr( - f"{BENCH}/measure.py", - *("-t", f"{NAME}/module/{module}"), - *("-m", "instructions"), - "--", - *("lean", "--profile", "-Dprofiler.threshold=9999999"), - *sys.argv[1:], + _, stderr = measure.main( + cmd=["lean", "--profile", "-Dprofiler.threshold=9999999", *sys.argv[1:]], + output=WRAPPER_OUT, + topics=[f"{BENCHMARK}/module/{module}"], + metrics={"instructions"}, + append=True, + capture=True, ) + # Output of `lean --profile` + # See timeit.cpp for the time format for line in stderr.splitlines(): - # Output of `lean --profile` - # See timeit.cpp for the time format if match := re.fullmatch(r"\t(.*) ([\d.]+)(m?s)", line): name = match.group(1) seconds = float(match.group(2)) if match.group(3) == "ms": seconds = seconds / 1000 - save_result(f"{NAME}/profile/{name}//wall-clock", seconds, "s") + save_measurement(f"{BENCHMARK}/profile/{name}//wall-clock", seconds, "s") def main() -> None: if sys.argv[1:] == ["--print-prefix"]: - print(Path(__file__).resolve().parent.parent) + print(WRAPPER_PREFIX) return if sys.argv[1:] == ["--githash"]: diff --git a/scripts/bench/build/lakeprof_measurements.py b/scripts/bench/build/lakeprof_measurements.py new file mode 100755 index 0000000000..db97dcb3bd --- /dev/null +++ b/scripts/bench/build/lakeprof_measurements.py @@ -0,0 +1,84 @@ +#!/usr/bin/env python3 + +# Derives the `build/lakeprof/*` measurements from `lakeprof report` and the +# existing contents of the measurements file. The results are appended back onto +# the measurements file. +# +# Must be run from the src dir so that lakeprof can collect the metadata it +# needs. + +import argparse +import json +import re +import subprocess +import sys +from dataclasses import dataclass +from pathlib import Path + + +def save_measurement( + output: Path, metric: str, value: float, unit: str | None = None +) -> None: + data = {"metric": metric, "value": value} + if unit is not None: + data["unit"] = unit + with open(output, "a") as f: + f.write(f"{json.dumps(data)}\n") + + +def load_instructions_per_module(output: Path) -> dict[str, float]: + pattern = re.compile(r"build/module/(.*)//instructions") + instructions: dict[str, float] = {} + with open(output) as f: + for line in f: + data = json.loads(line) + if match := pattern.fullmatch(data["metric"]): + instructions[match.group(1)] = data["value"] + return instructions + + +@dataclass +class Row: + time: float + time_frac: float + cum_time: float + cum_time_frac: float + module: str + + +def lakeprof_report(*args: str) -> list[Row]: + result = subprocess.run( + ["lakeprof", "report", *args, "-j"], capture_output=True, encoding="utf-8" + ) + if result.returncode != 0: + print(result.stdout, end="", file=sys.stdout) + print(result.stderr, end="", file=sys.stderr) + sys.exit(result.returncode) + return [Row(*row) for row in json.loads(result.stdout)] + + +def main() -> None: + parser = argparse.ArgumentParser() + parser.add_argument("out", type=Path) + args = parser.parse_args() + out: Path = args.out + + instructions = load_instructions_per_module(out) + + for flag, name in [("-p", "longest build path"), ("-r", "longest rebuild path")]: + rows = lakeprof_report(flag) + + # Total wall-clock time, as reported by lakeprof + save_measurement( + out, f"build/lakeprof/{name}//wall-clock", rows[-1].cum_time, "s" + ) + + # Total instructions, computed from lakeprof's modules and our own measurements + total_instructions = sum(instructions.get(row.module, 0) for row in rows) + save_measurement( + out, f"build/lakeprof/{name}//instructions", total_instructions + ) + + +if __name__ == "__main__": + main() diff --git a/scripts/bench/build/lakeprof_report_upload.py b/scripts/bench/build/lakeprof_report_upload.py index e49627b628..450887df8d 100644 --- a/scripts/bench/build/lakeprof_report_upload.py +++ b/scripts/bench/build/lakeprof_report_upload.py @@ -1,16 +1,23 @@ #!/usr/bin/env python3 import json +import os import subprocess import sys from pathlib import Path +upload_url = os.environ.get("LAKEPROF_UPLOAD_URL") +if not upload_url: + sys.exit(0) +if upload_url.endswith("/"): + upload_url = upload_url[:-1] -def run(*args: str) -> None: - subprocess.run(args, check=True) +# Determine paths +template_file = Path(__file__).with_name("lakeprof_report_template.html") +root_dir = Path(os.environ["ROOT_DIR"]) -def run_stdout(*command: str, cwd: str | None = None) -> str: +def run_stdout(*command: str, cwd: Path | None = None) -> str: result = subprocess.run(command, capture_output=True, encoding="utf-8", cwd=cwd) if result.returncode != 0: print(result.stdout, end="", file=sys.stdout) @@ -19,26 +26,20 @@ def run_stdout(*command: str, cwd: str | None = None) -> str: return result.stdout -def main() -> None: - script_file = Path(__file__) - template_file = script_file.parent / "lakeprof_report_template.html" +sha = run_stdout("git", "rev-parse", "@", cwd=root_dir).strip() +base_url = f"{upload_url}/{sha}" +report = run_stdout("lakeprof", "report", "-prc", cwd=root_dir) - sha = run_stdout("git", "rev-parse", "@").strip() - base_url = f"https://speed.lean-lang.org/cslib-out/{sha}" - report = run_stdout("lakeprof", "report", "-prc") - with open(template_file) as f: - template = f.read() +template = template_file.read_text() +template = template.replace("__BASE_URL__", json.dumps(base_url)) +template = template.replace("__LAKEPROF_REPORT__", report) +(root_dir / "index.html").write_text(template) - template = template.replace("__BASE_URL__", json.dumps(base_url)) - template = template.replace("__LAKEPROF_REPORT__", report) - with open("index.html", "w") as f: - f.write(template) +def upload(file: Path) -> None: + subprocess.run(["curl", "-fT", file, f"{base_url}/{file.name}"], check=True) - run("curl", "-T", "index.html", f"{base_url}/index.html") - run("curl", "-T", "lakeprof.log", f"{base_url}/lakeprof.log") - run("curl", "-T", "lakeprof.trace_event", f"{base_url}/lakeprof.trace_event") - -if __name__ == "__main__": - main() +upload(root_dir / "index.html") +upload(root_dir / "lakeprof.log") +upload(root_dir / "lakeprof.trace_event") diff --git a/scripts/bench/build/run b/scripts/bench/build/run index 39d34b2478..d20a8f7002 100755 --- a/scripts/bench/build/run +++ b/scripts/bench/build/run @@ -1,23 +1,17 @@ #!/usr/bin/env bash set -euxo pipefail -BENCH="scripts/bench" - # Prepare build lake exe cache get # Run build -LAKE_OVERRIDE_LEAN=true LEAN=$(realpath "$BENCH/build/fake-root/bin/lean") \ - "$BENCH/measure.py" -t build \ - -m instructions -m maxrss -m task-clock -m wall-clock -- \ +LAKE_OVERRIDE_LEAN=true \ + LEAN="$BENCH_DIR/build/fake-root/bin/lean" \ + WRAPPER_OUT="$OUTPUT_FILE" \ + WRAPPER_PREFIX="$BENCH_DIR/build/fake-root" \ + "$BENCH_DIR/measure.py" -t build -d -a -o "$OUTPUT_FILE" -- \ lakeprof record lake build --no-cache # Analyze lakeprof data -lakeprof report -pj | jq -c '{metric: "build/lakeprof/longest build path//wall-clock", value: .[-1][2], unit: "s"}' >> measurements.jsonl -lakeprof report -rj | jq -c '{metric: "build/lakeprof/longest rebuild path//wall-clock", value: .[-1][2], unit: "s"}' >> measurements.jsonl - -# Upload lakeprof report -# Guarded to prevent accidental uploads (which wouldn't work anyways) during local runs. -if [ -f build_upload_lakeprof_report ]; then - python3 "$BENCH/build/lakeprof_report_upload.py" -fi +"$BENCH_DIR/build/lakeprof_measurements.py" "$OUTPUT_FILE" +python3 "$BENCH_DIR/build/lakeprof_report_upload.py" diff --git a/scripts/bench/combine.py b/scripts/bench/combine.py index 2a71f31b96..bf5e3b6dce 100755 --- a/scripts/bench/combine.py +++ b/scripts/bench/combine.py @@ -2,30 +2,79 @@ import argparse import json +import sys from pathlib import Path +from typing import Any -OUTFILE = Path() / "measurements.jsonl" -if __name__ == "__main__": +def add_measurement( + values: dict[str, float], + units: dict[str, str | None], + data: dict[str, Any], +) -> None: + metric = data["metric"] + values[metric] = values.get(metric, 0) + data["value"] + units[metric] = data.get("unit") + + +def format_measurement( + values: dict[str, float], + units: dict[str, str | None], + name: str, +) -> dict[str, Any]: + value = values[name] + unit = units.get(name) + + data: dict[str, Any] = {"metric": name, "value": value} + if unit is not None: + data["unit"] = unit + + return data + + +def main() -> None: parser = argparse.ArgumentParser( - description=f"Combine duplicated measurements in {OUTFILE.name} the way radar does, by summing their values." + description="Combine measurement files in the JSON Lines format, summing duplicated measurements like radar does.", + ) + parser.add_argument( + "input", + nargs="*", + default=[], + help="input files to read measurements from. If none are specified, measurements are read from stdin.", + ) + parser.add_argument( + "-o", + "--output", + type=Path, + help="output file to write measurements to. If not specified, the result is printed to stdout.", ) args = parser.parse_args() + inputs: list[Path] = args.input + output: Path | None = args.output + values: dict[str, float] = {} units: dict[str, str | None] = {} - with open(OUTFILE, "r") as f: - for line in f: - data = json.loads(line) - metric = data["metric"] - values[metric] = values.get(metric, 0) + data["value"] - units[metric] = data.get("unit") - - with open(OUTFILE, "w") as f: - for metric, value in values.items(): - unit = units.get(metric) - data = {"metric": metric, "value": value} - if unit is not None: - data["unit"] = unit - f.write(f"{json.dumps(data)}\n") + # Read measurements + if inputs: + for input in inputs: + with open(input, "r") as f: + for line in f: + add_measurement(values, units, json.loads(line)) + else: + for line in sys.stdin: + add_measurement(values, units, json.loads(line)) + + # Write measurements + if output: + with open(output, "w") as f: + for metric in sorted(values): + f.write(f"{json.dumps(format_measurement(values, units, metric))}\n") + else: + for metric in sorted(values): + print(json.dumps(format_measurement(values, units, metric))) + + +if __name__ == "__main__": + main() diff --git a/scripts/bench/measure.py b/scripts/bench/measure.py index 072f4cdde6..c52b6e9028 100755 --- a/scripts/bench/measure.py +++ b/scripts/bench/measure.py @@ -9,8 +9,7 @@ import tempfile from dataclasses import dataclass from pathlib import Path - -OUTFILE = Path() / "measurements.jsonl" +from typing import Tuple @dataclass @@ -27,10 +26,24 @@ class RusageMetric: unit: str | None = None +@dataclass +class Result: + category: str + value: float + unit: str | None + + def fmt(self, topic: str) -> str: + data = {"metric": f"{topic}//{self.category}", "value": self.value} + if self.unit is not None: + data["unit"] = self.unit + return json.dumps(data) + + PERF_METRICS = { "task-clock": PerfMetric("task-clock", factor=1e-9, unit="s"), "wall-clock": PerfMetric("duration_time", factor=1e-9, unit="s"), "instructions": PerfMetric("instructions"), + "cycles": PerfMetric("cycles"), } PERF_UNITS = { @@ -43,118 +56,201 @@ class RusageMetric: } ALL_METRICS = {**PERF_METRICS, **RUSAGE_METRICS} +DEFAULT_METRICS = {"instructions", "maxrss", "task-clock", "wall-clock"} -def measure_perf(cmd: list[str], events: list[str]) -> dict[str, tuple[float, str]]: - with tempfile.NamedTemporaryFile() as tmp: - cmd = [ - *["perf", "stat", "-j", "-o", tmp.name], - *[arg for event in events for arg in ["-e", event]], - *["--", *cmd], - ] +def resolve_metrics(metrics: set[str]) -> Tuple[set[str], set[str]]: + perf = set() + rusage = set() + unknown = set() - # Execute command - env = os.environ.copy() - env["LC_ALL"] = "C" # or else perf may output syntactically invalid json - result = subprocess.run(cmd, env=env) - if result.returncode != 0: - sys.exit(result.returncode) + for metric in metrics: + if metric in PERF_METRICS: + perf.add(metric) + elif metric in RUSAGE_METRICS: + rusage.add(metric) + else: + unknown.add(metric) - # Collect results - perf = {} - for line in tmp: - data = json.loads(line) - if "event" in data and "counter-value" in data: - perf[data["event"]] = float(data["counter-value"]), data["unit"] + if unknown: + raise SystemExit(f"unknown metrics: {', '.join(unknown)}") - return perf + return perf, rusage @dataclass -class Result: - category: str +class PerfResult: value: float - unit: str | None + unit: str - def fmt(self, topic: str) -> str: - metric = f"{topic}//{self.category}" - if self.unit is None: - return json.dumps({"metric": metric, "value": self.value}) - return json.dumps({"metric": metric, "value": self.value, "unit": self.unit}) +type PerfResults = dict[str, PerfResult] -def measure(cmd: list[str], metrics: list[str]) -> list[Result]: - # Check args - unknown_metrics = [] - for metric in metrics: - if metric not in RUSAGE_METRICS and metric not in PERF_METRICS: - unknown_metrics.append(metric) - if unknown_metrics: - raise Exception(f"unknown metrics: {', '.join(unknown_metrics)}") - # Prepare perf events - events: list[str] = [] - for metric in metrics: - if info := PERF_METRICS.get(metric): - events.append(info.event) +@dataclass +class MeasureResult: + perf: PerfResults + stdout: str + stderr: str + + +def measure_perf(cmd: list[str], events: set[str], capture: bool) -> MeasureResult: + with tempfile.NamedTemporaryFile() as tmp: + env = os.environ.copy() + env["LC_ALL"] = "C" # or perf may output syntactically invalid JSON + + # On NixOS, perf effectively prepends /usr/bin to the PATH, but in this + # test suite, we often use the PATH to specify the binaries under test. + # Hence, we reset the PATH inside of perf using env. + cmd = [ + *("perf", "stat", "-j", "-o", tmp.name), + *(arg for event in sorted(events) for arg in ["-e", event]), + "--", + *("env", f"PATH={env['PATH']}"), + *cmd, + ] - # Measure - perf = measure_perf(cmd, events) + # Execute command + result = subprocess.run(cmd, env=env, capture_output=capture, encoding="utf-8") + if result.returncode != 0: + if capture: + print(result.stdout, end="", file=sys.stdout) + print(result.stderr, end="", file=sys.stderr) + raise SystemExit(result.returncode) + + # Collect results + perf: PerfResults = {} + for line in tmp: + data = json.loads(line) + if "event" in data and "counter-value" in data: + perf[data["event"]] = PerfResult( + value=float(data["counter-value"]), + unit=data["unit"], + ) + + return MeasureResult( + perf=perf, + stdout=result.stdout or "", + stderr=result.stderr or "", + ) + + +def get_perf_result(perf: PerfResults, metric: str) -> Result: + info = PERF_METRICS[metric] + if info.event in perf: + result = perf[info.event] + else: + # Without the corresponding permissions, + # we only get access to the userspace versions of the counters. + result = perf[f"{info.event}:u"] + + value = result.value * PERF_UNITS.get(result.unit, info.factor) + return Result(category=metric, value=value, unit=info.unit) + + +def get_rusage_result(rusage: resource.struct_rusage, metric: str) -> Result: + info = RUSAGE_METRICS[metric] + value = getattr(rusage, info.name) * info.factor + return Result(category=metric, value=value, unit=info.unit) + + +def main( + cmd: list[str], + output: Path, + topics: list[str], + metrics: set[str], + append: bool = True, + capture: bool = False, +) -> tuple[str, str]: + perf_metrics, rusage_metrics = resolve_metrics(metrics) + perf_events = {PERF_METRICS[metric].event for metric in perf_metrics} + + measured = measure_perf(cmd, perf_events, capture=capture) + perf = measured.perf rusage = resource.getrusage(resource.RUSAGE_CHILDREN) - # Extract results results = [] - for metric in metrics: - if info := PERF_METRICS.get(metric): - if info.event in perf: - value, unit = perf[info.event] - else: - # Without the corresponding permissions, - # we only get access to the userspace versions of the counters. - value, unit = perf[f"{info.event}:u"] + for metric in perf_metrics: + results.append(get_perf_result(perf, metric)) + for metric in rusage_metrics: + results.append(get_rusage_result(rusage, metric)) - value *= PERF_UNITS.get(unit, info.factor) - results.append(Result(metric, value, info.unit)) + with open(output, "a" if append else "w") as f: + for result in results: + for topic in topics: + f.write(f"{result.fmt(topic)}\n") - if info := RUSAGE_METRICS.get(metric): - value = getattr(rusage, info.name) * info.factor - results.append(Result(metric, value, info.unit)) + return measured.stdout, measured.stderr - return results + +class Args: + topic: list[str] + metric: list[str] + default_metrics: bool + output: Path + append: bool + cmd: str + args: list[str] if __name__ == "__main__": parser = argparse.ArgumentParser( - description=f"Measure resource usage of a command using perf and rusage. The results are appended to {OUTFILE.name}.", + description="Measure resource usage of a command using perf and rusage.", + formatter_class=argparse.ArgumentDefaultsHelpFormatter, ) parser.add_argument( - "-t", "--topic", + "-t", action="append", default=[], help="topic prefix for the metrics", ) parser.add_argument( - "-m", "--metric", + "-m", action="append", default=[], help=f"metrics to measure. Can be specified multiple times. Available metrics: {', '.join(sorted(ALL_METRICS))}", ) + parser.add_argument( + "--default-metrics", + "-d", + action="store_true", + help=f"measure a default set of metrics: {', '.join(sorted(DEFAULT_METRICS))}", + ) + parser.add_argument( + "--output", + "-o", + type=Path, + default=Path() / "measurements.jsonl", + help="output file to write measurements to, in the JSON Lines format", + ) + parser.add_argument( + "--append", + "-a", + action="store_true", + help="append to the output file instead of overwriting it", + ) parser.add_argument( "cmd", - nargs="*", help="command to measure the resource usage of", ) - args = parser.parse_args() - - topics: list[str] = args.topic - metrics: list[str] = args.metric - cmd: list[str] = args.cmd - - results = measure(cmd, metrics) - - with open(OUTFILE, "a+") as f: - for result in results: - for topic in topics: - f.write(f"{result.fmt(topic)}\n") + parser.add_argument( + "args", + nargs="*", + default=[], + help="arguments to pass to the command", + ) + args = parser.parse_args(namespace=Args()) + + metrics = set(args.metric) + if args.default_metrics: + metrics |= DEFAULT_METRICS + + main( + cmd=[args.cmd] + args.args, + output=args.output, + topics=args.topic, + metrics=metrics, + append=args.append, + ) diff --git a/scripts/bench/repeatedly.py b/scripts/bench/repeatedly.py new file mode 100755 index 0000000000..fae258cf02 --- /dev/null +++ b/scripts/bench/repeatedly.py @@ -0,0 +1,172 @@ +#!/usr/bin/env python3 + +import argparse +import json +import subprocess +import sys +from contextlib import contextmanager +from dataclasses import dataclass +from pathlib import Path + + +@dataclass +class Measurement: + metric: str + value: float + unit: str | None + + @classmethod + def from_json_str(cls, s: str) -> "Measurement": + data = json.loads(s.strip()) + return cls(data["metric"], data["value"], data.get("unit")) + + def to_json_str(self) -> str: + if self.unit is None: + return json.dumps({"metric": self.metric, "value": self.value}) + return json.dumps( + {"metric": self.metric, "value": self.value, "unit": self.unit} + ) + + +@contextmanager +def temporarily_move_outfile(outfile: Path): + outfile_tmp = outfile.with_name(outfile.name + ".repeatedly_tmp") + if outfile_tmp.exists(): + raise Exception(f"{outfile_tmp} already exists") + + outfile.touch() + outfile.rename(outfile_tmp) + try: + yield + finally: + outfile_tmp.rename(outfile) + + +def read_measurements_from_outfile(outfile: Path) -> list[Measurement]: + measurements = [] + with open(outfile, "r") as f: + for line in f: + measurements.append(Measurement.from_json_str(line)) + return measurements + + +def write_measurements_to_outfile( + outfile: Path, measurements: list[Measurement] +) -> None: + with open(outfile, "a") as f: + for measurement in measurements: + f.write(f"{measurement.to_json_str()}\n") + + +def run_once(cmd: list[str], outfile: Path) -> list[Measurement]: + with temporarily_move_outfile(outfile): + proc = subprocess.run(cmd) + if proc.returncode != 0: + sys.exit(proc.returncode) + + return read_measurements_from_outfile(outfile) + + +def sum_by_metric(measurements: list[Measurement]) -> dict[str, Measurement]: + totals: dict[str, Measurement] = {} + for measurement in measurements: + if existing := totals.get(measurement.metric): + measurement.value += existing.value + totals[measurement.metric] = measurement + return totals + + +def repeatedly( + cmd: list[str], + iterations: int, + outfile: Path, + drop_highest: int = 0, + drop_lowest: int = 0, +) -> list[Measurement]: + by_metric: dict[str, list[Measurement]] = {} + + for i in range(iterations): + for metric, measurement in sum_by_metric(run_once(cmd, outfile)).items(): + by_metric.setdefault(metric, []).append(measurement) + + if drop_highest + drop_lowest >= iterations: + raise ValueError( + f"drop_highest ({drop_highest}) + drop_lowest ({drop_lowest}) must be " + f"less than the number of iterations ({iterations})" + ) + + results = [] + for metric, measurements in by_metric.items(): + if drop_highest or drop_lowest: + measurements.sort(key=lambda m: m.value) + measurements = measurements[drop_lowest : len(measurements) - drop_highest] + if not measurements: + continue + unit = measurements[0].unit + value = sum(m.value for m in measurements) / len(measurements) + results.append(Measurement(metric, value, unit)) + + return results + + +class Args: + iterations: int + drop_highest: int + drop_lowest: int + outfile: Path + cmd: str + args: list[str] + + +if __name__ == "__main__": + parser = argparse.ArgumentParser( + description="Repeatedly run a command, averaging the measurements it writes.", + ) + parser.add_argument( + "-n", + "--iterations", + type=int, + default=5, + help="number of iterations", + ) + parser.add_argument( + "-H", + "--drop-highest", + type=int, + default=0, + help="drop the n highest values of each metric before averaging", + ) + parser.add_argument( + "-L", + "--drop-lowest", + type=int, + default=0, + help="drop the n lowest values of each metric before averaging", + ) + parser.add_argument( + "-o", + "--outfile", + type=Path, + default=Path("measurements.jsonl"), + help="measurements file the command under test writes to", + ) + parser.add_argument( + "cmd", + help="command to repeatedly run", + ) + parser.add_argument( + "args", + nargs="*", + default=[], + help="arguments to pass to the command", + ) + args = parser.parse_args(namespace=Args()) + + measurements = repeatedly( + [args.cmd] + args.args, + args.iterations, + args.outfile, + args.drop_highest, + args.drop_lowest, + ) + write_measurements_to_outfile(args.outfile, measurements) diff --git a/scripts/bench/run b/scripts/bench/run index 71af3550ca..5e7eb4c324 100755 --- a/scripts/bench/run +++ b/scripts/bench/run @@ -1,10 +1,12 @@ #!/usr/bin/env bash set -euo pipefail -BENCH="scripts/bench" +export ROOT_DIR="$(realpath .)" +export BENCH_DIR="$ROOT_DIR/scripts/bench" +export OUTPUT_FILE="$ROOT_DIR/measurements.jsonl" echo "Running benchmark: build" -"$BENCH/build/run" +"$BENCH_DIR/build/run" echo "Running benchmark: size" -"$BENCH/size/run" +"$BENCH_DIR/size/run" diff --git a/scripts/bench/size/run b/scripts/bench/size/run index 437671149f..38bea95813 100755 --- a/scripts/bench/size/run +++ b/scripts/bench/size/run @@ -1,40 +1,54 @@ #!/usr/bin/env python3 import json +import os from pathlib import Path +from typing import Generator -OUTFILE = Path() / "measurements.jsonl" +OUTFILE = Path(os.environ["OUTPUT_FILE"]) -def output_result(metric: str, value: float, unit: str | None = None) -> None: - data = {"metric": metric, "value": value} +def output_result( + topic: str, + category: str, + value: float, + unit: str | None = None, +) -> None: + data = {"metric": f"{topic}//{category}", "value": value} if unit is not None: data["unit"] = unit with open(OUTFILE, "a") as f: f.write(f"{json.dumps(data)}\n") -def measure_leans() -> None: - lean_files = 0 - lean_lines = 0 - for path in Path().glob("Cslib/**/*.lean"): - lean_files += 1 - with open(path) as f: - lean_lines += sum(1 for _ in f) - output_result("size/.lean//files", lean_files) - output_result("size/.lean//lines", lean_lines) +def find_lean_files() -> Generator[Path, None, None]: + for p in Path().iterdir(): + if p.name.startswith("."): + continue + elif p.is_dir(): + yield from p.glob("**/*.lean") + elif p.name.endswith(".lean"): + yield p -def measure_oleans() -> None: - olean_files = 0 - olean_bytes = 0 - for path in Path().glob(".lake/build/**/*.olean"): - olean_files += 1 - olean_bytes += path.stat().st_size - output_result("size/.olean//files", olean_files) - output_result("size/.olean//bytes", olean_bytes, "B") +def measure_lines(topic: str, *paths: Path) -> None: + for path in paths: + if path.is_file(): + lines = len(path.read_text().splitlines()) + output_result(topic, "lines", lines) + output_result(topic, "files", 1) + + +def measure_bytes(topic: str, *paths: Path) -> None: + for path in paths: + if path.is_file(): + bytes = path.stat().st_size + output_result(topic, "bytes", bytes, "B") + output_result(topic, "files", 1) if __name__ == "__main__": - measure_leans() - measure_oleans() + measure_lines("size/.lean", *find_lean_files()) + measure_bytes("size/.olean", *Path().glob(".lake/build/**/*.olean")) + measure_bytes("size/.olean.server", *Path().glob(".lake/build/**/*.olean.server")) + measure_bytes("size/.olean.private", *Path().glob(".lake/build/**/*.olean.private"))