From 37f7c86a7591da1233cdf1d293bf851f43c65ba1 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Wed, 15 Apr 2026 15:17:13 +0200 Subject: move wip --- Algebra.lean | 2 - Algebra/Derivations.lean | 237 ----------------------------------- Algebra/Semantics.lean | 79 ------------ Algebra/Terms.lean | 312 ----------------------------------------------- Graded.lean | 1 - Graded/GradedMonad.lean | 99 --------------- lakefile.toml | 7 -- 7 files changed, 737 deletions(-) delete mode 100644 Algebra.lean delete mode 100644 Algebra/Derivations.lean delete mode 100644 Algebra/Semantics.lean delete mode 100644 Algebra/Terms.lean delete mode 100644 Graded.lean delete mode 100644 Graded/GradedMonad.lean diff --git a/Algebra.lean b/Algebra.lean deleted file mode 100644 index 26109ba..0000000 --- a/Algebra.lean +++ /dev/null @@ -1,2 +0,0 @@ -import Algebra.Terms -import Algebra.Derivations diff --git a/Algebra/Derivations.lean b/Algebra/Derivations.lean deleted file mode 100644 index b6e5cb5..0000000 --- a/Algebra/Derivations.lean +++ /dev/null @@ -1,237 +0,0 @@ -import Mathlib -import Algebra.Terms - -namespace NominalAlgebra - -section Theories - -variable (𝔸 : Type) [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable (sig : Signature) - -@[ext] -structure Equation where - vars : Type - [vars_nominal : NominalSet 𝔸 vars] - left : Term 𝔸 sig vars - right : Term 𝔸 sig vars - -namespace Equation - -instance (eq : Equation 𝔸 sig) : NominalSet 𝔸 eq.vars := - eq.vars_nominal - -def HasDepth - {𝔸 : Type} [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] {sig : Signature} - (eq : Equation 𝔸 sig) (n : β„•) : Prop := - eq.left.HasDepth n ∧ eq.right.HasDepth n - -end Equation - -def UniformEquation := - { eq : Equation 𝔸 sig // βˆƒ n, eq.HasDepth n } - -structure Theory where - sig : Signature - axioms : Set (UniformEquation 𝔸 sig) - axioms_orbitFinite : βˆ€ eq ∈ axioms, OrbitFinite 𝔸 eq.val.vars - -end Theories - -variable {𝔸 : Type} [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable {sig : Signature} - -section Helpers - -def UniformEquation.mk - (X : Type) [NominalSet 𝔸 X] {n : β„•} (t u : TermAtDepth 𝔸 sig X n) : - UniformEquation 𝔸 sig := - ⟨⟨X, t.val, u.val⟩, ⟨n, t.prop, u.prop⟩⟩ - -notation:50 X " ⊒ " lhs " ≣ " rhs => UniformEquation.mk X lhs rhs - -end Helpers - -section DerivableEquations - -inductive Derivable (T : Theory 𝔸) : (eq : UniformEquation 𝔸 T.sig) β†’ Prop - | refl {X : Type} [NominalSet 𝔸 X] {x : X} : - Derivable T (X ⊒ .var x ≣ .var x) - | symm {X : Type} [NominalSet 𝔸 X] - {m : β„•} {t u : TermAtDepth 𝔸 T.sig X m} : - Derivable T (X ⊒ u ≣ t) β†’ - Derivable T (X ⊒ t ≣ u) - | trans {X : Type} [NominalSet 𝔸 X] - {m : β„•} {t u v : TermAtDepth 𝔸 T.sig X m} : - Derivable T (X ⊒ t ≣ v) β†’ - Derivable T (X ⊒ v ≣ u) β†’ - Derivable T (X ⊒ t ≣ u) - | cong_pure {X : Type} [NominalSet 𝔸 X] - {f : T.sig.pure} {m : β„•} {ts us : T.sig.pureArgs f β†’ TermAtDepth 𝔸 T.sig X m} : - (βˆ€ x, Derivable T (X ⊒ ts x ≣ us x)) β†’ - Derivable T (X ⊒ .pure f ts ≣ .pure f us) - | cong_free {X : Type} [NominalSet 𝔸 X] - {a : 𝔸} {f : T.sig.free} {m : β„•} {ts us : T.sig.freeArgs f β†’ TermAtDepth 𝔸 T.sig X m} : - (βˆ€ x, Derivable T (X ⊒ ts x ≣ us x)) β†’ - Derivable T (X ⊒ .free a f ts ≣ .free a f us) - | cong_bound {X : Type} [NominalSet 𝔸 X] - {a : 𝔸} {f : T.sig.bound} {m : β„•} {ts us : T.sig.boundArgs f β†’ TermAtDepth 𝔸 T.sig X m} : - (βˆ€ x, Derivable T (X ⊒ ts x ≣ us x)) β†’ - Derivable T (X ⊒ .bound a f ts ≣ .bound a f us) - | ax' {X Y : Type} [NominalSet 𝔸 X] [NominalSet 𝔸 Y] - {m : β„•} {r s : TermAtDepth 𝔸 T.sig Y m} - {l : β„•} {Οƒ : UniformSubstitution 𝔸 T.sig Y X l} {Ο„ : FPerm 𝔸} : - ((Y ⊒ r ≣ s) ∈ T.axioms) β†’ - (βˆ€ (y : Y) (Ο€ : FPerm 𝔸), Derivable T (X ⊒ Οƒ (Ο€ β€’ y) ≣ Ο€ β€’ (Οƒ y))) β†’ - Derivable T (X ⊒ Οƒ.apply (Ο„ β€’ r) ≣ Οƒ.apply (Ο„ β€’ s)) - | perm {X : Type} [NominalSet 𝔸 X] - {a b : 𝔸} {f : T.sig.bound} {m : β„•} {ts us : T.sig.boundArgs f β†’ TermAtDepth 𝔸 T.sig X m} : - a β‰  b β†’ - (βˆ€ x, a # us x) β†’ - (βˆ€ x, Derivable T (X ⊒ ts x ≣ βΈ¨a, bβΈ© β€’ us x)) β†’ - Derivable T (X ⊒ .bound a f ts ≣ .bound b f us) - -def DerivableEq (T : Theory 𝔸) (X : Type) [NominalSet 𝔸 X] (n : β„•) : - Rel (TermAtDepth 𝔸 T.sig X n) (TermAtDepth 𝔸 T.sig X n) := - fun t u => Derivable T (X ⊒ t ≣ u) - -variable {X Y : Type} [NominalSet 𝔸 X] [NominalSet 𝔸 Y] - -def UniformSubstitution.DerivablyEquivariant - (T : Theory 𝔸) {l : β„•} (Οƒ : UniformSubstitution 𝔸 T.sig X Y l) : Prop := - (βˆ€ (x : X) (Ο€ : FPerm 𝔸), Derivable T (Y ⊒ Οƒ (Ο€ β€’ x) ≣ Ο€ β€’ Οƒ x)) - -variable {T : Theory 𝔸} {n : β„•} - -/-- Restated ax' rule using DerivablyEquivariant in the premiss. -/ -lemma Derivable.ax - {m : β„•} {r s : TermAtDepth 𝔸 T.sig Y m} - {l : β„•} {Οƒ : UniformSubstitution 𝔸 T.sig Y X l} {Ο„ : FPerm 𝔸} : - ((Y ⊒ r ≣ s) ∈ T.axioms) β†’ - Οƒ.DerivablyEquivariant T β†’ - Derivable T (X ⊒ Οƒ.apply (Ο„ β€’ r) ≣ Οƒ.apply (Ο„ β€’ s)) := .ax' - -lemma Derivable.of_eq - {m : β„•} {eq : UniformEquation 𝔸 T.sig} (t u : TermAtDepth 𝔸 T.sig eq.val.vars m) - (ht : t.val = eq.val.left := by rfl) - (hu : u.val = eq.val.right := by rfl) : - Derivable T (eq.val.vars ⊒ t ≣ u) β†’ - Derivable T eq := by - intro hderiv - have heq : (eq.val.vars ⊒ t ≣ u) = eq := by - apply Subtype.ext; ext - Β· rfl - Β· rfl - Β· exact heq_of_eq ht - Β· exact heq_of_eq hu - rw [← heq]; exact hderiv - -lemma Derivable.equivariant_substitution - {l : β„•} (Οƒ : UniformSubstitution 𝔸 T.sig Y X l) : - Οƒ.DerivablyEquivariant T β†’ - βˆ€ {n : β„•} (t : TermAtDepth 𝔸 T.sig Y n) (Ο€ : FPerm 𝔸), - Derivable T (X ⊒ Οƒ.apply (Ο€ β€’ t) ≣ Ο€ β€’ (Οƒ.apply t)) := by - intro hequi n t Ο€ - induction' t using TermAtDepth.induction <;> expose_names - Β· apply of_eq (Οƒ (Ο€ β€’ x)) (Ο€ β€’ Οƒ x) - exact hequi x Ο€ - Β· apply of_eq (.pure f (Οƒ.apply ∘ (Ο€ β€’ Β·) ∘ args)) (.pure f ((Ο€ β€’ Β·) ∘ Οƒ.apply ∘ args)) - apply Derivable.cong_pure - exact h - Β· apply of_eq (.free (Ο€ β€’ a) f (Οƒ.apply ∘ (Ο€ β€’ Β·) ∘ args)) (.free (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ Οƒ.apply ∘ args)) - apply Derivable.cong_free - exact h - Β· apply of_eq (.bound (Ο€ β€’ a) f (Οƒ.apply ∘ (Ο€ β€’ Β·) ∘ args)) (.bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ Οƒ.apply ∘ args)) - apply Derivable.cong_bound - exact h - -lemma Derivable.equivariant {m : β„•} {t u : TermAtDepth 𝔸 T.sig X m} : - βˆ€ (Ο€ : FPerm 𝔸), Derivable T (X ⊒ t ≣ u) β†’ Derivable T (X ⊒ Ο€ β€’ t ≣ Ο€ β€’ u) := by - intro Ο€ - let rename (Ο€ : FPerm 𝔸) (eq : UniformEquation 𝔸 T.sig) : UniformEquation 𝔸 T.sig := - ⟨⟨eq.val.vars, Ο€ β€’ eq.val.left, Ο€ β€’ eq.val.right⟩, by - obtain ⟨n, ⟨hn₁, hnβ‚‚βŸ©βŸ© := eq.prop - let left : TermAtDepth 𝔸 T.sig eq.val.vars n := ⟨eq.val.left, hnβ‚βŸ© - let right : TermAtDepth 𝔸 T.sig eq.val.vars n := ⟨eq.val.right, hnβ‚‚βŸ© - use n; exact ⟨(Ο€ β€’ left).prop, (Ο€ β€’ right).prop⟩⟩ - have rename_eq - {Y : Type} [NominalSet 𝔸 Y] {Ο€ : FPerm 𝔸} {k : β„•} - {r s : TermAtDepth 𝔸 T.sig Y k} : rename Ο€ (Y ⊒ r ≣ s) = (Y ⊒ Ο€ β€’ r ≣ Ο€ β€’ s) := rfl - suffices βˆ€ eq, Derivable T eq β†’ Derivable T (rename Ο€ eq) by - exact this (X ⊒ t ≣ u) - intro eq hderiv - induction' hderiv <;> expose_names - Β· exact .refl - Β· rw [rename_eq] - apply Derivable.symm - exact a_ih - Β· rw [rename_eq] at * - apply Derivable.trans - Β· exact a_ih - Β· exact a_ih_1 - Β· apply of_eq (TermAtDepth.pure f ((Ο€ β€’ Β·) ∘ ts)) (TermAtDepth.pure f ((Ο€ β€’ Β·) ∘ us)) - apply Derivable.cong_pure - exact a_ih - Β· apply of_eq (TermAtDepth.free (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ ts)) (TermAtDepth.free (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ us)) - apply Derivable.cong_free - exact a_ih - Β· apply of_eq (TermAtDepth.bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ ts)) (TermAtDepth.bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ us)) - apply Derivable.cong_bound - exact a_ih - Β· rw [rename_eq] - apply Derivable.trans (by apply Derivable.symm; apply equivariant_substitution; exact h_1) _ - apply Derivable.trans _ (by apply equivariant_substitution; exact h_1) - rw [← SemigroupAction.mul_smul, ← SemigroupAction.mul_smul] - apply Derivable.ax - Β· exact h - Β· exact h_1 - Β· apply of_eq (TermAtDepth.bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ ts)) (TermAtDepth.bound (Ο€ β€’ b) f ((Ο€ β€’ Β·) ∘ us)) - apply Derivable.perm - Β· intro hcontra - apply Ο€.val.injective at hcontra - contradiction - Β· intro x - show Ο€ β€’ a # Ο€ β€’ (us x) - rw [← Rel.equivariant 𝔸 NominalSet.IsFresh] - exact h_1 x - Β· intro x - show Derivable T (X_1 ⊒ Ο€ β€’ ts x ≣ βΈ¨Ο€ a, Ο€ bβΈ© β€’ Ο€ β€’ us x) - rw [← SemigroupAction.mul_smul, ← FPerm.mul_swap_eq_swap_mul, SemigroupAction.mul_smul] - exact a_ih x - -instance DerivableEq.instEquivariant : Rel.Equivariant 𝔸 (DerivableEq T X n) := by - constructor; intro t u - exact Derivable.equivariant - -@[refl] -lemma DerivableEq.refl (t : TermAtDepth 𝔸 T.sig X n) : DerivableEq T X n t t := by - induction' t using TermAtDepth.induction <;> expose_names - Β· apply Derivable.refl - Β· apply Derivable.cong_pure; assumption - Β· apply Derivable.cong_free; assumption - Β· apply Derivable.cong_bound; assumption - -@[symm] -lemma DerivableEq.symm {t u : TermAtDepth 𝔸 T.sig X n} : - DerivableEq T X n u t β†’ DerivableEq T X n t u := by - intro h - apply Derivable.symm - exact h - -@[trans] -lemma DerivableEq.trans {t u v : TermAtDepth 𝔸 T.sig X n} : - DerivableEq T X n t v β†’ DerivableEq T X n v u β†’ DerivableEq T X n t u := by - intro htv hvu - apply Derivable.trans - Β· exact htv - Β· exact hvu - -instance TermAtDepth.setoid : Setoid (TermAtDepth 𝔸 T.sig X n) where - r := DerivableEq T X n - iseqv := - { refl := DerivableEq.refl - symm := DerivableEq.symm - trans := DerivableEq.trans } - -end DerivableEquations - -end NominalAlgebra diff --git a/Algebra/Semantics.lean b/Algebra/Semantics.lean deleted file mode 100644 index 13b54a0..0000000 --- a/Algebra/Semantics.lean +++ /dev/null @@ -1,79 +0,0 @@ -import Mathlib -import Algebra.Terms -import Algebra.Derivations - -open CategoryTheory - -namespace NominalAlgebra - -section AlgebraDefinition - -variable (𝔸 : Type) [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable (sig : Signature) - -structure Algebra where - carrier : β„• β†’ Nom 𝔸 - pure (f : sig.pure) {m : β„•} : - (sig.pureArgs f β†’ carrier m) β†’β‚‘[𝔸] carrier (m + sig.pureDepth f) - free (f : sig.free) {m : β„•} : - (𝔸 Γ— (sig.freeArgs f β†’ carrier m)) β†’β‚‘[𝔸] carrier (m + sig.freeDepth f) - bound (f : sig.bound) {m : β„•} : - NameAbstraction 𝔸 (sig.boundArgs f β†’ carrier m) β†’β‚‘[𝔸] carrier (m + sig.boundDepth f) - -instance : CoeFun (Algebra 𝔸 sig) (fun _ => β„• β†’ Nom 𝔸) where - coe A := A.carrier - -@[ext] -structure Algebra.Hom (A B : Algebra 𝔸 sig) where - toFun : (n : β„•) β†’ (A n β†’β‚‘[𝔸] B n) - preserve_pure : βˆ€ (f : sig.pure) {m : β„•} (args : sig.pureArgs f β†’ A m), - toFun (m + sig.pureDepth f) (A.pure f args) = B.pure f (toFun m ∘ args) - preserve_free : βˆ€ (a : 𝔸) (f : sig.free) {m : β„•} (args : sig.freeArgs f β†’ A m), - toFun (m + sig.freeDepth f) (A.free f ⟨a, args⟩) = B.free f ⟨a, toFun m ∘ args⟩ - preserve_bound : βˆ€ (a : 𝔸) (f : sig.bound) {m : β„•} (args : sig.boundArgs f β†’ A m), - toFun (m + sig.boundDepth f) (A.bound f (βŸͺa⟫ args)) = B.bound f (βŸͺa⟫ toFun m ∘ args) - -instance {A B : Algebra 𝔸 sig} : CoeFun (Algebra.Hom 𝔸 sig A B) (fun _ => (n : β„•) β†’ (A n β†’β‚‘[𝔸] B n)) where - coe h := h.toFun - -end AlgebraDefinition - -section Algebra - -variable {𝔸 : Type} [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable {sig : Signature} - -namespace Algebra - -def Hom.id (A : Algebra 𝔸 sig) : Hom 𝔸 sig A A where - toFun _ := EquivariantMap.id 𝔸 - preserve_pure _ _ _ := rfl - preserve_free _ _ _ _ := rfl - preserve_bound _ _ _ _ := rfl - -def Hom.comp {A B C : Algebra 𝔸 sig} (h : Hom 𝔸 sig B C) (g : Hom 𝔸 sig A B) : Hom 𝔸 sig A C where - toFun n := EquivariantMap.comp 𝔸 (h n) (g n) - preserve_pure f m args := by - rw [EquivariantMap.comp_app, g.preserve_pure, h.preserve_pure] - rfl - preserve_free a f m args := by - rw [EquivariantMap.comp_app, g.preserve_free, h.preserve_free] - rfl - preserve_bound a f m args := by - rw [EquivariantMap.comp_app, g.preserve_bound, h.preserve_bound] - rfl - -instance : Category (Algebra 𝔸 sig) where - Hom := Hom 𝔸 sig - id := Hom.id - comp h g := Hom.comp g h - -def forgetfulFunctor : Algebra 𝔸 sig β₯€ Nom 𝔸 where - obj X := X 0 - map f := f.toFun 0 - -end Algebra - -end Algebra - -end NominalAlgebra diff --git a/Algebra/Terms.lean b/Algebra/Terms.lean deleted file mode 100644 index 568f5cb..0000000 --- a/Algebra/Terms.lean +++ /dev/null @@ -1,312 +0,0 @@ -import Mathlib -import Nominal - -namespace NominalAlgebra - -section Definitions - -/-- A graded signature. -/ -structure Signature where - pure : Type - free : Type - bound : Type - /-- Type representing the arguments required for an operation. -/ - args : pure βŠ• free βŠ• bound β†’ Type - args_fintype : βˆ€ f, Fintype (args f) := by intro; infer_instance - /-- Depth of an operation. -/ - depth : pure βŠ• free βŠ• bound β†’ β„• - -def Signature.pureArgs (sig : Signature) (f : sig.pure) : Type := sig.args (.inl f) -def Signature.freeArgs (sig : Signature) (f : sig.free) : Type := sig.args (.inr (.inl f)) -def Signature.boundArgs (sig : Signature) (f : sig.bound) : Type := sig.args (.inr (.inr f)) - -instance Signature.instPureArgsFintype (sig : Signature) (f : sig.pure) : Fintype (sig.pureArgs f) := sig.args_fintype (.inl f) -instance Signature.instFreeArgsFintype (sig : Signature) (f : sig.free) : Fintype (sig.freeArgs f) := sig.args_fintype (.inr (.inl f)) -instance Signature.instBoundArgsFintype (sig : Signature) (f : sig.bound) : Fintype (sig.boundArgs f) := sig.args_fintype (.inr (.inr f)) - -def Signature.arity (sig : Signature) (f : sig.pure βŠ• sig.free βŠ• sig.bound) : β„• := (sig.args_fintype f).card -def Signature.pureArity (sig : Signature) (f : sig.pure) : β„• := sig.arity (.inl f) -def Signature.freeArity (sig : Signature) (f : sig.free) : β„• := sig.arity (.inr (.inl f)) -def Signature.boundArity (sig : Signature) (f : sig.bound) : β„• := sig.arity (.inr (.inr f)) - -def Signature.pureDepth (sig : Signature) (f : sig.pure) : β„• := sig.depth (.inl f) -def Signature.freeDepth (sig : Signature) (f : sig.free) : β„• := sig.depth (.inr (.inl f)) -def Signature.boundDepth (sig : Signature) (f : sig.bound) : β„• := sig.depth (.inr (.inr f)) - -variable (𝔸 : Type) [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable (sig : Signature) - -inductive Term (X : Type) [NominalSet 𝔸 X] - | var (x : X) : Term X - | pure (f : sig.pure) (args : sig.pureArgs f β†’ Term X) : Term X - | free (a : 𝔸) (f : sig.free) (args : sig.freeArgs f β†’ Term X) : Term X - | bound (a : 𝔸) (f : sig.bound) (args : sig.boundArgs f β†’ Term X) : Term X - -inductive Term.HasDepth - {𝔸 : Type} [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] - {sig : Signature} - {X : Type} [NominalSet 𝔸 X] - : Term 𝔸 sig X β†’ β„• β†’ Prop - | var (x : X) : HasDepth (.var x) 0 - | pure (f : sig.pure) (args : sig.pureArgs f β†’ Term 𝔸 sig X) (k : β„•) : - (βˆ€ arg : sig.pureArgs f, HasDepth (args arg) k) β†’ HasDepth (.pure f args) (k + sig.pureDepth f) - | free (a : 𝔸) (f : sig.free) (args : sig.freeArgs f β†’ Term 𝔸 sig X) (k : β„•) : - (βˆ€ arg : sig.freeArgs f, HasDepth (args arg) k) β†’ HasDepth (.free a f args) (k + sig.freeDepth f) - | bound (a : 𝔸) (f : sig.bound) (args : sig.boundArgs f β†’ Term 𝔸 sig X) (k : β„•) : - (βˆ€ arg : sig.boundArgs f, HasDepth (args arg) k) β†’ HasDepth (.bound a f args) (k + sig.boundDepth f) - -def TermAtDepth (X : Type) [NominalSet 𝔸 X] (n : β„•) := - { t : Term 𝔸 sig X // t.HasDepth n } - -def Substitution (X : Type) [NominalSet 𝔸 X] (Y : Type) [NominalSet 𝔸 Y] := - X β†’ Term 𝔸 sig Y - -def UniformSubstitution (X : Type) [NominalSet 𝔸 X] (Y : Type) [NominalSet 𝔸 Y] (l : β„•) := - X β†’ TermAtDepth 𝔸 sig Y l - -end Definitions - -variable {𝔸 : Type} [Infinite 𝔸] [Countable 𝔸] [DecidableEq 𝔸] -variable {sig : Signature} -variable {X : Type} [NominalSet 𝔸 X] -variable {Y : Type} [NominalSet 𝔸 Y] - -section ConvenienceConstructors - -def TermAtDepth.var (x : X) : TermAtDepth 𝔸 sig X 0 := ⟨.var x, by constructor⟩ - -def TermAtDepth.pure {n : β„•} (f : sig.pure) (args : sig.pureArgs f β†’ TermAtDepth 𝔸 sig X n) : - TermAtDepth 𝔸 sig X (n + sig.pureDepth f) := - ⟨.pure f (Subtype.val ∘ args), by constructor; intro arg; exact (args arg).prop⟩ - -def TermAtDepth.free {n : β„•} (a : 𝔸) (f : sig.free) (args : sig.freeArgs f β†’ TermAtDepth 𝔸 sig X n) : - TermAtDepth 𝔸 sig X (n + sig.freeDepth f) := - ⟨.free a f (Subtype.val ∘ args), by constructor; intro arg; exact (args arg).prop⟩ - -def TermAtDepth.bound {n : β„•} (a : 𝔸) (f : sig.bound) (args : sig.boundArgs f β†’ TermAtDepth 𝔸 sig X n) : - TermAtDepth 𝔸 sig X (n + sig.boundDepth f) := - ⟨.bound a f (Subtype.val ∘ args), by constructor; intro arg; exact (args arg).prop⟩ - -theorem TermAtDepth.induction - {motive : {n : β„•} β†’ TermAtDepth 𝔸 sig X n β†’ Prop} - (var : βˆ€ (x : X), motive (.var x)) - (pure : βˆ€ {n : β„•} (f : sig.pure) (args : sig.pureArgs f β†’ TermAtDepth 𝔸 sig X n), - (βˆ€ x, motive (args x)) β†’ motive (.pure f args)) - (free : βˆ€ {n : β„•} (a : 𝔸) (f : sig.free) (args : sig.freeArgs f β†’ TermAtDepth 𝔸 sig X n), - (βˆ€ x, motive (args x)) β†’ motive (.free a f args)) - (bound : βˆ€ {n : β„•} (a : 𝔸) (f : sig.bound) (args : sig.boundArgs f β†’ TermAtDepth 𝔸 sig X n), - (βˆ€ x, motive (args x)) β†’ motive (.bound a f args)) - : βˆ€ {n : β„•} (t : TermAtDepth 𝔸 sig X n), motive t := by - intro n ⟨t, ht⟩ - induction' t generalizing n <;> cases ht <;> expose_names - Β· exact var x - Β· let args' : sig.pureArgs f β†’ TermAtDepth 𝔸 sig X k := fun x => ⟨args x, h x⟩ - have args_ih' : βˆ€ x, motive (args' x) := fun x => args_ih x (h x) - exact pure f args' args_ih' - Β· let args' : sig.freeArgs f β†’ TermAtDepth 𝔸 sig X k := fun x => ⟨args x, h x⟩ - have args_ih' : βˆ€ x, motive (args' x) := fun x => args_ih x (h x) - exact free a f args' args_ih' - Β· let args' : sig.boundArgs f β†’ TermAtDepth 𝔸 sig X k := fun x => ⟨args x, h x⟩ - have args_ih' : βˆ€ x, motive (args' x) := fun x => args_ih x (h x) - exact bound a f args' args_ih' - -end ConvenienceConstructors - -section Substitution - -def Substitution.apply (Οƒ : Substitution 𝔸 sig X Y) : Term 𝔸 sig X β†’ Term 𝔸 sig Y - | .var x => Οƒ x - | .pure f args => .pure f (fun x => Οƒ.apply (args x)) - | .free a f args => .free a f (fun x => Οƒ.apply (args x)) - | .bound a f args => .bound a f (fun x => Οƒ.apply (args x)) - -@[simp] lemma Substitution.apply_var {x : X} {Οƒ : Substitution 𝔸 sig X Y} : - Οƒ.apply (.var x) = (Οƒ x) := rfl - -@[simp] lemma Substitution.apply_pure - {f : sig.pure} {args : sig.pureArgs f β†’ Term 𝔸 sig X} {Οƒ : Substitution 𝔸 sig X Y} : - Οƒ.apply (.pure f args) = .pure f (Οƒ.apply ∘ args) := rfl - -@[simp] lemma Substitution.apply_free - {a : 𝔸} {f : sig.free} {args : sig.freeArgs f β†’ Term 𝔸 sig X} {Οƒ : Substitution 𝔸 sig X Y} : - Οƒ.apply (.free a f args) = .free a f (Οƒ.apply ∘ args) := rfl - -@[simp] lemma Substitution.apply_bound - {a : 𝔸} {f : sig.bound} {args : sig.boundArgs f β†’ Term 𝔸 sig X} {Οƒ : Substitution 𝔸 sig X Y} : - Οƒ.apply (.bound a f args) = .bound a f (Οƒ.apply ∘ args) := rfl - -def UniformSubstitution.toSubstitution {l : β„•} (Οƒ : UniformSubstitution 𝔸 sig X Y l) : Substitution 𝔸 sig X Y := - fun x => (Οƒ x).val - -def UniformSubstitution.apply {n l : β„•} (Οƒ : UniformSubstitution 𝔸 sig X Y l) (t : TermAtDepth 𝔸 sig X n) : - TermAtDepth 𝔸 sig Y (n + l) := - βŸ¨Οƒ.toSubstitution.apply t.val, by - suffices βˆ€ t n, t.HasDepth n β†’ (Οƒ.toSubstitution.apply t).HasDepth (n + l) by - exact this t.val n t.prop - intro t; fun_induction Substitution.apply - Β· intro n h; cases h - rw [Nat.zero_add] - exact (Οƒ _).prop - all_goals - intro n h; cases h; expose_names - rw [Nat.add_right_comm] - constructor; intro arg - apply ih1; exact h arg⟩ - -@[simp] lemma UniformSubstitution.apply_var - {x : X} {l : β„•} {Οƒ : UniformSubstitution 𝔸 sig X Y l} : - (Οƒ.apply (.var x)).val = (Οƒ x).val := rfl - -@[simp] lemma UniformSubstitution.apply_pure - {n : β„•} {f : sig.pure} {args : sig.pureArgs f β†’ TermAtDepth 𝔸 sig X n} - {l : β„•} {Οƒ : UniformSubstitution 𝔸 sig X Y l} : - (Οƒ.apply (.pure f args)).val = (TermAtDepth.pure f (Οƒ.apply ∘ args)).val := rfl - -@[simp] lemma UniformSubstitution.apply_free - {n : β„•} {a : 𝔸} {f : sig.free} {args : sig.freeArgs f β†’ TermAtDepth 𝔸 sig X n} - {l : β„•} {Οƒ : UniformSubstitution 𝔸 sig X Y l} : - (Οƒ.apply (.free a f args)).val = (TermAtDepth.free a f (Οƒ.apply ∘ args)).val := rfl - -@[simp] lemma UniformSubstitution.apply_bound - {n : β„•} {a : 𝔸} {f : sig.bound} {args : sig.boundArgs f β†’ TermAtDepth 𝔸 sig X n} - {l : β„•} {Οƒ : UniformSubstitution 𝔸 sig X Y l} : - (Οƒ.apply (.bound a f args)).val = (TermAtDepth.bound a f (Οƒ.apply ∘ args)).val := rfl - -end Substitution - -section NominalSet - -namespace Term - -private def rename (Ο€ : FPerm 𝔸) : Term 𝔸 sig X β†’ Term 𝔸 sig X - | .var x => .var (Ο€ β€’ x) - | .pure f args => .pure f (fun x => rename Ο€ (args x)) - | .free a f args => .free (Ο€ β€’ a) f (fun x => rename Ο€ (args x)) - | .bound a f args => .bound (Ο€ β€’ a) f (fun x => rename Ο€ (args x)) - -private lemma one_rename (t : Term 𝔸 sig X) : t.rename 1 = t := by - induction' t <;> all_goals simp [rename, *] - -private lemma mul_rename (Ο€ Ο„ : FPerm 𝔸) (t : Term 𝔸 sig X) : - t.rename (Ο€ * Ο„) = (t.rename Ο„).rename Ο€ := by - induction' t <;> all_goals simp [rename, mul_smul, *] - -instance : PermSet 𝔸 (Term 𝔸 sig X) where - smul := rename - one_smul := one_rename - mul_smul := mul_rename - -@[simp] lemma smul_var {Ο€ : FPerm 𝔸} {x : X} : - Ο€ β€’ (.var x : Term 𝔸 sig X) = .var (Ο€ β€’ x) := rfl - -@[simp] lemma smul_pure {Ο€ : FPerm 𝔸} {f : sig.pure} {args : sig.pureArgs f β†’ Term 𝔸 sig X} : - Ο€ β€’ Term.pure f args = .pure f ((Ο€ β€’ Β·) ∘ args) := rfl - -@[simp] lemma smul_free {Ο€ : FPerm 𝔸} {a : 𝔸} {f : sig.free} {args : sig.freeArgs f β†’ Term 𝔸 sig X} : - Ο€ β€’ Term.free a f args = .free (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ args) := rfl - -@[simp] lemma smul_bound {Ο€ : FPerm 𝔸} {a : 𝔸} {f : sig.bound} {args : sig.boundArgs f β†’ Term 𝔸 sig X} : - Ο€ β€’ Term.bound a f args = .bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ args) := rfl - -private def atoms : Term 𝔸 sig X β†’ Set 𝔸 - | .var x => NominalSet.supp 𝔸 x - | .pure f args => ⋃₀ {(args x).atoms | x : sig.pureArgs f} - | .free a f args => {a} βˆͺ ⋃₀ {(args x).atoms | x : sig.freeArgs f} - | .bound a f args => {a} βˆͺ ⋃₀ {(args x).atoms | x : sig.boundArgs f} - -private lemma atoms_finite (t : Term 𝔸 sig X) : t.atoms.Finite := by - fun_induction atoms <;> all_goals expose_names - Β· exact NominalSet.supp_finite 𝔸 - Β· apply Set.Finite.sUnion - Β· simp only [Set.setOf_exists, Set.setOf_eq_eq_singleton', Set.iUnion_singleton_eq_range] - apply Set.finite_range - Β· intro S ⟨x, hS⟩ - rw [← hS] - exact ih1 x - all_goals - apply Set.Finite.union - Β· exact Set.finite_singleton a - Β· apply Set.Finite.sUnion - Β· simp only [Set.setOf_exists, Set.setOf_eq_eq_singleton', Set.iUnion_singleton_eq_range] - apply Set.finite_range - Β· intro S ⟨x, hS⟩ - rw [← hS] - exact ih1 x - -private lemma atoms_support (t : Term 𝔸 sig X) : PermSet.HasSupport 𝔸 t t.atoms := by - intro Ο€ - fun_induction atoms <;> all_goals expose_names - Β· have hsupp : PermSet.HasSupport 𝔸 x (NominalSet.supp 𝔸 x) := NominalSet.supp_is_support 𝔸 - intro hΟ€ - simp only [PermSet.fix', smul_var, Term.var.injEq, Set.mem_setOf_eq] - exact hsupp hΟ€ - Β· intro hΟ€ - simp only [PermSet.fix', smul_pure, Term.pure.injEq, heq_eq_eq, true_and, Set.mem_setOf_eq] - ext x - rw [Function.comp_apply] - apply ih1 - apply PermSet.fix_antitone_mem 𝔸 hΟ€ - apply Set.subset_sUnion_of_mem - use x - all_goals - intro hΟ€ - simp only [PermSet.fix', smul_free, smul_bound, Term.free.injEq, Term.bound.injEq, heq_eq_eq, - true_and, Set.mem_setOf_eq] - constructor - Β· apply PermSet.fix_antitone_mem 𝔸 hΟ€ - apply Set.subset_union_left - rfl - Β· ext x - rw [Function.comp_apply] - apply ih1 - apply PermSet.fix_antitone_mem 𝔸 hΟ€ - apply Set.subset_union_of_subset_right - apply Set.subset_sUnion_of_mem - use x - -instance : NominalSet 𝔸 (Term 𝔸 sig X) where - fin_supp t := by - use t.atoms - exact ⟨t.atoms_support, t.atoms_finite⟩ - -instance instHasDepthEquivariant {n : β„•} : - Set.Equivariant 𝔸 {t : Term 𝔸 sig X | t.HasDepth n} := by - constructor; intro t Ο€ ht - suffices βˆ€ (t : Term 𝔸 sig X) n, t.HasDepth n β†’ (t.rename Ο€).HasDepth n by - exact this t n ht - intro t; fun_induction rename - Β· intro n h; cases h; constructor - all_goals - intro n h; cases h - expose_names - constructor; intro arg - apply ih1; exact h arg - -end Term - -namespace TermAtDepth - -instance {n : β„•} : NominalSet 𝔸 (TermAtDepth 𝔸 sig X n) := - (Subtype.instNominalSetElem 𝔸 : NominalSet 𝔸 {t : Term 𝔸 sig X | t.HasDepth n}) - -@[simp] lemma smul_var - {Ο€ : FPerm 𝔸} {x : X} : - (Ο€ β€’ (.var x : TermAtDepth 𝔸 sig X 0)).val = (TermAtDepth.var (Ο€ β€’ x)).val := rfl - -@[simp] lemma smul_pure - {Ο€ : FPerm 𝔸} {n : β„•} {f : sig.pure} {args : sig.pureArgs f β†’ TermAtDepth 𝔸 sig X n} : - (Ο€ β€’ TermAtDepth.pure f args).val = (TermAtDepth.pure f ((Ο€ β€’ Β·) ∘ args)).val := rfl - -@[simp] lemma smul_free - {Ο€ : FPerm 𝔸} {n : β„•} {a : 𝔸} {f : sig.free} {args : sig.freeArgs f β†’ TermAtDepth 𝔸 sig X n} : - (Ο€ β€’ TermAtDepth.free a f args).val = (TermAtDepth.free (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ args)).val := rfl - -@[simp] lemma smul_bound - {Ο€ : FPerm 𝔸} {n : β„•} {a : 𝔸} {f : sig.bound} {args : sig.boundArgs f β†’ TermAtDepth 𝔸 sig X n} : - (Ο€ β€’ TermAtDepth.bound a f args).val = (TermAtDepth.bound (Ο€ β€’ a) f ((Ο€ β€’ Β·) ∘ args)).val := rfl - -end TermAtDepth - -end NominalSet - -end NominalAlgebra diff --git a/Graded.lean b/Graded.lean deleted file mode 100644 index 39b3ce2..0000000 --- a/Graded.lean +++ /dev/null @@ -1 +0,0 @@ -import Graded.GradedMonad diff --git a/Graded/GradedMonad.lean b/Graded/GradedMonad.lean deleted file mode 100644 index 39d543c..0000000 --- a/Graded/GradedMonad.lean +++ /dev/null @@ -1,99 +0,0 @@ -import Mathlib - -namespace CategoryTheory - -universe v u - -section Definition - -structure GradedMonad (C : Type u) [Category.{v} C] where - toFunctor : β„• β†’ C β₯€ C - Ξ· : 𝟭 _ ⟢ toFunctor 0 - ΞΌ (n k : β„•) : toFunctor k β‹™ toFunctor n ⟢ toFunctor (n + k) - assoc : βˆ€ (X : C) (n k m : β„•), - (toFunctor n).map (NatTrans.app (ΞΌ k m) X) ≫ (ΞΌ n (k + m)).app X = - (ΞΌ n k).app ((toFunctor m).obj X) ≫ (ΞΌ (n + k) m).app X ≫ eqToHom (by rw [Nat.add_assoc]) := - by cat_disch - left_unit : βˆ€ (X : C) (n : β„•), - Ξ·.app ((toFunctor n).obj X) ≫ (ΞΌ 0 n).app X = - πŸ™ ((toFunctor n).obj X) ≫ eqToHom (by rw [Nat.zero_add]) := - by cat_disch - right_unit : βˆ€ (X : C) (n : β„•), - (toFunctor n).map (Ξ·.app X) ≫ (ΞΌ n 0).app X = - πŸ™ ((toFunctor n).obj X) := - by cat_disch - -namespace GradedMonad - -variable {C : Type u} [Category.{v} C] - -instance : CoeFun (GradedMonad C) (fun _ => β„• β†’ C β₯€ C) where - coe M := M.toFunctor - -@[reassoc] -lemma unit_naturality (M : GradedMonad C) {X Y : C} (f : X ⟢ Y) : - f ≫ M.Ξ·.app Y = M.Ξ·.app X ≫ (M 0).map f := - M.Ξ·.naturality _ - -@[reassoc] -lemma multiplication_naturality (M : GradedMonad C) {X Y : C} (f : X ⟢ Y) {n k : β„•} : - (M n).map ((M k).map f) ≫ (M.ΞΌ n k).app Y = (M.ΞΌ n k).app X ≫ (M (n + k)).map f := - (M.ΞΌ n k).naturality _ - -end GradedMonad - -end Definition - -section Instances - -namespace GradedMonad - -variable {C : Type u} [Category.{v} C] - -def ofMonad (M : Monad C) : GradedMonad C where - toFunctor _ := M.toFunctor - Ξ· := M.Ξ· - ΞΌ _ _ := M.ΞΌ - assoc X _ _ _ := by simp only [Functor.comp_obj, eqToHom_refl, Category.comp_id]; exact M.assoc X - left_unit X _ := by simp only [eqToHom_refl, Category.comp_id]; exact M.left_unit X - right_unit X _ := by exact M.right_unit X - -def toMonad (M : GradedMonad C) : Monad C := - { M 0 with - Ξ· := M.Ξ· - ΞΌ := M.ΞΌ 0 0 - assoc X := by - have h := M.assoc X 0 0 0 - simp only [Functor.comp_obj, Nat.add_zero, eqToHom_refl, Category.comp_id] at h - exact h - left_unit X := by - have h := M.left_unit X 0 - simp only [Functor.id_obj, Nat.add_zero, eqToHom_refl, Category.comp_id] at h - exact h - right_unit X := M.right_unit X 0 } - -lemma toMonad_ofMonad {M : Monad C} : (ofMonad M).toMonad = M := rfl - -private def compFunctor (F : C β₯€ C) : β„• β†’ C β₯€ C - | 0 => 𝟭 C - | n + 1 => compFunctor F n β‹™ F - -private lemma compFunctor_comp (F : C β₯€ C) (n k : β„•) : - compFunctor F k β‹™ compFunctor F n = compFunctor F (n + k) := by - induction' n <;> all_goals expose_names - Β· simp [compFunctor, Functor.comp_id] - Β· rw [show n + 1 + k = n + k + 1 by ac_nf, compFunctor, compFunctor, ← h]; rfl - -def ofComp (F : C β₯€ C) : GradedMonad C where - toFunctor := compFunctor F - Ξ· := NatTrans.id (𝟭 C) - ΞΌ n k := NatTrans.id (compFunctor F k β‹™ compFunctor F n) ≫ eqToHom (compFunctor_comp _ n k) - assoc X n k m := by simp [eqToHom_map] - left_unit X n := by simp [compFunctor] - right_unit X n := by simp [compFunctor] - -end GradedMonad - -end Instances - -end CategoryTheory diff --git a/lakefile.toml b/lakefile.toml index 513bf8e..21d1e5c 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -9,10 +9,3 @@ rev = "v4.29.0" [[lean_lib]] name = "Nominal" - -[[lean_lib]] -name = "Graded" - -[[lean_lib]] -name = "Algebra" -needs = ["Nominal", "Graded"] -- cgit v1.3.1