├── .github └── workflows │ └── main.yml ├── .gitignore ├── GroundZero.lean ├── GroundZero ├── Algebra │ ├── Basic.lean │ ├── Boolean.lean │ ├── Category.lean │ ├── EilenbergMacLane.lean │ ├── Geometry.lean │ ├── Group │ │ ├── Action.lean │ │ ├── Alternating.lean │ │ ├── Automorphism.lean │ │ ├── Basic.lean │ │ ├── Differential.lean │ │ ├── Factor.lean │ │ ├── Finite.lean │ │ ├── Free.lean │ │ ├── Homotopy.lean │ │ ├── Isomorphism.lean │ │ ├── Lemmas.lean │ │ ├── Periodic.lean │ │ ├── Presentation.lean │ │ ├── Product.lean │ │ ├── Semidirect.lean │ │ ├── Subgroup.lean │ │ ├── Symmetric.lean │ │ └── Z.lean │ ├── Monoid.lean │ ├── Orgraph.lean │ ├── Reals.lean │ ├── Ring.lean │ └── Transformational.lean ├── Cubical │ ├── Connection.lean │ ├── Cubes.lean │ ├── Example.lean │ ├── Path.lean │ └── V.lean ├── Exercises │ ├── Chap1.lean │ ├── Chap2.lean │ ├── Chap3.lean │ ├── Chap4.lean │ ├── Chap5.lean │ └── README.md ├── HITs │ ├── Circle.lean │ ├── Coequalizer.lean │ ├── Colimit.lean │ ├── Flattening.lean │ ├── Generalized.lean │ ├── Int.lean │ ├── Interval.lean │ ├── Join.lean │ ├── Merely.lean │ ├── Moebius.lean │ ├── Pushout.lean │ ├── Quotient.lean │ ├── Reals.lean │ ├── Setquot.lean │ ├── Sphere.lean │ ├── Suspension.lean │ ├── Trunc.lean │ └── Wedge.lean ├── Meta │ ├── Basic.lean │ ├── HottTheory.lean │ ├── Notation.lean │ ├── Tactic.lean │ └── Trust.lean ├── Modal │ ├── Disc.lean │ ├── Etale.lean │ └── Infinitesimal.lean ├── Proto.lean ├── Structures.lean ├── Theorems │ ├── Classical.lean │ ├── Connectedness.lean │ ├── Equiv.lean │ ├── Fibration.lean │ ├── Functions.lean │ ├── Funext.lean │ ├── Hopf.lean │ ├── Nat.lean │ ├── Ontological.lean │ ├── Pullback.lean │ ├── Univalence.lean │ └── Weak.lean └── Types │ ├── Category.lean │ ├── CellComplex.lean │ ├── Coproduct.lean │ ├── Ens.lean │ ├── Equiv.lean │ ├── HEq.lean │ ├── Id.lean │ ├── Integer.lean │ ├── Lost.lean │ ├── Nat.lean │ ├── Precategory.lean │ ├── Product.lean │ ├── Setquot.lean │ ├── Sigma.lean │ └── Unit.lean ├── LICENSE ├── Makefile ├── README.md ├── lake-manifest.json ├── lakefile.lean ├── lean-toolchain └── pictures └── dependency-map.svg /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | - push 5 | 6 | jobs: 7 | build: 8 | runs-on: ubuntu-latest 9 | 10 | steps: 11 | - name: Checkout code 12 | uses: actions/checkout@v2 13 | 14 | - name: Install Lean 15 | run: | 16 | curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh -s - -y --default-toolchain `cat lean-toolchain` 17 | echo "$HOME/.elan/bin" >> $GITHUB_PATH 18 | 19 | - name: Build 20 | run: lake build 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.olean 2 | *.cpp 3 | *.o 4 | *.a 5 | /nongithub 6 | /build 7 | /lean_packages 8 | /.lake 9 | -------------------------------------------------------------------------------- /GroundZero.lean: -------------------------------------------------------------------------------- 1 | -- Automatically generated by `lake script run updateIndex`, do not edit it manually. 2 | import GroundZero.Algebra.Basic 3 | import GroundZero.Algebra.Boolean 4 | import GroundZero.Algebra.Category 5 | import GroundZero.Algebra.EilenbergMacLane 6 | import GroundZero.Algebra.Geometry 7 | import GroundZero.Algebra.Group.Action 8 | import GroundZero.Algebra.Group.Alternating 9 | import GroundZero.Algebra.Group.Automorphism 10 | import GroundZero.Algebra.Group.Basic 11 | import GroundZero.Algebra.Group.Differential 12 | import GroundZero.Algebra.Group.Factor 13 | import GroundZero.Algebra.Group.Finite 14 | import GroundZero.Algebra.Group.Free 15 | import GroundZero.Algebra.Group.Homotopy 16 | import GroundZero.Algebra.Group.Isomorphism 17 | import GroundZero.Algebra.Group.Lemmas 18 | import GroundZero.Algebra.Group.Periodic 19 | import GroundZero.Algebra.Group.Presentation 20 | import GroundZero.Algebra.Group.Product 21 | import GroundZero.Algebra.Group.Semidirect 22 | import GroundZero.Algebra.Group.Subgroup 23 | import GroundZero.Algebra.Group.Symmetric 24 | import GroundZero.Algebra.Group.Z 25 | import GroundZero.Algebra.Monoid 26 | import GroundZero.Algebra.Orgraph 27 | import GroundZero.Algebra.Reals 28 | import GroundZero.Algebra.Ring 29 | import GroundZero.Algebra.Transformational 30 | import GroundZero.Cubical.Connection 31 | import GroundZero.Cubical.Cubes 32 | import GroundZero.Cubical.Example 33 | import GroundZero.Cubical.Path 34 | import GroundZero.Cubical.V 35 | import GroundZero.Exercises.Chap1 36 | import GroundZero.Exercises.Chap2 37 | import GroundZero.Exercises.Chap3 38 | import GroundZero.Exercises.Chap4 39 | import GroundZero.Exercises.Chap5 40 | import GroundZero.HITs.Circle 41 | import GroundZero.HITs.Coequalizer 42 | import GroundZero.HITs.Colimit 43 | import GroundZero.HITs.Flattening 44 | import GroundZero.HITs.Generalized 45 | import GroundZero.HITs.Int 46 | import GroundZero.HITs.Interval 47 | import GroundZero.HITs.Join 48 | import GroundZero.HITs.Merely 49 | import GroundZero.HITs.Moebius 50 | import GroundZero.HITs.Pushout 51 | import GroundZero.HITs.Quotient 52 | import GroundZero.HITs.Reals 53 | import GroundZero.HITs.Setquot 54 | import GroundZero.HITs.Sphere 55 | import GroundZero.HITs.Suspension 56 | import GroundZero.HITs.Trunc 57 | import GroundZero.HITs.Wedge 58 | import GroundZero.Meta.Basic 59 | import GroundZero.Meta.HottTheory 60 | import GroundZero.Meta.Notation 61 | import GroundZero.Meta.Tactic 62 | import GroundZero.Meta.Trust 63 | import GroundZero.Modal.Disc 64 | import GroundZero.Modal.Etale 65 | import GroundZero.Modal.Infinitesimal 66 | import GroundZero.Proto 67 | import GroundZero.Structures 68 | import GroundZero.Theorems.Classical 69 | import GroundZero.Theorems.Connectedness 70 | import GroundZero.Theorems.Equiv 71 | import GroundZero.Theorems.Fibration 72 | import GroundZero.Theorems.Functions 73 | import GroundZero.Theorems.Funext 74 | import GroundZero.Theorems.Hopf 75 | import GroundZero.Theorems.Nat 76 | import GroundZero.Theorems.Ontological 77 | import GroundZero.Theorems.Pullback 78 | import GroundZero.Theorems.Univalence 79 | import GroundZero.Theorems.Weak 80 | import GroundZero.Types.Category 81 | import GroundZero.Types.CellComplex 82 | import GroundZero.Types.Coproduct 83 | import GroundZero.Types.Ens 84 | import GroundZero.Types.Equiv 85 | import GroundZero.Types.HEq 86 | import GroundZero.Types.Id 87 | import GroundZero.Types.Integer 88 | import GroundZero.Types.Lost 89 | import GroundZero.Types.Nat 90 | import GroundZero.Types.Precategory 91 | import GroundZero.Types.Product 92 | import GroundZero.Types.Setquot 93 | import GroundZero.Types.Sigma 94 | import GroundZero.Types.Unit 95 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Boolean.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Ring 2 | 3 | namespace GroundZero.Algebra 4 | class Prering.boolean (T : Prering) := 5 | (sqr : Π (x : T.carrier), x * x = x) 6 | end GroundZero.Algebra -------------------------------------------------------------------------------- /GroundZero/Algebra/EilenbergMacLane.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | import GroundZero.HITs.Suspension 3 | import GroundZero.HITs.Trunc 4 | 5 | open GroundZero.Theorems.Functions GroundZero.Theorems.Equiv 6 | open GroundZero.Types.Equiv (idtoeqv apd transport) 7 | open GroundZero.Types.Id (isPointed ap) 8 | open GroundZero.Structures 9 | open GroundZero.Types 10 | 11 | open GroundZero 12 | 13 | namespace GroundZero.Algebra 14 | universe u v 15 | 16 | hott axiom K1 (G : Group.{u}) : Type u := Opaque 𝟏 17 | 18 | namespace K1 19 | variable {G : Group} 20 | 21 | hott axiom base : K1 G := Opaque.intro ★ 22 | 23 | hott opaque axiom grpd : groupoid (K1 G) := 24 | λ _ _ _ _, λ (idp _), λ (idp _), idp _ 25 | 26 | hott opaque axiom loop (g : G.carrier) : @Id (K1 G) base base := idp base 27 | 28 | hott opaque axiom loop.mul (x y : G.carrier) : loop (G.φ x y) = loop x ⬝ loop y := 29 | trustCoherence 30 | 31 | hott axiom ind {C : K1 G → Type v} (baseπ : C base) (loopπ : Π (x : G.carrier), baseπ =[loop x] baseπ) 32 | (mulπ : Π (x y : G.carrier), loopπ (G.φ x y) =[λ p, baseπ =[p] baseπ, loop.mul x y] loopπ x ⬝′ loopπ y) 33 | (groupoidπ : Π x, groupoid (C x)) : Π x, C x := 34 | λ x, Quot.withUseOf (loopπ, mulπ, groupoidπ) (Opaque.ind (λ ★, baseπ) x) x 35 | 36 | attribute [induction_eliminator] ind 37 | 38 | hott axiom rec {C : Type v} (baseπ : C) (loopπ : G.carrier → baseπ = baseπ) 39 | (mulπ : Π x y, loopπ (G.φ x y) = loopπ x ⬝ loopπ y) 40 | (groupoidπ : groupoid C) : K1 G → C := 41 | λ x, Quot.withUseOf (loopπ, mulπ, groupoidπ) (Opaque.elim (λ ★, baseπ) x) x 42 | 43 | hott opaque axiom indβrule {C : K1 G → Type v} (baseπ : C base) (loopπ : Π (x : G.carrier), baseπ =[loop x] baseπ) 44 | (mulπ : Π (x y : G.carrier), loopπ (G.φ x y) =[λ p, baseπ =[p] baseπ, loop.mul x y] loopπ x ⬝′ loopπ y) 45 | (groupoidπ : Π x, groupoid (C x)) : Π x, apd (ind baseπ loopπ mulπ groupoidπ) (loop x) = loopπ x := 46 | λ _, trustCoherence 47 | 48 | hott opaque axiom recβrule {C : Type v} (baseπ : C) (loopπ : G.carrier → baseπ = baseπ) 49 | (mulπ : Π x y, loopπ (G.φ x y) = loopπ x ⬝ loopπ y) (groupoidπ : groupoid C) : 50 | Π x, ap (rec baseπ loopπ mulπ groupoidπ) (loop x) = loopπ x := 51 | λ _, trustCoherence 52 | 53 | attribute [irreducible] K1 54 | 55 | noncomputable instance : isPointed (K1 G) := ⟨base⟩ 56 | 57 | hott definition KΩ.mul : Ω¹(K1 G) → Ω¹(K1 G) → Ω¹(K1 G) := λ p q, p ⬝ q 58 | hott definition KΩ.one : Ω¹(K1 G) := idp base 59 | hott definition KΩ.inv : Ω¹(K1 G) → Ω¹(K1 G) := Id.inv 60 | 61 | hott definition KΩ (G : Group) : Group := 62 | @Group.intro (Ω¹(K1 G)) (grpd _ _) KΩ.mul KΩ.inv KΩ.one 63 | (λ _ _ _, Id.inv (Id.assoc _ _ _)) Id.lid Id.invComp 64 | 65 | hott definition homomorphism : Group.Hom G (KΩ G) := 66 | Group.mkhomo loop loop.mul 67 | 68 | hott definition loop.one : @Id Ω¹(K1 G) (loop G.e) (idp base) := 69 | Group.homoUnit homomorphism 70 | 71 | hott definition loop.inv : Π p, loop (G.ι p) = (loop p)⁻¹ := 72 | Group.homoInv homomorphism 73 | 74 | hott definition family (baseπ : Type u) 75 | (loopπ : G.carrier → baseπ = baseπ) 76 | (mulπ : Π x y, loopπ (G.φ x y) = loopπ x ⬝ loopπ y) 77 | (setπ : hset baseπ) : K1 G → 0-Type := 78 | begin 79 | fapply rec; 80 | { existsi baseπ; apply zeroEqvSet.left; apply setπ }; 81 | { intro x; fapply Sigma.prod; apply loopπ x; apply ntypeIsProp }; 82 | { intros x y; symmetry; 83 | transitivity; symmetry; apply Sigma.prodComp; 84 | fapply Sigma.prodEq; { symmetry; apply mulπ }; 85 | { apply propIsSet; apply ntypeIsProp } }; 86 | { apply ensIsGroupoid } 87 | end 88 | 89 | hott definition code' : K1 G → 0-Type := 90 | begin 91 | fapply family; exact G.carrier; 92 | { intro x; apply ua; existsi (G.φ · x); apply Prod.mk <;> 93 | existsi (G.φ · (G.ι x)) <;> intro y <;> change G.φ (G.φ _ _) _ = _; 94 | symmetry; apply Group.cancelRight; 95 | symmetry; apply Group.cancelLeft }; 96 | { intros x y; symmetry; transitivity; 97 | { symmetry; apply uacom }; 98 | apply ap ua; fapply Sigma.prod; 99 | { apply Theorems.funext; intro; apply G.mulAssoc }; 100 | { apply biinvProp } }; 101 | apply G.hset 102 | end 103 | 104 | hott definition code (x : K1 G) := (code' x).1 105 | 106 | hott lemma code.hset (z : K1 G) : hset (code z) := 107 | begin 108 | induction z; apply G.hset; apply setIsProp; 109 | { apply propIsSet; apply setIsProp }; 110 | { apply oneEqvGroupoid.forward; 111 | apply propIsNType _ 0; 112 | apply setIsProp } 113 | end 114 | 115 | attribute [irreducible] code.hset 116 | 117 | hott definition hsetBase : hset (@code _ G base) := code.hset base 118 | 119 | hott definition encode : Π (z : K1 G), base = z → code z := 120 | λ z p, transport code p G.e 121 | 122 | hott definition decode (z : K1 G) : code z → base = z := 123 | begin 124 | induction z; exact loop; 125 | { case loopπ x => 126 | change _ = _; transitivity; apply Equiv.transportCharacterization; 127 | apply Theorems.funext; intro y; transitivity; 128 | apply ap (λ p, Equiv.transport (λ x, base = x) (loop x) (loop p)); 129 | transitivity; apply Equiv.transportToTransportconst; 130 | transitivity; apply ap (Equiv.transportconst · y); 131 | transitivity; apply Id.mapInv; apply ap; 132 | transitivity; apply Equiv.mapOverComp; 133 | transitivity; apply ap; unfold code'; apply recβrule; 134 | apply Sigma.mapFstOverProd; apply uaβrev; 135 | transitivity; apply Equiv.transportOverInvContrMap; 136 | transitivity; apply ap; apply Equiv.idmap; 137 | transitivity; apply ap (· ⬝ loop x); apply loop.mul; 138 | transitivity; symmetry; apply Id.assoc; 139 | transitivity; apply ap; apply ap (· ⬝ loop x); apply loop.inv; 140 | transitivity; apply ap; apply Id.invComp; apply Id.rid }; 141 | { apply zeroEqvSet.forward; apply piRespectsNType 0; 142 | intro; apply zeroEqvSet.left; apply grpd }; 143 | { apply oneEqvGroupoid.forward; 144 | apply piRespectsNType 1; intro; 145 | apply hlevel.cumulative 0; 146 | apply zeroEqvSet.left; apply grpd } 147 | end 148 | 149 | hott lemma encodeDecode (z : K1 G) : Π (p : code z), encode z (decode z p) = p := 150 | begin 151 | induction z; 152 | { intro (x : G.carrier); change encode base (loop x) = _; 153 | transitivity; apply Equiv.transportToTransportconst; 154 | transitivity; apply ap (Equiv.transportconst · G.e); 155 | transitivity; apply Equiv.mapOverComp; 156 | transitivity; apply ap; unfold code'; apply recβrule; 157 | apply Sigma.mapFstOverProd; transitivity; 158 | apply uaβ; apply G.oneMul }; 159 | { apply Theorems.funext; intro; apply hsetBase }; 160 | { apply propIsSet; apply piProp; intro; apply hsetBase }; 161 | { apply oneEqvGroupoid.forward; apply propIsNType _ 0; 162 | intros p q; apply Theorems.funext; intro; apply code.hset } 163 | end 164 | 165 | hott lemma decodeEncode : Π (z : K1 G) (p : base = z), decode z (encode z p) = p := 166 | begin intros z p; induction p; apply loop.one end 167 | 168 | hott theorem univ : G ≅ KΩ G := 169 | begin 170 | fapply Group.mkiso; exact loop; 171 | { intros x y; apply loop.mul }; 172 | apply Prod.mk <;> existsi encode base; 173 | { intro; apply encodeDecode }; 174 | { apply decodeEncode } 175 | end 176 | end K1 177 | 178 | hott definition ItS (A : Type u) : ℕ → Type u 179 | | 0 => A 180 | | Nat.succ n => ∑ (ItS A n) 181 | 182 | open GroundZero.HITs (Trunc) 183 | 184 | hott definition K (G : Group) (n : ℕ) := 185 | ∥ItS (K1 G) n∥ₙ₊₁ 186 | 187 | end GroundZero.Algebra 188 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Geometry.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Basic 2 | 3 | open GroundZero.Structures (prop propset contr) 4 | open GroundZero.Types GroundZero.Proto 5 | open GroundZero.HITs 6 | open GroundZero.Types 7 | 8 | namespace GroundZero.Algebra 9 | universe u v 10 | 11 | hott def Pregeometry : Type (max u v + 1) := 12 | @Alg.{0, 0, u, v} 𝟎 𝟐 (Coproduct.elim explode (Bool.rec 3 4)) 13 | 14 | namespace Pregeometry 15 | hott def between (G : Pregeometry) (a b c : G.carrier) := 16 | (G.rel false (a, b, c, ★)).1 17 | 18 | hott def congruent (G : Pregeometry) (a b c d : G.carrier) := 19 | (G.rel true (a, b, c, d, ★)).1 20 | 21 | hott def prop₁ (G : Pregeometry) {a b c : G.carrier} : prop (G.between a b c) := 22 | (G.rel false (a, b, c, ★)).2 23 | 24 | hott def prop₂ (G : Pregeometry) {a b c d : G.carrier} : prop (G.congruent a b c d) := 25 | (G.rel true (a, b, c, d, ★)).2 26 | 27 | hott def collinear (G : Pregeometry) (a b c : G.carrier) := 28 | ∥G.between a b c + G.between c a b + G.between b c a∥ 29 | 30 | class geometry (G : Pregeometry) := 31 | (refl : Π a b, G.congruent a b b a) 32 | (trans : Π a₁ b₁ a₂ b₂ a₃ b₃, G.congruent a₁ b₁ a₂ b₂ → G.congruent a₁ b₁ a₃ b₃ → G.congruent a₂ b₂ a₃ b₃) 33 | (idp₁ : Π a b c, G.congruent a b c c → a = b) 34 | (idp₂ : Π a b, G.between a b a → a = b) 35 | (pasch : Π a b c u v, G.between a u c → G.between b v c → ∥Σ x, G.between u x b × G.between v x a∥) 36 | 37 | class nonlinear (G : Pregeometry) := 38 | (lower : ∥Σ a b c, (¬G.between a b c) × (¬G.between b c a) × (¬G.between c a b)∥) 39 | 40 | class planar (G : Pregeometry) := 41 | (upper : Π a b c u v, G.congruent a u a v → G.congruent b u b v → G.congruent c u c v → ¬(u = v) → G.collinear a b c) 42 | 43 | class planimetry (G : Pregeometry) extends geometry G, nonlinear G, planar G 44 | 45 | class isotropic (G : Pregeometry) := 46 | (construct : Π a b x y, ∥Σ z, G.between x y z × G.congruent y z a b∥) 47 | 48 | class continuous (G : Pregeometry) := 49 | (cut (φ ψ : G.carrier → Prop) : 50 | ∥Σ a, Π x y, (φ x).1 → (ψ y).1 → G.between a x y∥ → 51 | ∥Σ b, Π x y, (φ x).1 → (ψ y).1 → G.between x b y∥) 52 | 53 | class absolute (G : Pregeometry) extends geometry G, isotropic G := 54 | (five : Π x₁ y₁ z₁ u₁ x₂ y₂ z₂ u₂, ¬(x₁ = y₁) → G.between x₁ y₁ z₁ → G.between x₂ y₂ z₂ → 55 | G.congruent x₁ y₁ x₂ y₂ → G.congruent y₁ z₁ y₂ z₂ → 56 | G.congruent x₁ u₁ x₂ u₂ → G.congruent y₁ u₁ y₂ u₂ → 57 | G.congruent z₁ u₁ z₂ u₂) 58 | 59 | hott def segment (G : Pregeometry) (a b : G.carrier) : Ens G.carrier := 60 | ⟨λ c, G.between a c b, λ _, G.prop₁⟩ 61 | 62 | hott def geodesic (G : Pregeometry) (a b : G.carrier) : Ens G.carrier := 63 | ⟨G.collinear a b, λ _, Merely.uniq⟩ 64 | 65 | hott def circle (G : Pregeometry) (a b : G.carrier) : Ens G.carrier := 66 | ⟨λ c, G.congruent a b a c, λ _, G.prop₂⟩ 67 | 68 | hott def triangle (G : Pregeometry) (a b c : G.carrier) : Ens G.carrier := 69 | ⟨λ z, ∥G.between a z b + G.between b z c + G.between a z c∥, λ _, Merely.uniq⟩ 70 | 71 | hott def ray (G : Pregeometry) (a b : G.carrier) : Ens G.carrier := 72 | ⟨λ c, ∥G.between a c b + G.between a b c∥, λ _, Merely.uniq⟩ 73 | 74 | class euclidean (G : Pregeometry) extends absolute G := 75 | (fifth : Π a₁ b₁ a₂ b₂ a₃ b₃, 76 | Ens.parallel (geodesic G a₁ b₁) (geodesic G a₃ b₃) → 77 | Ens.parallel (geodesic G a₂ b₂) (geodesic G a₃ b₃) → 78 | Ens.parallel (geodesic G a₁ b₁) (geodesic G a₂ b₂)) 79 | end Pregeometry 80 | end GroundZero.Algebra 81 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Action.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Symmetric 2 | import GroundZero.HITs.Setquot 3 | 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | open GroundZero.Types 7 | open GroundZero.HITs 8 | open GroundZero 9 | 10 | namespace GroundZero.Algebra 11 | universe u v w 12 | 13 | namespace Group 14 | hott def leftAction (G : Group) (A : Type u) := 15 | Σ (φ : G.carrier → A → A), (Π x, φ G.e x = x) × (Π g h x, φ g (φ h x) = φ (G.φ g h) x) 16 | infix:20 " ⮎ " => leftAction 17 | 18 | hott def leftAction.id {G : Group} {A : Type u} (H : Structures.hset A) 19 | (φ ψ : G ⮎ A) (p : φ.1 ~ ψ.1) : φ = ψ := 20 | begin 21 | fapply Sigma.prod; apply Theorems.funext; exact p; 22 | apply productProp; apply piProp; intro; apply H; 23 | apply piProp; intro; apply piProp; intro; apply piProp; intro; apply H 24 | end 25 | 26 | hott def rightAction (G : Group) (A : Type u) := 27 | Σ (φ : A → G.carrier → A), (Π x, φ x G.e = x) × (Π g h x, φ (φ x g) h = φ x (G.φ g h)) 28 | infix:20 " ⮌ " => rightAction 29 | 30 | variable {G : Group} 31 | 32 | section 33 | variable {A : Type u} 34 | 35 | hott def rightAction.associated : (G ⮎ A) → (G ⮌ A) := 36 | λ ⟨φ, (p, q)⟩, ⟨λ x g, φ (G.ι g) x, (begin 37 | intro x; transitivity; apply ap (φ · x); 38 | symmetry; apply unitInv; apply p 39 | end, begin 40 | intros g h x; transitivity; 41 | apply q; apply ap (φ · x); 42 | symmetry; apply invExplode 43 | end)⟩ 44 | 45 | hott def orbit (φ : G ⮎ A) (x : A) := 46 | GroundZero.Algebra.im (φ.1 · x) 47 | 48 | hott def Orb (φ : G ⮎ A) (x : A) := 49 | (orbit φ x).subtype 50 | 51 | hott def orbitᵣ (φ : G ⮌ A) (x : A) := 52 | GroundZero.Algebra.im (φ.1 x) 53 | 54 | hott def Orbᵣ (φ : G ⮌ A) (x : A) := 55 | (orbitᵣ φ x).subtype 56 | end 57 | 58 | hott def S.ap {A : 0-Type} : S A ⮎ A.1 := 59 | ⟨λ f x, f.1 x, (idp, λ ⟨g, G⟩ ⟨h, G⟩ x, idp (g (h x)))⟩ 60 | 61 | hott def leftAction.cut {A : Type u} (φ : G.subgroup) : 62 | (G ⮎ A) → (Subgroup G φ ⮎ A) := 63 | λ ⟨φ, (p, q)⟩, ⟨λ ⟨g, G⟩ x, φ g x, (p, λ ⟨g, G⟩ ⟨h, G⟩, q g h)⟩ 64 | 65 | hott def leftAction.eqv {A : Type u} (φ : G ⮎ A) (n m : A) := 66 | ∥(Σ g, φ.1 g n = m)∥ 67 | 68 | hott def leftAction.refl {A : Type u} (φ : G ⮎ A) {a : A} : φ.eqv a a := 69 | begin apply HITs.Merely.elem; existsi G.e; apply φ.2.1 end 70 | 71 | hott def leftAction.symm {A : Type u} (φ : G ⮎ A) 72 | {a b : A} : φ.eqv a b → φ.eqv b a := 73 | begin 74 | apply HITs.Merely.lift; 75 | intro ⟨g, p⟩; existsi G.ι g; 76 | transitivity; apply ap; exact Id.inv p; 77 | transitivity; apply φ.2.2; 78 | transitivity; apply ap (φ.1 · a); 79 | apply G.mulLeftInv; apply φ.2.1 80 | end 81 | 82 | hott def leftAction.trans {A : Type u} (φ : G ⮎ A) 83 | {a b c : A} : φ.eqv a b → φ.eqv b c → φ.eqv a c := 84 | begin 85 | apply HITs.Merely.lift₂; intro ⟨g, p⟩ ⟨h, q⟩; 86 | existsi G.φ h g; transitivity; symmetry; apply φ.2.2; 87 | transitivity; apply ap; exact p; exact q 88 | end 89 | 90 | hott def leftAction.rel {A : Type u} (φ : G ⮎ A) : hrel A := 91 | λ n m, ⟨φ.eqv n m, HITs.Merely.uniq⟩ 92 | 93 | hott def leftAction.eqrel {A : Type u} (φ : G ⮎ A) : eqrel A := 94 | ⟨leftAction.rel φ, (λ _, φ.refl, λ _ _, φ.symm, λ _ _ _, φ.trans)⟩ 95 | 96 | hott def orbit.subset {A : Type u} (φ : G ⮎ A) {a b : A} 97 | (p : φ.eqv a b) : orbit φ a ⊆ orbit φ b := 98 | begin intros c G; apply φ.trans; apply φ.symm p; exact G end 99 | 100 | hott def Orbits {A : Type u} (φ : G ⮎ A) := 101 | Relquot φ.eqrel 102 | 103 | hott def transitive {A : Type u} (φ : G ⮎ A) := 104 | Π a b, ∥(Σ g, φ.fst g a = b)∥ 105 | 106 | hott def free {A : Type u} (φ : G ⮎ A) := 107 | Π x g h, φ.fst g x = φ.fst h x → g = h 108 | 109 | hott def regular {A : Type u} (φ : G ⮎ A) := 110 | Π a b, contr (Σ g, φ.fst g a = b) 111 | 112 | inductive Marked (A : Type u) (β : Type v) 113 | | elem : A → Marked A β 114 | | comp : β → Marked A β → Marked A β 115 | 116 | section 117 | private structure Fga.aux (A : Type u) (G : Group) := 118 | (val : Marked A G.carrier) 119 | 120 | attribute [nothott] Fga.aux Fga.aux.mk Fga.aux.recOn Fga.aux.rec Fga.aux.val 121 | 122 | def Fga (A : Type u) (G : Group) := Fga.aux A G 123 | end 124 | 125 | namespace Fga 126 | variable {A : Type u} 127 | 128 | def elem : A → Fga A G := aux.mk ∘ Marked.elem 129 | 130 | def φ (g : G.carrier) (x : Fga A G) : Fga A G := 131 | Fga.aux.mk (Marked.comp g x.val) 132 | 133 | axiom unit : Π (x : Fga A G), φ G.e x = x 134 | axiom assoc : Π (g h : G.carrier) (x : Fga A G), φ g (φ h x) = φ (G.φ g h) x 135 | 136 | axiom ens : Structures.hset (Fga A G) 137 | 138 | section 139 | variable (ψ : G ⮎ A) 140 | 141 | @[nothott] def rec.aux (H : Structures.hset A) : Marked A G.carrier → A 142 | | Marked.elem x => x 143 | | Marked.comp g x => ψ.1 g (aux H x) 144 | 145 | def rec (H : Structures.hset A) : Fga A G → A := rec.aux ψ H ∘ @aux.val A G 146 | end 147 | 148 | attribute [hottAxiom] Fga elem φ unit assoc ens rec 149 | 150 | attribute [irreducible] Fga 151 | 152 | hott def act : G ⮎ Fga A G := 153 | ⟨φ, (unit, assoc)⟩ 154 | end Fga 155 | 156 | hott def pact {A : Type u} : G ⮎ G.carrier × A := 157 | ⟨λ g ⟨h, x⟩, (G.φ g h, x), 158 | (λ ⟨g, x⟩, Product.prod (G.oneMul g) (idp x), 159 | λ g h ⟨f, x⟩, Product.prod (Id.inv (G.mulAssoc g h f)) (idp x))⟩ 160 | 161 | hott def regular.mk {A : Type u} (H : Structures.hset A) 162 | (φ : G ⮎ A) : transitive φ → free φ → regular φ := 163 | begin 164 | intros f g a b; fapply HITs.Merely.rec _ _ (f a b); 165 | { apply contrIsProp }; 166 | { intro p; existsi p; 167 | intro q; fapply Sigma.prod; 168 | { apply g a; transitivity; exact p.2; 169 | symmetry; exact q.2 }; 170 | { apply H } } 171 | end 172 | 173 | hott def regular.elim {A : Type u} 174 | (φ : G ⮎ A) : regular φ → transitive φ × free φ := 175 | begin 176 | intro H; apply Prod.mk; 177 | { intros a b; apply HITs.Merely.elem; exact (H a b).1 }; 178 | { intros x g h p; 179 | apply @ap (Σ g, φ.fst g x = φ.fst h x) G.carrier 180 | ⟨g, p⟩ ⟨h, Id.refl⟩ Sigma.fst; 181 | apply contrImplProp; apply H } 182 | end 183 | 184 | hott def regularIsProp {A : Type u} (φ : G ⮎ A) : prop (regular φ) := 185 | begin apply piProp; intro; apply piProp; intro; apply contrIsProp end 186 | 187 | hott def transitiveIsProp {A : Type u} (φ : G ⮎ A) : prop (transitive φ) := 188 | begin apply piProp; intro; apply piProp; intro; apply HITs.Merely.uniq end 189 | 190 | hott def freeIsProp {A : Type u} (φ : G ⮎ A) : prop (free φ) := 191 | begin apply piProp; intro; apply piProp; intro; apply piProp; intro; apply piProp; intro; apply G.hset end 192 | 193 | hott def regular.eqv {A : Type u} (H : Structures.hset A) 194 | (φ : G ⮎ A) : regular φ ≃ transitive φ × free φ := 195 | begin 196 | apply propEquivLemma; apply regularIsProp; 197 | apply productProp; apply transitiveIsProp; apply freeIsProp; 198 | apply regular.elim; intro w; apply regular.mk H φ w.1 w.2 199 | end 200 | end Group 201 | 202 | end GroundZero.Algebra 203 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Alternating.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Factor 2 | 3 | open GroundZero.Types.Equiv (biinv transport) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | open GroundZero.Types 7 | open GroundZero.Proto 8 | open GroundZero.HITs 9 | open GroundZero 10 | 11 | /- 12 | Trivial group, symmetric group, cyclic group Z₂, 13 | dihedral group D₃, alternating group A₃ as its subgroup. 14 | * https://en.wikipedia.org/wiki/Trivial_group 15 | * https://en.wikipedia.org/wiki/Symmetric_group 16 | * https://en.wikipedia.org/wiki/Cyclic_group 17 | * https://en.wikipedia.org/wiki/Dihedral_group_of_order_6 18 | * https://en.wikipedia.org/wiki/Alternating_group 19 | 20 | Z₂ ≅ D₃\A₃ proof. 21 | -/ 22 | 23 | universe u 24 | 25 | namespace GroundZero.Algebra 26 | 27 | namespace Group 28 | inductive D₃.carrier 29 | | R₀ | R₁ | R₂ 30 | | S₀ | S₁ | S₂ 31 | attribute [induction_eliminator] D₃.carrier.casesOn 32 | 33 | open D₃.carrier 34 | 35 | hott definition D₃.inv : D₃.carrier → D₃.carrier 36 | | R₀ => R₀ | R₁ => R₂ | R₂ => R₁ 37 | | S₀ => S₀ | S₁ => S₁ | S₂ => S₂ 38 | 39 | hott definition D₃.mul : D₃.carrier → D₃.carrier → D₃.carrier 40 | | R₀, R₀ => R₀ | R₀, R₁ => R₁ | R₀, R₂ => R₂ 41 | | R₀, S₀ => S₀ | R₀, S₁ => S₁ | R₀, S₂ => S₂ 42 | | R₁, R₀ => R₁ | R₁, R₁ => R₂ | R₁, R₂ => R₀ 43 | | R₁, S₀ => S₁ | R₁, S₁ => S₂ | R₁, S₂ => S₀ 44 | | R₂, R₀ => R₂ | R₂, R₁ => R₀ | R₂, R₂ => R₁ 45 | | R₂, S₀ => S₂ | R₂, S₁ => S₀ | R₂, S₂ => S₁ 46 | | S₀, R₀ => S₀ | S₀, R₁ => S₂ | S₀, R₂ => S₁ 47 | | S₀, S₀ => R₀ | S₀, S₁ => R₂ | S₀, S₂ => R₁ 48 | | S₁, R₀ => S₁ | S₁, R₁ => S₀ | S₁, R₂ => S₂ 49 | | S₁, S₀ => R₁ | S₁, S₁ => R₀ | S₁, S₂ => R₂ 50 | | S₂, R₀ => S₂ | S₂, R₁ => S₁ | S₂, R₂ => S₀ 51 | | S₂, S₀ => R₂ | S₂, S₁ => R₁ | S₂, S₂ => R₀ 52 | 53 | noncomputable instance D₃.hasOne : OfNat D₃.carrier (Nat.succ Nat.zero) := ⟨R₀⟩ 54 | noncomputable instance D₃.hasMul : Mul D₃.carrier := ⟨D₃.mul⟩ 55 | 56 | hott definition D₃.elim {β : Type u} (b₁ b₂ b₃ b₄ b₅ b₆ : β) (d : D₃.carrier) : β := 57 | @D₃.carrier.casesOn (λ _, β) d b₁ b₂ b₃ b₄ b₅ b₆ 58 | 59 | hott definition D₃ : Group := 60 | begin 61 | fapply Group.intro; exact D₃.carrier; apply Hedberg; 62 | intros x y; induction x <;> induction y <;> 63 | (first | apply Sum.inl; reflexivity | 64 | apply Sum.inr; intro H; apply ffNeqTt; symmetry; first 65 | | apply ap (D₃.elim true false false false false false) H 66 | | apply ap (D₃.elim false true false false false false) H 67 | | apply ap (D₃.elim false false true false false false) H 68 | | apply ap (D₃.elim false false false true false false) H 69 | | apply ap (D₃.elim false false false false false true) H 70 | | apply ap (D₃.elim false false false false true false) H); 71 | exact D₃.mul; exact D₃.inv; exact R₀; 72 | { intro a b c; induction a <;> induction b <;> induction c <;> reflexivity }; 73 | repeat { intro a; induction a <;> reflexivity } 74 | end 75 | 76 | hott definition A₃.set : D₃.subset := 77 | ⟨D₃.elim 𝟏 𝟏 𝟏 𝟎 𝟎 𝟎, begin 78 | intro (x : D₃.carrier); induction x <;> 79 | first | apply Structures.unitIsProp 80 | | apply Structures.emptyIsProp 81 | end⟩ 82 | 83 | hott definition A₃ : D₃.normal := 84 | ⟨begin 85 | fapply Group.subgroup.mk; exact A₃.set; apply ★; 86 | { intro (a : D₃.carrier) (b : D₃.carrier) p q; 87 | induction a <;> induction b <;> 88 | (first | induction p using Unit.casesOn 89 | | induction p using Proto.Empty.casesOn) <;> 90 | (first | induction q using Unit.casesOn 91 | | induction q using Proto.Empty.casesOn) <;> apply ★ }; 92 | { intro (a : D₃.carrier) p <;> induction a <;> 93 | (first | induction p using Unit.casesOn 94 | | induction p using Proto.Empty.casesOn) <;> apply ★ } 95 | end, 96 | begin 97 | intro (g : D₃.carrier) (h : D₃.carrier) p; 98 | induction g <;> induction h <;> 99 | (first | induction p using Unit.casesOn 100 | | induction p using Proto.Empty.casesOn) <;> apply ★ 101 | end⟩ 102 | 103 | hott definition D₃.inj : D₃.carrier → factorLeft D₃ A₃ := @Factor.incl D₃ A₃ 104 | 105 | hott definition Z₂.encode : Z₂.carrier → factorLeft D₃ A₃ 106 | | false => D₃.inj R₀ 107 | | true => D₃.inj S₀ 108 | 109 | hott definition Z₂.decode : factorLeft D₃ A₃ → Z₂.carrier := 110 | begin 111 | fapply Relquot.rec; 112 | exact D₃.elim false false false true true true; 113 | intros x y H <;> induction x using D₃.carrier.casesOn <;> induction y using D₃.carrier.casesOn <;> 114 | (first | induction H using Proto.Empty.casesOn | induction H using Unit.casesOn; reflexivity); 115 | apply Z₂.set 116 | end 117 | 118 | hott definition Z₂.iso : Z₂ ≅ D₃\A₃ := 119 | begin 120 | fapply mkiso; exact Z₂.encode; 121 | { intros x y; induction x <;> induction y <;> reflexivity }; 122 | apply Prod.mk <;> existsi Z₂.decode; 123 | { intro x; induction x <;> reflexivity }; 124 | { fapply Relquot.ind; 125 | { intro x; induction x <;> apply Relquot.sound <;> exact ★ }; 126 | { intros x y H; apply Relquot.set }; 127 | { intro; apply Structures.propIsSet; 128 | apply Relquot.set } } 129 | end 130 | end Group 131 | 132 | end GroundZero.Algebra 133 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Automorphism.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | open GroundZero.Types 3 | 4 | namespace GroundZero.Algebra 5 | 6 | namespace Group 7 | hott definition Aut.carrier (G : Group) := G ≅ G 8 | 9 | hott definition Aut (G : Group) : Group := 10 | @Group.intro (G ≅ G) Iso.hset (λ φ ψ, Iso.trans ψ φ) Iso.symm (Iso.refl G.1) 11 | (λ ⟨f, ⟨f', e₁⟩⟩ ⟨g, ⟨g', e₂⟩⟩ ⟨h, ⟨h', e₂⟩⟩, Iso.ext (λ _, idp _)) 12 | (λ ⟨f, ⟨f', e₁⟩⟩, Iso.ext (λ _, idp _)) 13 | (λ ⟨f, ⟨(η₁, η₂), (⟨g, μ₁⟩, μ₂)⟩⟩, Iso.ext (λ _, μ₁ _)) 14 | end Group 15 | 16 | end GroundZero.Algebra 17 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Differential.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Subgroup 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Structures 5 | open GroundZero.Types 6 | open GroundZero.Proto 7 | open GroundZero 8 | 9 | /- 10 | Differential group. 11 | * https://encyclopediaofmath.org/wiki/Differential_group 12 | -/ 13 | 14 | namespace GroundZero.Algebra 15 | universe u v u' v' w 16 | 17 | namespace Group 18 | variable {G : Group} 19 | 20 | hott definition imImplKer {φ : Hom G G} (H : φ ⋅ φ = 0) : (im φ).set ⊆ (ker φ).set := 21 | begin 22 | intro x; fapply HITs.Merely.rec; apply G.hset; 23 | intro ⟨y, p⟩; change _ = _; transitivity; apply ap _ (Id.inv p); 24 | apply @idhom _ _ _ _ _ (φ ⋅ φ) 0; apply H 25 | end 26 | 27 | hott lemma boundaryOfBoundary {φ : Hom G G} 28 | (p : (im φ).set ⊆ (ker φ).set) : φ ⋅ φ = 0 := 29 | begin 30 | fapply Hom.funext; intro x; apply p; 31 | apply HITs.Merely.elem; existsi x; reflexivity 32 | end 33 | 34 | hott lemma boundaryEqv (φ : Hom G G) : 35 | (φ ⋅ φ = 0) ≃ ((im φ).set ⊆ (ker φ).set) := 36 | begin 37 | apply Structures.propEquivLemma; 38 | apply Homo.set; apply Ens.ssubset.prop; 39 | exact imImplKer; exact boundaryOfBoundary 40 | end 41 | end Group 42 | 43 | hott definition Diff := Σ (G : Abelian) (δ : Abelian.Hom G G), δ ⋅ δ = 0 44 | 45 | -- Accessors 46 | hott definition Diff.abelian (G : Diff) := G.1 47 | hott definition Diff.group (G : Diff) := G.abelian.group 48 | 49 | hott definition Diff.δ (G : Diff) : Group.Hom G.group G.group := G.2.1 50 | hott definition Diff.sqr (G : Diff) : G.δ ⋅ G.δ = 0 := G.2.2 51 | 52 | namespace Diff 53 | open GroundZero.Algebra.Group (im ker) 54 | variable (G : Diff) 55 | 56 | hott lemma univ : (Group.im G.δ).set ⊆ (ker G.δ).set := 57 | Group.imImplKer G.sqr 58 | end Diff 59 | 60 | end GroundZero.Algebra 61 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Free.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | 3 | open GroundZero.Types.Equiv (biinv transport) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | open GroundZero.Types 7 | open GroundZero.Proto 8 | open GroundZero 9 | 10 | /- 11 | Free group. 12 | * https://en.wikipedia.org/wiki/Free_group 13 | -/ 14 | 15 | namespace GroundZero.Algebra 16 | universe u v w 17 | 18 | namespace Group 19 | inductive Exp (α : Type u) 20 | | unit : Exp α 21 | | elem : α → Exp α 22 | | mul : Exp α → Exp α → Exp α 23 | | inv : Exp α → Exp α 24 | 25 | namespace Exp 26 | variable {α : Type u} (G : Group) (f : α → G.carrier) 27 | 28 | hott definition eval : Exp α → G.carrier 29 | | unit => G.e 30 | | elem x => f x 31 | | mul x y => G.φ (eval x) (eval y) 32 | | inv x => G.ι (eval x) 33 | end Exp 34 | 35 | private def F.aux (α : Type u) := Opaque (Exp α) 36 | 37 | attribute [nothott] F.aux 38 | 39 | def F.carrier (α : Type u) := F.aux α 40 | 41 | namespace F 42 | variable {ε : Type u} 43 | 44 | def unit : F.carrier ε := Opaque.intro Exp.unit 45 | def elem : ε → F.carrier ε := Opaque.intro ∘ Exp.elem 46 | 47 | def mul (x y : F.carrier ε) : F.carrier ε := 48 | Opaque.intro (Exp.mul x.value y.value) 49 | 50 | def inv (x : F.carrier ε) : F.carrier ε := 51 | Opaque.intro (Exp.inv x.value) 52 | 53 | instance : Mul (F.carrier ε) := ⟨mul⟩ 54 | instance : OfNat (F.carrier ε) (Nat.succ Nat.zero) := ⟨unit⟩ 55 | 56 | axiom mulAssoc (a b c : F.carrier ε) : mul (mul a b) c = mul a (mul b c) 57 | axiom oneMul (a : F.carrier ε) : mul unit a = a 58 | axiom mulLeftInv (a : F.carrier ε) : mul (inv a) a = unit 59 | axiom ens : Structures.hset (F.carrier ε) 60 | 61 | noncomputable def rec (G : Group) (f : ε → G.carrier) (x : F.carrier ε) : G.carrier := 62 | Exp.eval G f x.value 63 | 64 | @[induction_eliminator] def ind {π : F.carrier ε → Type v} 65 | (setπ : Π x, Structures.hset (π x)) 66 | (u : π unit) (η : Π x, π (elem x)) 67 | (m : Π {x y}, π x → π y → π (mul x y)) 68 | (i : Π {x}, π x → π (inv x)) 69 | (mulAssoc : Π {x y z : F.carrier ε} (a : π x) (b : π y) (c : π z), 70 | m (m a b) c =[mulAssoc x y z] m a (m b c)) 71 | (oneMul : Π {x : F.carrier ε} (a : π x), m u a =[oneMul x] a) 72 | (mulLeftInv : Π {x : F.carrier ε} (a : π x), 73 | m (i a) a =[mulLeftInv x] u) : Π x, π x := 74 | let rec ev : Π x, π (Opaque.intro x) 75 | | Exp.unit => u 76 | | Exp.elem x => η x 77 | | Exp.inv x => i (ev x) 78 | | Exp.mul x y => m (ev x) (ev y); 79 | λ x, Quot.withUseOf (setπ, @mulAssoc, @oneMul, @mulLeftInv) (Opaque.ind ev x) x 80 | end F 81 | 82 | attribute [hottAxiom] F.carrier F.unit F.elem F.mul F.inv F.rec F.ind 83 | 84 | noncomputable def F (ε : Type u) : Group := 85 | @Group.intro (F.carrier ε) F.ens F.mul F.inv F.unit F.mulAssoc F.oneMul F.mulLeftInv 86 | 87 | attribute [irreducible] F.carrier 88 | 89 | namespace F 90 | variable {G : Group} {ε : Type u} 91 | 92 | local infixl:70 (priority := high) " * " => G.φ 93 | local postfix:max (priority := high) "⁻¹" => G.ι 94 | local notation "e" => G.e 95 | 96 | hott remark recMul (f : ε → G.carrier) (x y : F.carrier ε) : rec G f (mul x y) = rec G f x * rec G f y := 97 | by reflexivity 98 | 99 | hott remark recInv (f : ε → G.carrier) (x : F.carrier ε) : rec G f (inv x) = (rec G f x)⁻¹ := 100 | by reflexivity 101 | 102 | hott remark recOne (f : ε → G.carrier) : rec G f unit = e := 103 | by reflexivity 104 | 105 | hott definition homomorphism (f : ε → G.carrier) : Hom (F ε) G := 106 | mkhomo (rec G f) (recMul f) 107 | 108 | hott remark recβrule₁ {a b c : F.carrier ε} (f : ε → G.carrier) : 109 | ap (rec G f) (mulAssoc a b c) = 110 | G.mulAssoc (rec G f a) (rec G f b) (rec G f c) := 111 | by apply G.hset 112 | 113 | hott remark recβrule₂ {a : F.carrier ε} (f : ε → G.carrier) : 114 | ap (rec G f) (oneMul a) = G.oneMul (rec G f a) := 115 | by apply G.hset 116 | 117 | hott remark recβrule₄ {a : F.carrier ε} (f : ε → G.carrier) : 118 | ap (rec G f) (mulLeftInv a) = G.mulLeftInv (rec G f a) := 119 | by apply G.hset 120 | 121 | hott definition indΩ {π : F.carrier ε → Type v} 122 | (propπ : Π x, prop (π x)) 123 | (u : π unit) (η : Π {x}, π (elem x)) 124 | (m : Π {x y}, π x → π y → π (mul x y)) 125 | (i : Π {x}, π x → π (inv x)) : Π x, π x := 126 | begin 127 | fapply ind; 128 | { intro; apply propIsSet; apply propπ }; 129 | { exact u }; 130 | { intro x; apply η }; 131 | { intros x y u v; apply m u v }; 132 | { intros x u; apply i u }; 133 | repeat { intros; apply propπ } 134 | end 135 | end F 136 | end Group 137 | 138 | end GroundZero.Algebra 139 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Homotopy.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | import GroundZero.HITs.Trunc 3 | 4 | open GroundZero.Types.Id (idΩ ap) 5 | open GroundZero.Types.Equiv 6 | open GroundZero.Structures 7 | open GroundZero.Types 8 | open GroundZero.HITs 9 | 10 | universe u 11 | 12 | namespace GroundZero.Algebra 13 | 14 | namespace Homotopy 15 | variable {A : Type u} {x : A} {n : ℕ} 16 | 17 | hott definition mul : ∥Ωⁿ⁺¹(A, x)∥₀ → ∥Ωⁿ⁺¹(A, x)∥₀ → ∥Ωⁿ⁺¹(A, x)∥₀ := 18 | Trunc.ap₂ comΩ 19 | 20 | hott definition inv : ∥Ωⁿ⁺¹(A, x)∥₀ → ∥Ωⁿ⁺¹(A, x)∥₀ := 21 | Trunc.ap revΩ 22 | 23 | hott definition unit : ∥Ωⁿ(A, x)∥₀ := 24 | |idΩ x n|₀ 25 | 26 | hott lemma isAssoc (a b c : ∥Ωⁿ⁺¹(A, x)∥₀) : mul (mul a b) c = mul a (mul b c) := 27 | begin 28 | induction a; induction b; induction c; transitivity; 29 | apply Trunc.apβrule₂; apply ap Trunc.elem; symmetry; apply assocΩ; 30 | -- TODO: write some tactic to solve this automatically? 31 | apply hlevel.cumulative; apply Trunc.uniq 0; 32 | apply hlevel.cumulative; apply Trunc.uniq 0; 33 | apply hlevel.cumulative; apply Trunc.uniq 0 34 | end 35 | 36 | hott lemma hasLeftUnit (a : ∥Ωⁿ⁺¹(A, x)∥₀) : mul unit a = a := 37 | begin 38 | induction a; transitivity; apply Trunc.apβrule₂; apply ap Trunc.elem; 39 | apply lidΩ; apply hlevel.cumulative; apply Trunc.uniq 0 40 | end 41 | 42 | hott lemma hasLeftInverse (a : ∥Ωⁿ⁺¹(A, x)∥₀) : mul (inv a) a = unit := 43 | begin 44 | induction a; transitivity; apply Trunc.apβrule₂; apply ap Trunc.elem; 45 | apply revlΩ; apply hlevel.cumulative; apply Trunc.uniq 0 46 | end 47 | 48 | hott lemma isAbelian (a b : ∥Ωⁿ⁺²(A, x)∥₀) : mul a b = mul b a := 49 | begin 50 | induction a; induction b; transitivity; apply Trunc.apβrule₂; 51 | apply ap Trunc.elem; apply abelianComΩ; 52 | apply hlevel.cumulative; apply Trunc.uniq 0; 53 | apply hlevel.cumulative; apply Trunc.uniq 0 54 | end 55 | end Homotopy 56 | 57 | hott definition Homotopy {A : Type u} (a : A) (n : ℕ) : Group := 58 | @Group.intro ∥Ωⁿ⁺¹(A, a)∥₀ (zeroEqvSet.forward (Trunc.uniq 0)) 59 | Homotopy.mul Homotopy.inv Homotopy.unit Homotopy.isAssoc 60 | Homotopy.hasLeftUnit Homotopy.hasLeftInverse 61 | 62 | end GroundZero.Algebra 63 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Isomorphism.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Symmetric 2 | import GroundZero.Algebra.Group.Factor 3 | 4 | open GroundZero.Types.Equiv (biinv transport) 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Structures 7 | open GroundZero.Types 8 | open GroundZero.Proto 9 | open GroundZero.HITs 10 | open GroundZero 11 | 12 | /- 13 | First isomorphism theorem: Im φ ≅ G\ker φ. 14 | * https://en.wikipedia.org/wiki/Fundamental_theorem_on_homomorphisms 15 | * https://en.wikipedia.org/wiki/First_isomorphism_theorem#Theorem_A 16 | 17 | Cayley’s theorem. 18 | * https://en.wikipedia.org/wiki/Cayley's_theorem 19 | -/ 20 | 21 | namespace GroundZero.Algebra 22 | 23 | namespace Group 24 | variable {G : Group} 25 | 26 | section 27 | variable {H : Group} 28 | 29 | hott def ker.encode {φ : Hom G H} : factorLeft G (ker φ) → im.carrier φ := 30 | begin 31 | fapply Relquot.rec; 32 | { intro x; existsi φ.fst x; 33 | apply HITs.Merely.elem; existsi x; reflexivity }; 34 | { intro x y (p : _ = _); fapply Sigma.prod; transitivity; 35 | symmetry; apply invInv; apply invEqOfMulEqOne; transitivity; 36 | { apply ap (H.φ · (φ.1 y)); symmetry; apply homoInv }; 37 | transitivity; { symmetry; apply homoMul }; apply p; 38 | apply HITs.Merely.uniq }; 39 | { apply Ens.hset; apply H.hset } 40 | end 41 | 42 | hott def ker.encodeInj {φ : Hom G H} : 43 | Π (x y : factorLeft G (ker φ)), ker.encode x = ker.encode y → x = y := 44 | begin 45 | fapply @Relquot.indProp _ _ (λ x, Π y, ker.encode x = ker.encode y → x = y) <;> intro x; 46 | { fapply @Relquot.indProp _ _ (λ y, ker.encode _ = ker.encode y → _ = y) <;> intro y; 47 | { intro p; apply Relquot.sound; 48 | change _ = _; transitivity; apply homoMul; 49 | transitivity; apply ap (H.φ · (φ.1 y)); 50 | apply homoInv; apply mulEqOneOfInvEq; 51 | transitivity; apply invInv; 52 | apply (Sigma.sigmaEqOfEq p).1 }; 53 | { apply implProp; apply Relquot.set } }; 54 | { apply piProp; intro; apply implProp; apply Relquot.set } 55 | end 56 | 57 | hott def ker.incl {φ : Hom G H} : G.carrier → factorLeft G (ker φ) := 58 | Factor.incl 59 | 60 | hott def ker.decodeSigma {φ : Hom G H} : 61 | Π (x : im.carrier φ), fib ker.encode x := 62 | begin 63 | apply Sigma.Ind; intro x; fapply Merely.ind; 64 | { intro z; existsi ker.incl z.1; fapply Types.Sigma.prod; 65 | apply z.2; apply HITs.Merely.uniq }; 66 | { intro w p q; fapply Types.Sigma.prod; 67 | { apply ker.encodeInj; transitivity; 68 | exact p.2; symmetry; exact q.2 }; 69 | { apply Ens.hset; apply H.hset } } 70 | end 71 | 72 | hott def ker.decode {φ : Hom G H} 73 | (x : im.carrier φ) : factorLeft G (ker φ) := 74 | (ker.decodeSigma x).1 75 | 76 | hott abbrev Im (φ : Hom G H) : Group := 77 | Subgroup H (im φ) 78 | 79 | -- First isomorphism theorem. 80 | hott def firstIsoTheorem {φ : Hom G H} : Im φ ≅ G\ker φ := 81 | begin 82 | fapply mkiso; exact ker.decode; 83 | { intro ⟨a, (A : ∥_∥)⟩ ⟨b, (B : ∥_∥)⟩; induction A; induction B; 84 | reflexivity; apply Relquot.set; apply Relquot.set }; 85 | apply Prod.mk <;> existsi ker.encode; 86 | { intro x; apply (ker.decodeSigma x).2 }; 87 | { fapply Relquot.indProp; intro; 88 | reflexivity; intro; apply Relquot.set } 89 | end 90 | end 91 | 92 | hott def S.iso : Im (S.univ G) ≅ G := 93 | begin 94 | fapply Iso.trans firstIsoTheorem; 95 | apply Iso.symm; fapply Iso.trans triv.factor; 96 | apply Factor.iso S.univ.ker.decode S.univ.ker.encode 97 | end 98 | 99 | hott def Hom.id.encode : G.carrier → im.carrier (Hom.id G.1) := 100 | λ x, ⟨x, HITs.Merely.elem ⟨x, idp x⟩⟩ 101 | 102 | hott def Hom.id.decode : im.carrier (Hom.id G.1) → G.carrier := 103 | Sigma.fst 104 | 105 | hott def Hom.id.iso : G ≅ Im (Hom.id G.1) := 106 | begin 107 | fapply mkiso; exact Hom.id.encode; 108 | { intros a b; fapply Sigma.prod; 109 | reflexivity; apply Ens.prop }; 110 | apply Prod.mk <;> existsi Hom.id.decode; 111 | { intro; reflexivity }; 112 | { intro; fapply Sigma.prod; 113 | reflexivity; apply Ens.prop } 114 | end 115 | 116 | -- Cayley’s theorem 117 | hott def Cayley : Σ (φ : subgroup (S G.1.zero)), Subgroup (S G.1.zero) φ ≅ G := 118 | ⟨im (S.univ G), S.iso⟩ 119 | end Group 120 | 121 | end GroundZero.Algebra 122 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Lemmas.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Subgroup 2 | import GroundZero.Theorems.Nat 3 | 4 | open GroundZero.Types.Equiv (transport) 5 | open GroundZero.Theorems 6 | open GroundZero.Types 7 | open GroundZero 8 | 9 | namespace GroundZero.Algebra 10 | 11 | namespace Group 12 | variable {G : Group} 13 | 14 | hott def union (φ : ℕ → G.subgroup) (p : Π i, (φ i).set ⊆ (φ (i + 1)).set) : G.subgroup := 15 | begin 16 | fapply Group.subgroup.mk; exact ⋃(λ n, (φ n).set); 17 | { apply HITs.Merely.elem; existsi 0; apply (φ 0).unit }; 18 | { intros a b; apply HITs.Merely.lift₂; intro ⟨n, r⟩ ⟨m, s⟩; 19 | let ε := @Nat.le.elim (λ n m, (φ n).set ⊆ (φ m).set) 20 | (λ n m k, Ens.ssubset.trans) 21 | (λ n, Ens.ssubset.refl (φ n).set) p; 22 | existsi Theorems.Nat.max n m; apply (φ _).mul; 23 | apply ε; apply Nat.le.max; assumption; 24 | apply ε; apply Nat.le.maxRev; assumption }; 25 | { intro a; apply HITs.Merely.lift; intro ⟨n, r⟩; 26 | existsi n; apply (φ n).inv; assumption } 27 | end 28 | 29 | hott def distinctNormalSubgroups {φ ψ : G.subgroup} 30 | (H : Π x, x ∈ φ.set → x ∈ ψ.set → x = G.e) (μ : G ⊵ φ) (η : G ⊵ ψ) : 31 | Π g h, g ∈ φ.set → h ∈ ψ.set → G.φ g h = G.φ h g := 32 | begin 33 | intros g h p q; apply commutes; apply H; 34 | { apply transport (· ∈ φ.set); symmetry; 35 | apply G.mulAssoc; apply φ.mul; exact p; 36 | apply transport (· ∈ φ.set); apply G.mulAssoc; 37 | apply conjugateEqv μ; apply isNormalSubgroup.conj μ; 38 | apply φ.inv; exact p }; 39 | { apply transport (· ∈ ψ.set); apply G.mulAssoc; 40 | apply ψ.mul; apply conjugateEqv η; 41 | apply isNormalSubgroup.conj η; 42 | exact q; apply ψ.inv; exact q } 43 | end 44 | end Group 45 | 46 | end GroundZero.Algebra -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Periodic.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | 3 | open GroundZero.Structures 4 | open GroundZero.Types 5 | open GroundZero 6 | 7 | namespace GroundZero.Algebra 8 | universe u v u' v' w 9 | 10 | namespace Group 11 | variable {G : Group} 12 | 13 | hott definition P.carrier (G : Group) := ℕ → G.carrier 14 | 15 | hott lemma P.hset (G : Group) : Structures.hset (P.carrier G) := 16 | begin apply piHset; intro; apply G.hset end 17 | 18 | section 19 | variable {H : Group} 20 | 21 | hott definition P.mul : P.carrier H → P.carrier H → P.carrier H := 22 | λ f g n, H.φ (f n) (g n) 23 | 24 | hott definition P.one : P.carrier H := λ _, H.e 25 | hott definition P.inv : P.carrier H → P.carrier H := λ f n, H.ι (f n) 26 | end 27 | 28 | hott definition P (G : Group) : Group := 29 | @Group.intro (P.carrier G) (P.hset G) P.mul P.inv P.one 30 | (λ _ _ _, Theorems.funext (λ _, G.mulAssoc _ _ _)) 31 | (λ _, Theorems.funext (λ _, G.oneMul _)) 32 | (λ _, Theorems.funext (λ _, G.mulLeftInv _)) 33 | 34 | noncomputable instance P.abelian (G : Group) (ρ : G.isCommutative) : (P G).isCommutative := 35 | begin intros f g; fapply Theorems.funext; intro; apply ρ end 36 | 37 | hott definition P.unitSqr (H : Π x, G.φ x x = G.e) (x : P.carrier G) : P.mul x x = P.one := 38 | begin fapply Theorems.funext; intro; apply H end 39 | 40 | hott definition P₂ := P Z₂ 41 | 42 | hott theorem P₂.periodic : Π (x : P₂.carrier), P.mul x x = P.one := 43 | P.unitSqr (λ | false => Id.refl | true => Id.refl) 44 | end Group 45 | 46 | end GroundZero.Algebra 47 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Presentation.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Isomorphism 2 | import GroundZero.Algebra.Group.Free 3 | 4 | open GroundZero.Types.Equiv (biinv transport) 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Structures 7 | open GroundZero.Types 8 | open GroundZero.Proto 9 | open GroundZero.HITs 10 | open GroundZero 11 | 12 | /- 13 | Group presentation, presentation of every group. 14 | * https://en.wikipedia.org/wiki/presentation_of_a_group#Definition 15 | 16 | Abelianization (as factor group). 17 | * https://groupprops.subwiki.org/wiki/abelianization 18 | * https://ncatlab.org/nlab/show/abelianization 19 | 20 | Free abelian group. 21 | * https://en.wikipedia.org/wiki/Free_abelian_group 22 | -/ 23 | 24 | namespace GroundZero.Algebra 25 | 26 | namespace Group 27 | variable {G : Group} 28 | 29 | universe u v 30 | 31 | hott definition Closure.set (G : Group.{u}) (x : Group.subset.{u, v} G) : G.subset := 32 | Ens.smallest.{u, v, max u v} (λ φ, G.isSubgroup φ × G.isNormal φ × x ⊆ φ) 33 | 34 | hott definition Closure.sub (φ : G.subset) : φ ⊆ Closure.set G φ := 35 | begin intros x G y H; apply H.2.2; assumption end 36 | 37 | hott lemma Closure.subTrans {φ : G.subset} {ψ : G.normal} : φ ⊆ ψ.set → Closure.set G φ ⊆ ψ.set := 38 | begin 39 | intros H x G; apply G; apply Prod.mk; 40 | exact ψ.1.2; apply Prod.mk; exact ψ.2; exact H 41 | end 42 | 43 | hott lemma Closure.elim (φ : G.normal) : 44 | Closure.set G φ.set ⊆ φ.set := 45 | Closure.subTrans (Ens.ssubset.refl φ.set) 46 | 47 | hott definition Closure (x : G.subset) : G.normal := 48 | ⟨begin 49 | fapply Group.subgroup.mk; exact Closure.set G x; 50 | { intro y ⟨G, H⟩; apply G.1 }; 51 | { intro a b G H y F; apply F.1.2.1; 52 | apply G y; assumption; apply H y; assumption }; 53 | { intro a H y G; apply G.1.2.2; apply H y; assumption } 54 | end, 55 | begin intros g h G y H; apply H.2.1; apply G y; assumption end⟩ 56 | 57 | section 58 | variable {ε : Type u} (R : (F ε).subset) 59 | hott definition Presentation := 60 | (F ε)\(Closure R) 61 | 62 | hott definition Presentation.carrier := 63 | factorLeft (F ε) (Closure R) 64 | 65 | hott definition Presentation.one : Presentation.carrier R := 66 | (Presentation R).e 67 | end 68 | 69 | hott lemma Presentation.sound {A : Type u} 70 | {R : (F A).subset} {x : F.carrier A} (H : x ∈ R) : 71 | @Factor.incl (F A) _ x = Presentation.one R := 72 | begin apply Factor.sound; apply Closure.sub; assumption end 73 | 74 | hott definition commutators (G : Group) : G.subset := 75 | GroundZero.Algebra.im (λ (a, b), commutator a b) 76 | 77 | hott definition Abelianization (G : Group) := 78 | G\Closure (commutators G) 79 | postfix:max "ᵃᵇ" => Abelianization 80 | 81 | hott definition Abelianization.elem : G.carrier → (Abelianization G).carrier := 82 | Factor.incl 83 | 84 | hott theorem abelComm : (Abelianization G).isCommutative := 85 | begin 86 | intro (a : Relquot _) (b : Relquot _); 87 | apply @commutes (Abelianization G); induction a; 88 | { case elemπ a => 89 | induction b; 90 | { case elemπ b => 91 | apply Factor.sound; intros y H; apply H.2.2; apply Merely.elem; 92 | existsi (a, b); reflexivity }; 93 | apply Relquot.set; apply propIsSet; apply Relquot.set }; 94 | apply Relquot.set; apply propIsSet; apply Relquot.set 95 | end 96 | 97 | section 98 | variable {H : Group} (ρ : H.isCommutative) 99 | 100 | hott theorem commutators.toKer (f : Hom G H) : commutators G ⊆ (ker f).set := 101 | begin 102 | intro x; fapply HITs.Merely.rec; apply Ens.prop; 103 | intro ⟨(a, b), q⟩; change _ = _; apply calc 104 | f.1 x = f.1 (G.φ (G.φ a b) (G.φ (G.ι a) (G.ι b))) : ap f.1 (Id.inv q) 105 | ... = H.φ (f.1 (G.φ a b)) (f.1 (G.φ (G.ι a) (G.ι b))) : homoMul f _ _ 106 | ... = H.φ (f.1 (G.φ a b)) (H.φ (f.1 (G.ι a)) (f.1 (G.ι b))) : ap _ (homoMul f _ _) 107 | ... = H.φ (f.1 (G.φ a b)) (H.φ (f.1 (G.ι b)) (f.1 (G.ι a))) : ap _ (ρ _ _) 108 | ... = H.φ (f.1 (G.φ a b)) (f.1 (G.φ (G.ι b) (G.ι a))) : ap _ (homoMul f _ _)⁻¹ 109 | ... = f.1 (G.φ (G.φ a b) (G.φ (G.ι b) (G.ι a))) : Id.inv (homoMul f _ _) 110 | ... = f.1 (G.φ (G.φ (G.φ a b) (G.ι b)) (G.ι a)) : ap f.1 (Id.inv (G.mulAssoc _ _ _)) 111 | ... = f.1 (G.φ (G.φ a (G.φ b (G.ι b))) (G.ι a)) : @ap G.carrier H.carrier _ _ (λ x, f.1 (G.φ x (G.ι a))) (G.mulAssoc a b (G.ι b)) 112 | ... = f.1 (G.φ (G.φ a G.e) (G.ι a)) : @ap G.carrier H.carrier _ _ (λ x, f.1 (G.φ (G.φ a x) (G.ι a))) (mulRightInv b) 113 | ... = f.1 (G.φ a (G.ι a)) : @ap G.carrier H.carrier _ _ (λ x, f.1 (G.φ x (G.ι a))) (G.mulOne a) 114 | ... = f.1 G.e : ap f.1 (mulRightInv a) 115 | ... = H.e : homoUnit f 116 | end 117 | end 118 | 119 | hott definition commutators.toClosureKer {H : Group} (ρ : H.isCommutative) (f : Hom G H) : 120 | Ens.ssubset (Closure.set G (commutators G)) (ker f).set := 121 | Closure.subTrans (commutators.toKer ρ f) 122 | 123 | hott definition Abelianization.rec {G A : Group} (ρ : A.isCommutative) 124 | (f : Hom G A) : Gᵃᵇ.carrier → A.carrier := 125 | begin 126 | fapply Factor.lift; exact f; intros x H; 127 | apply commutators.toClosureKer ρ; assumption 128 | end 129 | 130 | hott definition Abelianization.homomorphism {G A : Group} (ρ : A.isCommutative) (f : Hom G A) : Hom Gᵃᵇ A := 131 | mkhomo (Abelianization.rec ρ f) (begin 132 | intro (a : Relquot _) (b : Relquot _); 133 | induction a; induction b; apply homoMul; 134 | apply A.hset; apply propIsSet; apply A.hset; 135 | apply A.hset; apply propIsSet; apply A.hset 136 | end) 137 | 138 | hott definition FAb (A : Type u) := Abelianization (F A) 139 | 140 | hott definition FAb.elem {A : Type u} : A → (FAb A).carrier := 141 | Abelianization.elem ∘ F.elem 142 | 143 | hott definition FAb.rec {A : Group} (ρ : A.isCommutative) 144 | {ε : Type v} (f : ε → A.carrier) : (FAb ε).carrier → A.carrier := 145 | Abelianization.rec ρ (F.homomorphism f) 146 | 147 | hott definition FAb.homomorphism {A : Group} (ρ : A.isCommutative) 148 | {ε : Type v} (f : ε → A.carrier) : Hom (FAb ε) A := 149 | Abelianization.homomorphism ρ (F.homomorphism f) 150 | 151 | hott definition normalFactor (φ : G.normal) : G\φ ≅ G\Closure φ.set := 152 | Factor.iso (Closure.sub φ.set) (Closure.elim φ) 153 | 154 | hott definition F.homomorphism.encode : 155 | G.carrier → im.carrier (@F.homomorphism G G.carrier id) := 156 | λ x, ⟨x, HITs.Merely.elem ⟨F.elem x, idp _⟩⟩ 157 | 158 | hott theorem F.homomorphism.iso : 159 | G ≅ Im (@F.homomorphism G G.carrier id) := 160 | begin 161 | fapply mkiso; exact F.homomorphism.encode; 162 | { intros x y; fapply Sigma.prod; 163 | reflexivity; apply HITs.Merely.uniq }; 164 | { apply Prod.mk <;> existsi Sigma.fst; 165 | { intro; reflexivity }; 166 | { intro; fapply Sigma.prod; 167 | reflexivity; apply HITs.Merely.uniq } } 168 | end 169 | 170 | hott theorem Presentation.univ : 171 | Σ (R : (F G.carrier).subset), G ≅ Presentation R := 172 | begin 173 | existsi (ker (F.homomorphism id)).set; 174 | apply Iso.trans F.homomorphism.iso; 175 | apply Iso.trans firstIsoTheorem; 176 | apply normalFactor 177 | end 178 | end Group 179 | 180 | end GroundZero.Algebra 181 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Product.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Basic 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types 5 | 6 | namespace GroundZero.Algebra 7 | 8 | namespace Group 9 | hott definition Prod (G H : Group) : Group := 10 | @Group.intro (G.carrier × H.carrier) 11 | (GroundZero.Structures.prodHset G.hset H.hset) 12 | (λ w₁ w₂, (G.φ w₁.1 w₂.1, H.φ w₁.2 w₂.2)) 13 | (λ w, (G.ι w.1, H.ι w.2)) (G.e, H.e) 14 | (λ _ _ _, Product.prod (G.mulAssoc _ _ _) (H.mulAssoc _ _ _)) 15 | (λ _, Product.prod (G.oneMul _) (H.oneMul _)) 16 | (λ _, Product.prod (G.mulLeftInv _) (H.mulLeftInv _)) 17 | 18 | infixl:70 " × " => Prod 19 | 20 | hott definition Prod.abelian (G H : Group) 21 | (ρ₁ : G.isCommutative) (ρ₂ : H.isCommutative) : (G × H).isCommutative := 22 | λ _ _, Product.prod (ρ₁ _ _) (ρ₂ _ _) 23 | 24 | hott definition Homo.prod {G H F : Group} (ρ : F.isCommutative) 25 | (φ : Hom G F) (ψ : Hom H F) : Hom (G × H) F := 26 | begin 27 | fapply mkhomo; exact (λ w, F.φ (φ.1 w.1) (ψ.1 w.2)); intros x y; 28 | change F.φ (φ.1 _) (ψ.1 _) = F.φ (F.φ _ _) (F.φ _ _); 29 | transitivity; apply Equiv.bimap F.φ <;> apply homoMul; 30 | transitivity; apply F.mulAssoc; 31 | transitivity; apply ap (F.φ (φ.1 _)); 32 | transitivity; apply ρ; apply F.mulAssoc; 33 | transitivity; symmetry; apply F.mulAssoc; 34 | apply ap; apply ρ 35 | end 36 | end Group 37 | 38 | end GroundZero.Algebra 39 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Semidirect.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Automorphism 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Structures 5 | open GroundZero.Types 6 | open GroundZero 7 | 8 | namespace GroundZero.Algebra 9 | 10 | namespace Group 11 | -- Outer semidirect product 12 | hott definition Semidirect {N H : Group} (φ : Hom H (Aut N)) : Group := 13 | @Group.intro (N.carrier × H.carrier) (prodHset N.hset H.hset) 14 | (λ (n₁, h₁) (n₂, h₂), (N.φ n₁ ((φ.fst h₁).fst n₂), H.φ h₁ h₂)) 15 | (λ (n, h), ⟨(φ.1 (H.ι h)).1 (N.ι n), H.ι h⟩) (N.e, H.e) 16 | (λ (n₁, h₁) (n₂, h₂) (n₃, h₃), begin 17 | apply Product.prod; 18 | { transitivity; apply N.mulAssoc; 19 | apply ap (N.φ n₁); symmetry; 20 | transitivity; apply isoMul; 21 | apply ap; symmetry; 22 | transitivity; apply HITs.Interval.happly; 23 | apply ap; apply homoMul; reflexivity }; 24 | { apply H.mulAssoc } 25 | end) 26 | (λ (n, h), begin 27 | apply Product.prod; 28 | { transitivity; apply N.oneMul; 29 | transitivity; apply HITs.Interval.happly; 30 | apply ap; apply homoUnit; reflexivity }; 31 | { apply H.oneMul } 32 | end) 33 | (λ ⟨n, h⟩, begin 34 | apply Product.prod; 35 | { transitivity; symmetry; apply isoMul; 36 | transitivity; apply ap; 37 | apply N.mulLeftInv; apply isoUnit }; 38 | { apply H.mulLeftInv } 39 | end) 40 | 41 | notation N " ⋊" "[" φ "] " H => Semidirect (N := N) (H := H) φ 42 | notation H " ⋉" "[" φ "] " N => Semidirect (N := N) (H := H) φ 43 | end Group 44 | 45 | end GroundZero.Algebra 46 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Symmetric.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Subgroup 2 | 3 | open GroundZero.Types.Equiv (ideqv) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | open GroundZero.Theorems 7 | open GroundZero.Types 8 | open GroundZero.Proto 9 | open GroundZero 10 | 11 | /- 12 | Symmetric group. 13 | * https://en.wikipedia.org/wiki/Symmetric_group 14 | -/ 15 | 16 | namespace GroundZero.Algebra 17 | universe u 18 | 19 | namespace Group 20 | variable {G : Group} 21 | 22 | -- Permutations 23 | hott definition S.carrier (ε : 0-Type) := ε ≃₀ ε 24 | 25 | section 26 | variable {ε : 0-Type} 27 | 28 | hott definition S.mul (p q : S.carrier ε) := Equiv.trans q p 29 | hott definition S.one := Equiv.ideqv ε.1 30 | hott definition S.inv (p : S.carrier ε) := Equiv.symm p 31 | 32 | noncomputable instance S.hasMul : Mul (S.carrier ε) := ⟨S.mul⟩ 33 | noncomputable instance S.hasOne : OfNat (S.carrier ε) (Nat.succ Nat.zero) := ⟨S.one⟩ 34 | 35 | hott definition S (ε : nType.{u} 0) : Group.{u} := 36 | @Group.intro (ε ≃₀ ε) (Equiv.zeroEquiv.hset ε ε) S.mul S.inv S.one 37 | (λ _ _ _, Equiv.equivHmtpyLem _ _ (λ _, idp _)) 38 | (λ _, Equiv.equivHmtpyLem _ _ (λ _, idp _)) 39 | (λ e, Equiv.equivHmtpyLem _ _ (λ _, e.rightForward _)) 40 | 41 | hott definition left (G : Group) (x : G.carrier) : G.carrier ≃ G.carrier := 42 | begin 43 | existsi (G.φ x ·); apply Prod.mk <;> existsi (G.φ (G.ι x) ·) <;> intro y; 44 | { transitivity; { symmetry; apply G.mulAssoc }; 45 | transitivity; { apply ap (G.φ · y); apply G.mulLeftInv }; 46 | apply G.oneMul }; 47 | { transitivity; { symmetry; apply G.mulAssoc }; 48 | transitivity; { apply ap (G.φ · y); apply mulRightInv }; 49 | apply G.oneMul } 50 | end 51 | 52 | hott lemma leftIdeqv (G : Group) : left G G.e = ideqv G.carrier := 53 | begin apply Equiv.equivHmtpyLem; intro; apply G.oneMul end 54 | 55 | hott lemma leftRev (G : Group) (x : G.carrier) : left G (G.ι x) = (left G x).symm := 56 | begin apply Equiv.equivHmtpyLem; intro; reflexivity end 57 | 58 | hott definition S.univ (G : Group.{u}) : Hom G (S G.1.zero) := 59 | mkhomo (left G) 60 | (begin 61 | intros x y; fapply Theorems.Equiv.equivHmtpyLem; 62 | intro; apply G.mulAssoc 63 | end) 64 | 65 | hott lemma S.univ.ker.encode : (ker (S.univ G)).set ⊆ (triv G).set := 66 | begin 67 | intro x H; change _ = _; symmetry; 68 | apply unitOfSqr; apply Equiv.happlyEqv H 69 | end 70 | 71 | hott lemma S.univ.ker.decode : (triv G).set ⊆ (ker (S.univ G)).set := 72 | begin 73 | intros x H; apply Theorems.Equiv.equivHmtpyLem; 74 | intro y; induction H using Id.casesOn; apply G.oneMul 75 | end 76 | 77 | hott theorem S.univ.ker : ker (S.univ G) = triv G := 78 | normal.ext (Ens.ssubset.asymm S.univ.ker.encode S.univ.ker.decode) 79 | end 80 | end Group 81 | 82 | end GroundZero.Algebra 83 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Group/Z.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Group.Symmetric 2 | import GroundZero.HITs.Circle 3 | 4 | open GroundZero.Structures GroundZero.Types.Equiv 5 | open GroundZero.HITs.Circle (base loop) 6 | open GroundZero.Types GroundZero.HITs 7 | open GroundZero.Types.Id (ap) 8 | 9 | namespace GroundZero.Algebra 10 | 11 | hott definition ZΩ : Group := 12 | Group.intro (Circle.isGroupoid Circle.base Circle.base) Id.trans Id.inv (idp base) 13 | (λ a b c, (Id.assoc a b c)⁻¹) Id.lid Id.invComp 14 | 15 | hott definition ZΩ.abelian : ZΩ.isCommutative := Circle.comm 16 | 17 | hott definition helix {G : Group} (z : G.carrier) : S¹ → Type := 18 | Circle.rec G.carrier (GroundZero.ua (Group.left G z)) 19 | 20 | hott definition power {G : Group} (z : G.carrier) (p : ZΩ.carrier) : G.carrier := 21 | @transport S¹ (helix z) base base p G.e 22 | 23 | -- In cubicaltt these two lemmas will just compute 24 | hott lemma helix.loop {G : Group} (z x : G.carrier) : 25 | transport (helix z) loop x = G.φ z x := 26 | begin 27 | transitivity; apply Equiv.transportToTransportconst; 28 | transitivity; apply ap (transportconst · x); 29 | apply Circle.recβrule₂; apply uaβ 30 | end 31 | 32 | hott lemma helix.loopInv {G : Group} (z x : G.carrier) : 33 | transport (helix z) Circle.loop⁻¹ x = G.φ (G.ι z) x := 34 | begin 35 | transitivity; apply Equiv.transportToTransportconst; 36 | transitivity; apply ap (transportconst · x); 37 | transitivity; apply Id.mapInv; apply ap; 38 | apply Circle.recβrule₂; apply uaβrev 39 | end 40 | 41 | hott lemma power.succ {G : Group} (z : G.carrier) : 42 | Π p, power z (Circle.succ p) = G.φ z (power z p) := 43 | begin intro p; transitivity; apply Equiv.transportcom; apply helix.loop end 44 | 45 | hott lemma power.pred {G : Group} (z : G.carrier) : 46 | Π p, power z (Circle.pred p) = G.φ (G.ι z) (power z p) := 47 | begin intro p; transitivity; apply Equiv.transportcom; apply helix.loopInv end 48 | 49 | hott theorem power.mul {G : Group} (z : G.carrier) : 50 | Π (p q : ZΩ.carrier), power z (p ⬝ q) = G.φ (power z p) (power z q) := 51 | begin 52 | intro p q; fapply @Circle.Ωind₁ _ (λ p, power z (p ⬝ q) = G.φ (power z p) (power z q)) <;> clear p; 53 | { symmetry; apply G.oneMul }; 54 | { intros p ih; transitivity; apply ap; transitivity; 55 | symmetry; apply Id.assoc; transitivity; apply ap (Id.trans p); 56 | apply Circle.comm; apply Id.assoc; transitivity; apply power.succ; 57 | transitivity; apply ap (G.φ z); exact ih; 58 | transitivity; symmetry; apply G.mulAssoc; 59 | apply ap (G.φ · _); symmetry; apply power.succ }; 60 | { intros p ih; transitivity; apply ap; transitivity; 61 | symmetry; apply Id.assoc; transitivity; apply ap (Id.trans p); 62 | apply Circle.comm; apply Id.assoc; transitivity; apply power.pred; 63 | transitivity; apply ap (G.φ (G.ι z)); exact ih; 64 | transitivity; symmetry; apply G.mulAssoc; 65 | apply ap (G.φ · _); symmetry; apply power.pred } 66 | end 67 | 68 | hott definition ZΩ.rec {G : Group} (z : G.carrier) : Group.Hom ZΩ G := 69 | Group.mkhomo (power z) (power.mul z) 70 | 71 | hott definition ZΩ.mul (p q : ZΩ.carrier) : ZΩ.carrier := 72 | (@power hott% (Group.S ZΩ.1.zero) (ZΩ.left p) q).1 Id.refl 73 | 74 | hott theorem power.one {G : Group} : Π p, power G.e p = G.e := 75 | begin 76 | fapply Circle.Ωind₁; reflexivity; 77 | { intros p ih; transitivity; apply power.succ; 78 | transitivity; apply G.oneMul; exact ih }; 79 | { intros p ih; transitivity; apply power.pred; 80 | transitivity; apply ap (G.φ · _); 81 | symmetry; apply Group.unitInv; 82 | transitivity; apply G.oneMul; exact ih } 83 | end 84 | 85 | hott definition power.zero {G : Group} (x : G.carrier) : power x (idp base) = G.e := 86 | by reflexivity 87 | 88 | hott remark ZΩ.mulZero (p : ZΩ.carrier) : ZΩ.mul p (idp base) = idp base := 89 | by reflexivity 90 | 91 | hott lemma ZΩ.zeroMul (p : ZΩ.carrier) : ZΩ.mul (idp base) p = idp base := 92 | begin 93 | dsimp [ZΩ.mul]; show _ = (ideqv ZΩ.carrier).1 (idp base); 94 | apply ap (λ (e : ZΩ.carrier ≃ ZΩ.carrier), e.1 (idp base)); 95 | transitivity; apply ap (power · _); apply ZΩ.leftIdeqv; 96 | apply power.one 97 | end 98 | 99 | end GroundZero.Algebra 100 | -------------------------------------------------------------------------------- /GroundZero/Algebra/Monoid.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Algebra.Basic 2 | import GroundZero.HITs.Trunc 3 | 4 | open GroundZero GroundZero.Types 5 | open GroundZero.Types.Id (ap) 6 | 7 | namespace GroundZero.Algebra 8 | 9 | universe u v 10 | 11 | hott def Monoid := Σ (M : Magma), M.isAssociative × M.isUnital 12 | 13 | namespace Monoid 14 | variable (M : Monoid) 15 | 16 | hott def carrier := M.1.carrier 17 | hott def subset := M.1.subset 18 | hott def hset := M.1.hset 19 | hott def magma := M.1 20 | 21 | hott def φ := M.1.φ 22 | hott def e := M.2.2.1 23 | 24 | hott def mulAssoc : Π a b c, M.φ (M.φ a b) c = M.φ a (M.φ b c) := M.2.1 25 | 26 | hott def oneMul (a : M.carrier) : M.φ M.e a = a := (M.2.2.2 a).1 27 | hott def mulOne (a : M.carrier) : M.φ a M.e = a := (M.2.2.2 a).2 28 | 29 | hott def isCommutative := M.1.isCommutative 30 | 31 | hott def Hom (G H : Monoid) := Algebra.Hom G.1 H.1 32 | 33 | hott def intro {A : Type u} (H : Structures.hset A) 34 | (φ : A → A → A) (ι : A → A) (e : A) 35 | (α : Π a b c, φ (φ a b) c = φ a (φ b c)) 36 | (β₁ : Π a, φ e a = a) (β₂ : Π a, φ a e = a) : Monoid := 37 | ⟨Magma.intro H φ, (α, ⟨e, λ a, (β₁ a, β₂ a)⟩)⟩ 38 | end Monoid 39 | 40 | inductive Term (A : Type u) 41 | | φ : Term A → Term A → Term A 42 | | ι : A → Term A 43 | | e : Term A 44 | 45 | hott def Term.toList {A : Type u} : Term A → List A 46 | | Term.φ x y => Term.toList x ++ Term.toList y 47 | | Term.ι x => [x] 48 | | Term.e => [] 49 | 50 | hott def Term.ofList {A : Type u} : List A → Term A 51 | | [] => Term.e 52 | | x :: xs => Term.φ (Term.ι x) (Term.ofList xs) 53 | 54 | hott def Term.toMonoid (M : Monoid) : Term M.carrier → M.carrier 55 | | Term.φ x y => M.φ (Term.toMonoid M x) (Term.toMonoid M y) 56 | | Term.ι x => x 57 | | Term.e => M.e 58 | 59 | hott def Term.ofAppend (M : Monoid) : Π (xs ys : List M.carrier), 60 | Term.toMonoid M (Term.ofList (xs ++ ys)) 61 | = M.φ (Term.toMonoid M (Term.ofList xs)) (Term.toMonoid M (Term.ofList ys)) 62 | | [], ys => (M.oneMul _)⁻¹ 63 | | x :: xs, ys => ap (M.φ x) (Term.ofAppend M xs ys) ⬝ (M.mulAssoc _ _ _)⁻¹ 64 | 65 | hott def Term.sec (M : Monoid) : Term.toMonoid M ∘ Term.ofList ∘ Term.toList ~ Term.toMonoid M 66 | | Term.e => Id.refl 67 | | Term.ι x => M.mulOne x 68 | | Term.φ x y => Term.ofAppend M _ _ ⬝ Equiv.bimap M.φ (Term.sec M x) (Term.sec M y) 69 | 70 | hott def Term.solve (M : Monoid) (τ₁ τ₂ : Term M.carrier) 71 | (ρ : τ₁.toList = τ₂.toList) : τ₁.toMonoid M = τ₂.toMonoid M := 72 | (Term.sec M τ₁)⁻¹ ⬝ ap (Term.toMonoid M ∘ Term.ofList) ρ ⬝ Term.sec M τ₂ 73 | 74 | hott def Term.example (M : Monoid) (x y z : M.carrier) : 75 | M.φ (M.φ (M.φ x (M.φ y M.e)) M.e) (M.φ z M.e) = M.φ x (M.φ y z) := 76 | Term.solve M (Term.φ (Term.φ (Term.φ (Term.ι x) (Term.φ (Term.ι y) Term.e)) Term.e) (Term.φ (Term.ι z) Term.e)) 77 | (Term.φ (Term.ι x) (Term.φ (Term.ι y) (Term.ι z))) Id.refl 78 | 79 | hott def Term.ret {A : Type u} : Term.toList ∘ @Term.ofList A ~ id 80 | | [] => Id.refl 81 | | x :: xs => ap (List.cons x) (Term.ret xs) 82 | 83 | end GroundZero.Algebra 84 | -------------------------------------------------------------------------------- /GroundZero/Cubical/Connection.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Cubical.Path 2 | open GroundZero.Cubical GroundZero.HITs 3 | 4 | /- 5 | Connections as lines. 6 | -/ 7 | 8 | namespace GroundZero.Cubical.Connection 9 | universe u 10 | 11 | variable {A : Type u} {a b : A} (p : Path A a b) 12 | 13 | hott definition and (i : I) : Path A a (p @ i) := p @ i ∧ j 14 | hott definition or (i : I) : Path A (p @ i) b := p @ i ∨ j 15 | 16 | end GroundZero.Cubical.Connection 17 | -------------------------------------------------------------------------------- /GroundZero/Cubical/Cubes.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Interval 2 | open GroundZero.HITs GroundZero.Types 3 | open GroundZero.HITs.Interval (i₀ i₁ seg) 4 | 5 | /- 6 | * n-cube. 7 | * Square (2-cube). 8 | -/ 9 | 10 | namespace GroundZero.Cubical 11 | universe u v w r 12 | 13 | hott definition binary (A : Type u) : ℕ → Type u 14 | | Nat.zero => A × A 15 | | Nat.succ n => binary A n × binary A n 16 | 17 | -- cube n represents (n + 1)-cube. 18 | hott definition cube (A : Type u) : ℕ → Type u 19 | | Nat.zero => I → A 20 | | Nat.succ n => I → cube A n 21 | 22 | hott definition cube.tree {A : Type u} : Π {n : ℕ}, cube A n → binary A n 23 | | Nat.zero, f => (f 0, f 1) 24 | | Nat.succ n, f => (cube.tree (f 0), cube.tree (f 1)) 25 | 26 | inductive Cube {A : Type u} (n : ℕ) : binary A n → Type u 27 | | lam (f : cube A n) : Cube n (cube.tree f) 28 | 29 | hott definition Cube.lambda {A : Type u} (n : ℕ) (f : cube A n) : Cube n (cube.tree f) := 30 | Cube.lam f 31 | 32 | /- 33 | c ------> d 34 | ^ ^ 35 | | | 36 | | | 37 | | | 38 | a ------> b 39 | -/ 40 | hott definition Square {A : Type u} (a b c d : A) := 41 | Cube 1 ((a, b), (c, d)) 42 | 43 | hott definition Square.lam {A : Type u} (f : I → I → A) : 44 | Square (f 0 0) (f 0 1) (f 1 0) (f 1 1) := 45 | @Cube.lam A 1 f 46 | 47 | hott definition Square.rec {A : Type u} {C : Π (a b c d : A), Square a b c d → Type v} 48 | (H : Π (f : I → I → A), C (f 0 0) (f 0 1) (f 1 0) (f 1 1) (Square.lam f)) 49 | {a b c d : A} (τ : Square a b c d) : C a b c d τ := 50 | @Cube.casesOn A 1 (λ w, C w.1.1 w.1.2 w.2.1 w.2.2) ((a, b), (c, d)) τ H 51 | 52 | end GroundZero.Cubical 53 | -------------------------------------------------------------------------------- /GroundZero/Cubical/Example.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Cubical.V 2 | 3 | open GroundZero.Cubical.Path (kan refl) 4 | open GroundZero.Cubical 5 | 6 | /- 7 | This example on Lean. 8 | https://github.com/mortberg/cubicaltt/blob/9baa6f2491cc61dbd4fd81d58323c04100381451/examples/nat.ctt#L52-L57 9 | -/ 10 | 11 | namespace GroundZero.Cubical.Cubicaltt 12 | open Nat (zero succ) 13 | 14 | hott definition add (m : ℕ) : ℕ → ℕ 15 | | zero => m 16 | | succ n => succ (add m n) 17 | 18 | hott definition addZero : Π a, Path ℕ (add zero a) a 19 | | zero => <_> zero 20 | | succ a => succ ((addZero a) @ i) 21 | 22 | hott definition addSucc (a : ℕ) : Π b, Path ℕ (add (succ a) b) (succ (add a b)) 23 | | zero => <_> succ a 24 | | succ b => succ ((addSucc a b) @ i) 25 | 26 | hott definition addZeroInv : Π a, Path ℕ a (add a zero) := 27 | refl 28 | 29 | hott definition addComm (a : ℕ) : Π b, Path ℕ (add a b) (add b a) 30 | | zero => (addZero a) @ −i 31 | | succ b => kan ( succ ((addComm a b) @ i)) ( succ (add a b)) ( (addSucc b a) @ −j) 32 | 33 | hott definition addAssoc (a b : ℕ) : Π c, Path ℕ (add a (add b c)) (add (add a b) c) 34 | | zero => <_> add a b 35 | | succ c => succ ((addAssoc a b c) @ i) 36 | 37 | hott definition addComm₃ {a b c : ℕ} : Path ℕ (add a (add b c)) (add c (add b a) ):= 38 | let r : Path ℕ (add a (add b c)) (add a (add c b)) := 39 | add a ((addComm b c) @ i); 40 | kan (addComm a (add c b)) ( r @ −j) ( (addAssoc c b a) @ −j) 41 | 42 | hott example (n m : ℕ) (h : Path ℕ n m) : Path ℕ (n + 1) (m + 1) := 43 | succ (h @ i) 44 | 45 | end GroundZero.Cubical.Cubicaltt 46 | -------------------------------------------------------------------------------- /GroundZero/Cubical/V.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | import GroundZero.Cubical.Path 3 | 4 | open GroundZero.HITs.Interval (transportconstWithSeg) 5 | open GroundZero GroundZero.HITs GroundZero.Types 6 | 7 | /- 8 | V, Vproj 9 | * https://arxiv.org/abs/1712.01800 10 | Part 6 ‘Rules’, page 66 ‘Univalence’ 11 | 12 | ua, uabeta 13 | -/ 14 | 15 | namespace GroundZero.Cubical 16 | universe u v 17 | 18 | hott definition V (i : I) {A B : Type u} (e : A ≃ B) : Type u := 19 | Interval.rec A B (ua e) i 20 | 21 | hott definition Vproj (i : I) {A B : Type u} (e : A ≃ B) (m : A) : V i e := 22 | @Interval.ind (λ i, V i e) m (e m) (transportconstWithSeg (ua e) m ⬝ uaβ e m) i 23 | 24 | hott definition ua {A B : Type u} (e : A ≃ B) : Path (Type u) A B := V i e 25 | 26 | hott definition uabeta {A B : Type u} (e : A ≃ B) (m : A) : 27 | Path B (coe⁻¹ 0 1 (λ i, V i e) m) (e.1 m) := 28 | coe⁻¹ i 1 (λ i, V i e) (Vproj i e m) 29 | 30 | hott definition univalence.elim {A B : Type u} (p : Path (Type u) A B) : A ≃ B := 31 | Path.coe 0 1 (λ i, A ≃ p @ i) (Equiv.ideqv A) 32 | 33 | hott definition iso {A B : Type u} (f : A → B) (g : B → A) 34 | (F : f ∘ g ~′ id) (G : g ∘ f ~′ id) : Path (Type u) A B := 35 | ua ⟨f, Qinv.toBiinv f ⟨g, ⟨Path.homotopyEquality F, Path.homotopyEquality G⟩⟩⟩ 36 | 37 | end GroundZero.Cubical 38 | -------------------------------------------------------------------------------- /GroundZero/Exercises/Chap2.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | import GroundZero.Theorems.Pullback 3 | 4 | open GroundZero GroundZero.Types 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Types.Equiv 7 | open GroundZero.Proto 8 | 9 | open GroundZero.Structures (prop contr) 10 | 11 | universe u v u' v' w w' k k' 12 | 13 | -- exercise 2.1 14 | 15 | section 16 | variable {A : Type u} {a b c : A} 17 | 18 | hott definition trans₁ (p : a = b) (q : b = c) : a = c := 19 | @J₁ A a (λ x _, x = c → a = c) (@J₁ A a (λ x _, a = x) (idp a) c) b p q 20 | 21 | infixl:99 " ⬝₁ " => trans₁ 22 | 23 | hott definition trans₂ (p : a = b) (q : b = c) : a = c := 24 | @J₁ A a (λ x _, x = c → a = c) idfun b p q 25 | 26 | infixl:99 " ⬝₂ " => trans₂ 27 | 28 | hott definition trans₃ (p : a = b) (q : b = c) : a = c := 29 | @J₁ A b (λ x _, a = b → a = x) idfun c q p 30 | 31 | infixl:99 " ⬝₃ " => trans₃ 32 | 33 | hott remark eq₁₂ (p : a = b) (q : b = c) : p ⬝₁ q = p ⬝₂ q := 34 | begin induction p; induction q; reflexivity end 35 | 36 | hott remark eq₂₃ (p : a = b) (q : b = c) : p ⬝₂ q = p ⬝₃ q := 37 | begin induction p; induction q; reflexivity end 38 | 39 | hott remark eq₁₃ (p : a = b) (q : b = c) : p ⬝₁ q = p ⬝₃ q := 40 | begin induction p; induction q; reflexivity end 41 | end 42 | 43 | -- exercise 2.2 44 | 45 | section 46 | variable {A : Type u} {a b c : A} (p : a = b) (q : b = c) 47 | 48 | hott example : eq₁₂ p q ⬝ eq₂₃ p q = eq₁₃ p q := 49 | begin induction p; induction q; reflexivity end 50 | end 51 | 52 | -- exercise 2.3 53 | 54 | section 55 | variable {A : Type u} {a b c : A} 56 | 57 | hott definition trans₄ (p : a = b) (q : b = c) : a = c := 58 | @J₁ A b (λ x _, a = b → a = x) (@J₁ A a (λ x _, a = x) (idp a) b) c q p 59 | 60 | infixl:99 " ⬝₄ " => trans₄ 61 | 62 | /- 63 | hott example (p : a = b) (q : b = c) : p ⬝₁ q = p ⬝₄ q := idp _ 64 | hott example (p : a = b) (q : b = c) : p ⬝₂ q = p ⬝₄ q := idp _ 65 | hott example (p : a = b) (q : b = c) : p ⬝₃ q = p ⬝₄ q := idp _ 66 | -/ 67 | 68 | hott example (p : a = b) (q : b = c) : p ⬝₁ q = p ⬝₄ q := 69 | begin induction p; induction q; reflexivity end 70 | end 71 | 72 | -- exercise 2.4 73 | 74 | hott definition nPath (A : Type u) : ℕ → Type u 75 | | Nat.zero => A 76 | | Nat.succ n => Σ (a b : nPath A n), a = b 77 | 78 | hott definition boundary {A : Type u} {n : ℕ} : 79 | nPath A (n + 1) → (nPath A n) × (nPath A n) := 80 | λ ⟨a, b, _⟩, (a, b) 81 | 82 | -- exercise 2.5 83 | 84 | namespace «2.5» 85 | variable {A : Type u} {B : Type v} {x y : A} (p : x = y) 86 | 87 | hott definition transconst (b : B) : transport (λ _, B) p b = b := 88 | begin induction p; reflexivity end 89 | 90 | hott definition f (φ : A → B) : φ x = φ y → transport (λ _, B) p (φ x) = φ y := 91 | λ q, transconst p (φ x) ⬝ q 92 | 93 | hott definition g (φ : A → B) : transport (λ _, B) p (φ x) = φ y → φ x = φ y := 94 | λ q, (transconst p (φ x))⁻¹ ⬝ q 95 | 96 | hott example (φ : A → B) : f p φ ∘ g p φ ~ id := 97 | begin induction p; reflexivity end 98 | 99 | hott example (φ : A → B) : g p φ ∘ f p φ ~ id := 100 | begin induction p; reflexivity end 101 | end «2.5» 102 | 103 | -- exercise 2.6 104 | 105 | hott example {A : Type u} {x y z : A} (p : x = y) : biinv (@Id.trans A x y z p) := 106 | begin apply Prod.mk <;> existsi Id.trans p⁻¹ <;> intro q <;> induction p <;> induction q <;> reflexivity end 107 | 108 | -- exercise 2.7 109 | 110 | namespace «2.7» 111 | variable {A : Type u} {A' : Type u'} {B : A → Type v} {B' : A' → Type v'} 112 | (g : A → A') (h : Π a, B a → B' (g a)) 113 | 114 | hott definition φ (x : Σ a, B a) : Σ a', B' a' := ⟨g x.1, h x.1 x.2⟩ 115 | 116 | hott definition prodMap : Π (x y : Σ a, B a) (p : x.1 = y.1) (q : x.2 =[p] y.2), 117 | ap (φ g h) (Sigma.prod p q) 118 | = @Sigma.prod A' B' (φ g h x) (φ g h y) 119 | (@ap A A' x.1 y.1 g p) (depPathMap' g h q) := 120 | begin 121 | intro ⟨x, H⟩ ⟨y, G⟩ (p : x = y); induction p; 122 | intro (q : H = G); induction q; reflexivity 123 | end 124 | end «2.7» 125 | 126 | -- exercise 2.8 127 | 128 | namespace «2.8» 129 | variable {A A' B B' : Type u} (g : A → A') (h : B → B') 130 | 131 | hott definition φ : A + B → A' + B' := 132 | Coproduct.elim (Coproduct.inl ∘ g) (Coproduct.inr ∘ h) 133 | 134 | hott definition ρ : Π {x y : A + B}, Coproduct.code x y → Coproduct.code (φ g h x) (φ g h y) 135 | | Sum.inl _, Sum.inl _, p => ap _ p 136 | | Sum.inr _, Sum.inl _, p => explode p 137 | | Sum.inl _, Sum.inr _, p => explode p 138 | | Sum.inr _, Sum.inr _, p => ap _ p 139 | 140 | hott definition mapPathSum (x y : A + B) : Π p, 141 | ap (φ g h) (Coproduct.pathSum x y p) 142 | = Coproduct.pathSum (φ g h x) (φ g h y) (ρ g h p) := 143 | begin 144 | match x, y with 145 | | Sum.inl x, Sum.inl y => _ 146 | | Sum.inr _, Sum.inl _ => _ 147 | | Sum.inl _, Sum.inr _ => _ 148 | | Sum.inr x, Sum.inr y => _; 149 | 150 | { intro (p : x = y); induction p; reflexivity }; 151 | { intro; apply explode; assumption }; 152 | { intro; apply explode; assumption }; 153 | { intro (p : x = y); induction p; reflexivity } 154 | end 155 | end «2.8» 156 | 157 | -- exercise 2.9 158 | 159 | hott definition Coproduct.depUnivProperty (A : Type u) (B : Type v) (X : A + B → Type w) : 160 | (Π x, X x) ≃ (Π a, X (Coproduct.inl a)) × (Π b, X (Coproduct.inr b)) := 161 | begin 162 | fapply Sigma.mk; { intro φ; exact (λ a, φ (Coproduct.inl a), λ b, φ (Coproduct.inr b)) }; 163 | apply Qinv.toBiinv; fapply Sigma.mk; 164 | { intros φ x; induction x using Sum.casesOn; apply φ.1; apply φ.2 }; 165 | apply Prod.mk; { intro (φ, ψ); reflexivity }; 166 | { intro f; apply Theorems.funext; intro z; induction z using Sum.casesOn <;> reflexivity } 167 | end 168 | 169 | hott definition Coproduct.univProperty (A : Type u) (B : Type v) (X : Type w) : 170 | (A + B → X) ≃ (A → X) × (B → X) := 171 | Coproduct.depUnivProperty A B (λ _, X) 172 | 173 | -- exercise 2.10 174 | 175 | hott example (A : Type u) (B : A → Type v) (C : (Σ x, B x) → Type w) : 176 | (Σ x, Σ y, C ⟨x, y⟩) ≃ (Σ p, C p) := 177 | Sigma.assoc C 178 | 179 | -- exercise 2.11 180 | 181 | namespace «2.11» 182 | variable {P : Type k} {A : Type u} {B : Type v} {C : Type w} 183 | (η : pullbackSquare P A B C) 184 | 185 | hott example : P ≃ pullback C η.1.right η.1.bot := 186 | Theorems.pullbackCorner η 187 | end «2.11» 188 | 189 | -- exercise 2.12 190 | 191 | namespace «2.12» 192 | variable {A B C D E F : Type u} 193 | {f : A → C} {g : C → E} {i : A → B} {j : C → D} 194 | {k : E → F} {h : B → D} {s : D → F} 195 | (α : j ∘ f = h ∘ i) (β : k ∘ g = s ∘ j) 196 | 197 | hott definition left : hcommSquare A C B D := ⟨j, h, f, i, α⟩ 198 | hott definition right : hcommSquare C E D F := ⟨k, s, g, j, β⟩ 199 | 200 | hott definition outer : hcommSquare A E B F := 201 | ⟨k, s ∘ h, g ∘ f, i, @ap (C → F) (A → F) _ _ (· ∘ f) β 202 | ⬝ @ap _ (A → F) _ _ (s ∘ ·) α⟩ 203 | 204 | hott theorem pullbackLemma (H : (right β).isPullback) : 205 | (left α).isPullback ↔ (outer α β).isPullback := 206 | sorry 207 | end «2.12» 208 | 209 | -- exercise 2.13 210 | 211 | hott example : (𝟐 ≃ 𝟐) ≃ 𝟐 := Theorems.Equiv.boolEquivEqvBool 212 | 213 | -- exercise 2.14 214 | 215 | -- Assume Γ, p : x = y ⊢ x ≡ y, let Γ = A : U, a : A. Then Γ, b : A, p : a = b ⊢ p = idp a : U, 216 | -- because in this context we have p : a = b, so a ≡ b, so p : a = a. 217 | -- “@Id.rec A a (λ b, p = idp a) (λ x, idp a) a” is then well-typed. 218 | -- This means that we have a proof of “Π (p : a = a), p = idp a” leading to contradiction. 219 | 220 | -- exercise 2.15 221 | 222 | hott definition transportMap {A : Type u} {B : A → Type v} {x y : A} (p : x = y) : 223 | transport B p = idtoeqv (ap B p) := 224 | begin induction p; reflexivity end 225 | 226 | -- exercise 2.18 227 | 228 | hott definition transportSquare {A : Type u} {B : A → Type v} {f g : Π x, B x} (H : f ~ g) {x y : A} (p : x = y) : 229 | ap (transport B p) (H x) ⬝ apd g p = apd f p ⬝ H y := 230 | begin induction p; transitivity; apply Id.rid; apply Equiv.idmap end 231 | -------------------------------------------------------------------------------- /GroundZero/Exercises/Chap5.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Exercises.Chap4 2 | import GroundZero.Types.Lost 3 | 4 | open GroundZero.Types 5 | open GroundZero.Proto 6 | open GroundZero 7 | 8 | universe u v w 9 | 10 | -- Exercise 5.1 11 | 12 | namespace «5.1» 13 | /- 14 | Another useful example is the type List(A) of finite lists of elements of some type A, 15 | which has constructors 16 | • nil : List(A) 17 | • cons : A → List(A) → List(A). 18 | -/ 19 | 20 | variable (List : Type → Type) 21 | 22 | variable (A : Type) (nil : List A) (cons : A → List A → List A) 23 | 24 | hott definition indSig := 25 | Π (C : List A → Type), C nil → (Π (x : A) (xs : List A), C xs → C (cons x xs)) → Π ys, C ys 26 | 27 | variable (ind : indSig List A nil cons) 28 | 29 | variable (C : List A → Type) (cz : C nil) (cs : Π (x : A) (xs : List A), C xs → C (cons x xs)) 30 | 31 | hott definition indβruleSig₁ := 32 | ind C cz cs nil = cz 33 | 34 | hott definition indβruleSig₂ := 35 | Π (x : A) (xs : List A), ind C cz cs (cons x xs) = cs x xs (ind C cz cs xs) 36 | end «5.1» 37 | 38 | -- Exercise 5.2 39 | 40 | namespace «5.2» 41 | open Nat (zero succ) 42 | 43 | hott definition idfun₁ : ℕ → ℕ := 44 | λ n, n 45 | 46 | hott definition idfun₂ : ℕ → ℕ 47 | | zero => zero 48 | | succ n => succ (idfun₂ n) 49 | 50 | hott definition ez : ℕ := zero 51 | hott definition es : ℕ → ℕ → ℕ := λ n m, succ m 52 | 53 | #failure idfun₁ ≡ idfun₂ 54 | 55 | #success idfun₁ zero ≡ ez 56 | #success idfun₂ zero ≡ ez 57 | 58 | variable (n : ℕ) 59 | #success idfun₁ (succ n) ≡ es n (idfun₁ n) 60 | #success idfun₂ (succ n) ≡ es n (idfun₂ n) 61 | end «5.2» 62 | 63 | -- Exercise 5.3 64 | 65 | namespace «5.3» 66 | open Nat (zero succ) 67 | 68 | variable {E : Type u} {e : E} 69 | 70 | hott definition ez₁ : E := e 71 | hott definition es₁ : ℕ → E → E := λ n ε, ε 72 | 73 | hott definition ez₂ : E := e 74 | hott definition es₂ : ℕ → E → E := λ n _, e 75 | 76 | #failure @es₁ E ≡ @es₂ E e : ℕ → E → E 77 | 78 | hott definition f : ℕ → E := 79 | λ _, e 80 | 81 | #success (@f E e) zero ≡ @ez₁ E e 82 | #success (@f E e) zero ≡ @ez₂ E e 83 | 84 | variable (n : ℕ) 85 | #success (@f E e) (succ n) ≡ (@es₁ E) n (@f E e n) 86 | #success (@f E e) (succ n) ≡ (@es₂ E e) n (@f E e n) 87 | end «5.3» 88 | 89 | -- Exercise 5.4 90 | 91 | hott example (E : 𝟐 → Type u) : (E false × E true) ≃ (Π b, E b) := 92 | familyOnBool 93 | 94 | -- Exercise 5.7 95 | 96 | namespace «5.7» 97 | variable (C : Type) (c : (C → 𝟎) → C) (elim : Π (P : Type), ((C → 𝟎) → (P → 𝟎) → P) → C → P) 98 | 99 | hott example : 𝟎 := 100 | have nc := elim 𝟎 (λ g i, g (c g)); 101 | nc (c nc) 102 | end «5.7» 103 | 104 | -- Exercise 5.8 105 | 106 | namespace «5.8» 107 | variable (D : Type) (scott : (D → D) → D) 108 | (elim : Π (P : Type), ((D → D) → (D → P) → P) → D → P) 109 | 110 | hott example : 𝟎 := 111 | have nd := elim 𝟎 (λ f g, g (scott f)); 112 | nd (scott idfun) 113 | 114 | -- Computation rule seems to be not required here. 115 | variable (elimβrule : Π P h α, elim P h (scott α) = h α (elim P h ∘ α)) 116 | end «5.8» 117 | 118 | -- Exercise 5.9 119 | 120 | namespace «5.9» 121 | variable {A L : Type} (lawvere : (L → A) → L) (elim : Π (P : Type), ((L → A) → P) → L → P) 122 | 123 | hott definition fix (f : A → A) : A := 124 | have φ := elim A (λ α, f (α (lawvere α))); 125 | φ (lawvere φ) 126 | 127 | variable (elimβrule : Π P h α, elim P h (lawvere α) = h α) 128 | 129 | hott theorem hasFixpoint (f : A → A) (a : A) : f (fix lawvere elim f) = fix lawvere elim f := 130 | begin symmetry; apply elimβrule end 131 | end «5.9» 132 | 133 | -- Exercise 5.11 134 | 135 | hott example (A : Type u) : Lost A ≃ 𝟎 := 136 | Lost.isZero 137 | -------------------------------------------------------------------------------- /GroundZero/Exercises/README.md: -------------------------------------------------------------------------------- 1 | # See also 2 | 3 | * https://github.com/HoTT/Coq-HoTT/blob/master/contrib/HoTTBookExercises.v 4 | * https://github.com/HoTT/book/blob/master/exercise_solutions.tex 5 | * https://github.com/pcapriotti/hott-exercises 6 | * https://github.com/ezyang/HoTT-coqex -------------------------------------------------------------------------------- /GroundZero/HITs/Coequalizer.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Quotient 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types 6 | 7 | namespace GroundZero.HITs 8 | universe u v w 9 | 10 | section 11 | variable {A : Type u} {B : Type v} (f g : A → B) 12 | 13 | inductive Coeq.rel : B → B → Type (max u v) 14 | | intro : Π x, rel (f x) (g x) 15 | 16 | hott definition Coeq := Quotient (Coeq.rel f g) 17 | end 18 | 19 | namespace Coeq 20 | variable {A : Type u} {B : Type v} {f g : A → B} 21 | 22 | hott definition iota : B → Coeq f g := Quotient.elem 23 | 24 | hott definition resp : Π x, @Id (Coeq f g) (iota (f x)) (iota (g x)) := 25 | λ x, Quotient.line (Coeq.rel.intro x) 26 | 27 | hott definition ind (C : Coeq f g → Type w) (i : Π x, C (iota x)) 28 | (ρ : Π x, i (f x) =[resp x] i (g x)) : Π x, C x := 29 | begin fapply Quotient.ind; apply i; intros x y H; induction H using rel.casesOn; apply ρ end 30 | 31 | attribute [induction_eliminator] ind 32 | 33 | hott definition indβrule (C : Coeq f g → Type w) (i : Π x, C (iota x)) 34 | (ρ : Π x, i (f x) =[resp x] i (g x)) (x : A) : apd (ind C i ρ) (resp x) = ρ x := 35 | @Quotient.indβrule _ (rel f g) _ _ _ _ _ (rel.intro x) 36 | 37 | hott definition rec (C : Type w) (i : B → C) (ρ : Π x, i (f x) = i (g x)) : Coeq f g → C := 38 | ind (λ _, C) i (λ x, pathoverOfEq (resp x) (ρ x)) 39 | 40 | hott definition recβrule (C : Type w) (i : B → C) (ρ : Π x, i (f x) = i (g x)) : 41 | Π x, ap (rec C i ρ) (resp x) = ρ x := 42 | begin 43 | intro x; apply pathoverOfEqInj (resp x); 44 | transitivity; symmetry; apply apdOverConstantFamily; 45 | transitivity; apply indβrule; reflexivity 46 | end 47 | end Coeq 48 | 49 | end GroundZero.HITs 50 | -------------------------------------------------------------------------------- /GroundZero/HITs/Colimit.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Quotient 2 | open GroundZero.Types.Equiv (pathoverOfEq) 3 | 4 | /- 5 | Sequential Colimit. 6 | * https://homotopytypetheory.org/2016/01/08/Colimits-in-hott/ 7 | -/ 8 | 9 | namespace GroundZero.HITs 10 | universe u v 11 | 12 | inductive Colimit.core (A : ℕ → Type u) 13 | (f : Π (n : ℕ), A n → A (n + 1)) 14 | | incl {n : ℕ} : A n → core A f 15 | 16 | inductive Colimit.rel (A : ℕ → Type u) (f : Π (n : ℕ), A n → A (n + 1)) : 17 | Colimit.core A f → Colimit.core A f → Type u 18 | | glue (n : ℕ) (x : A n) : rel A f (core.incl (f n x)) (core.incl x) 19 | 20 | hott definition Colimit (A : ℕ → Type u) (f : Π (n : ℕ), A n → A (n + 1)) := 21 | Quotient (Colimit.rel A f) 22 | 23 | namespace Colimit 24 | variable {A : ℕ → Type u} {f : Π (n : ℕ), A n → A (n + 1)} 25 | 26 | hott definition incl {n : ℕ} (x : A n) : Colimit A f := 27 | Quotient.elem (core.incl x) 28 | 29 | hott definition inclusion (n : ℕ) : A n → Colimit A f := incl 30 | 31 | hott definition glue {n : ℕ} (x : A n) : incl (f n x) = @incl A f n x := 32 | Quotient.line (Colimit.rel.glue n x) 33 | 34 | hott definition ind {B : Colimit A f → Type v} (inclπ : Π (n : ℕ) (x : A n), B (incl x)) 35 | (glueπ : Π (n : ℕ) (x : A n), inclπ (n + 1) (f n x) =[glue x] inclπ n x) : Π x, B x := 36 | begin 37 | intro x; fapply Quotient.ind; 38 | { intro (core.incl x); apply inclπ }; 39 | { intros u v H; induction H; apply glueπ } 40 | end 41 | 42 | attribute [induction_eliminator] ind 43 | 44 | hott definition rec {B : Type v} (inclπ : Π (n : ℕ), A n → B) 45 | (glueπ : Π (n : ℕ) (x : A n), inclπ (n + 1) (f n x) = inclπ n x) : Colimit A f → B := 46 | ind @inclπ (λ n x, pathoverOfEq (glue x) (glueπ n x)) 47 | end Colimit 48 | 49 | end GroundZero.HITs 50 | -------------------------------------------------------------------------------- /GroundZero/HITs/Flattening.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | import GroundZero.HITs.Coequalizer 3 | 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Types.Equiv 6 | open GroundZero.Types 7 | open GroundZero (ua) 8 | 9 | namespace GroundZero.HITs 10 | universe u v w 11 | 12 | section 13 | variable {A : Type u} {B : Type v} (f g : A → B) 14 | (C : B → Type w) (D : Π x, C (f x) ≃ C (g x)) 15 | 16 | hott definition Flattening := @Coeq (Σ x, C (f x)) (Σ x, C x) 17 | (λ w, ⟨f w.1, w.2⟩) (λ w, ⟨g w.1, (D w.1).1 w.2⟩) 18 | 19 | hott definition P : Coeq f g → Type w := 20 | Coeq.rec (Type w) C (λ x, ua (D x)) 21 | end 22 | 23 | namespace Flattening 24 | variable {A : Type u} {B : Type v} {f g : A → B} 25 | {C : B → Type w} {D : Π x, C (f x) ≃ C (g x)} 26 | 27 | hott definition iota (x : B) (c : C x) : Flattening f g C D := 28 | Coeq.iota ⟨x, c⟩ 29 | 30 | hott definition resp (x : A) (y : C (f x)) : @Id (Flattening f g C D) (iota (f x) y) (iota (g x) ((D x).1 y)) := 31 | @Coeq.resp (Σ x, C (f x)) (Σ x, C x) (λ w, ⟨f w.1, w.2⟩) (λ w, ⟨g w.1, (D w.1).1 w.2⟩) ⟨x, y⟩ 32 | 33 | hott definition iotaφ : Π x, C x → Σ x, P f g C D x := 34 | λ x y, ⟨Coeq.iota x, y⟩ 35 | 36 | hott definition respφ (x : A) (y : C (f x)) : 37 | @Id (Σ x, P f g C D x) (iotaφ (f x) y) (iotaφ (g x) ((D x).1 y)) := 38 | begin 39 | fapply Sigma.prod; apply Coeq.resp; 40 | transitivity; apply transportToTransportconst; 41 | transitivity; apply @ap _ _ (ap (P f g C D) (Coeq.resp x)) _ (transportconst · y); 42 | apply Coeq.recβrule (Type w) C (λ x, ua (D x)) x; apply uaβ 43 | end 44 | 45 | hott definition sec : Flattening f g C D → Σ x, P f g C D x := 46 | begin fapply Coeq.rec; intro w; apply iotaφ w.1 w.2; intro w; apply respφ w.1 w.2 end 47 | end Flattening 48 | 49 | end GroundZero.HITs 50 | -------------------------------------------------------------------------------- /GroundZero/HITs/Generalized.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Quotient 2 | open GroundZero.Types.Equiv (pathoverOfEq) 3 | 4 | /- 5 | Generalized circle or one-step truncation. 6 | * https://homotopytypetheory.org/2015/07/28/constructing-the-propositional-truncation-using-nonrecursive-hits/ 7 | * https://arxiv.org/pdf/1512.02274 8 | -/ 9 | 10 | namespace GroundZero.HITs 11 | universe u v 12 | 13 | inductive Generalized.rel (A : Type u) : A → A → Type u 14 | | mk : Π (a b : A), rel A a b 15 | 16 | hott definition Generalized (A : Type u) := Quotient (Generalized.rel A) 17 | notation "{" A "}" => Generalized A 18 | 19 | namespace Generalized 20 | hott definition incl {A : Type u} : A → {A} := Quotient.elem 21 | 22 | hott definition glue {A : Type u} (a b : A) : incl a = incl b := 23 | Quotient.line (Generalized.rel.mk a b) 24 | 25 | hott definition ind {A : Type u} {B : {A} → Type v} (inclπ : Π a, B (incl a)) 26 | (glueπ : Π a b, inclπ a =[glue a b] inclπ b) : Π x, B x := 27 | begin fapply Quotient.ind; exact inclπ; { intros u v H; induction H; apply glueπ } end 28 | 29 | attribute [induction_eliminator] ind 30 | 31 | hott definition rec {A : Type u} {B : Type v} (inclπ : A → B) 32 | (glueπ : Π a b, inclπ a = inclπ b) : {A} → B := 33 | ind inclπ (λ a b, pathoverOfEq (glue a b) (glueπ a b)) 34 | 35 | hott definition rep (A : Type u) : ℕ → Type u 36 | | Nat.zero => A 37 | | Nat.succ n => {rep A n} 38 | 39 | hott definition dep (A : Type u) (n : ℕ) : rep A n → rep A (n + 1) := incl 40 | end Generalized 41 | 42 | end GroundZero.HITs 43 | -------------------------------------------------------------------------------- /GroundZero/HITs/Int.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Nat 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types 5 | open GroundZero 6 | 7 | /- 8 | Integers ℤ as a quotient of ℕ × ℕ. 9 | * HoTT 6.10, remark 6.10.7 10 | -/ 11 | 12 | namespace GroundZero.HITs 13 | 14 | hott definition Int.rel (w₁ w₂ : ℕ × ℕ) : Type := 15 | w₁.1 + w₂.2 = w₁.2 + w₂.1 16 | 17 | hott definition Int := Quotient Int.rel 18 | local notation "ℤ" => Int 19 | 20 | namespace Nat.Product 21 | hott definition add (x y : ℕ × ℕ) : ℕ × ℕ := 22 | (x.1 + y.1, x.2 + y.2) 23 | 24 | noncomputable instance : Add (ℕ × ℕ) := ⟨add⟩ 25 | 26 | hott definition mul (x y : ℕ × ℕ) : ℕ × ℕ := 27 | (x.1 * y.1 + x.2 * y.2, x.1 * y.2 + x.2 * y.1) 28 | 29 | noncomputable instance : Mul (ℕ × ℕ) := ⟨mul⟩ 30 | end Nat.Product 31 | 32 | namespace Int 33 | universe u v 34 | 35 | hott definition mk : ℕ × ℕ → ℤ := Quotient.elem 36 | hott definition elem (a b : ℕ) : ℤ := Quotient.elem (a, b) 37 | 38 | hott definition pos (n : ℕ) := mk (n, 0) 39 | noncomputable instance (n : ℕ) : OfNat ℤ n := ⟨pos n⟩ 40 | 41 | hott definition neg (n : ℕ) := mk (0, n) 42 | 43 | hott definition glue {a b c d : ℕ} (H : a + d = b + c) : mk (a, b) = mk (c, d) := 44 | Quotient.line H 45 | 46 | hott definition ind {C : ℤ → Type u} (mkπ : Π x, C (mk x)) 47 | (glueπ : Π {a b c d : ℕ} (H : a + d = b + c), 48 | mkπ (a, b) =[glue H] mkπ (c, d)) (x : ℤ) : C x := 49 | begin fapply Quotient.ind; exact mkπ; intros x y H; apply glueπ end 50 | 51 | hott definition rec {C : Type u} (mkπ : ℕ × ℕ → C) 52 | (glueπ : Π {a b c d : ℕ} (H : a + d = b + c), 53 | mkπ (a, b) = mkπ (c, d)) : ℤ → C := 54 | begin fapply Quotient.rec; exact mkπ; intros x y H; apply glueπ H end 55 | 56 | noncomputable instance : Neg Int := 57 | ⟨rec (λ x, mk ⟨x.2, x.1⟩) (λ H, glue H⁻¹)⟩ 58 | 59 | hott definition addRight (a b k : ℕ) : mk (a, b) = mk (a + k, b + k) := 60 | begin 61 | apply glue; transitivity; symmetry; apply Theorems.Nat.assoc; 62 | symmetry; transitivity; symmetry; apply Theorems.Nat.assoc; 63 | apply ap (λ n, n + k); apply Theorems.Nat.comm 64 | end 65 | end Int 66 | end GroundZero.HITs 67 | -------------------------------------------------------------------------------- /GroundZero/HITs/Interval.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Structures 2 | 3 | open GroundZero.Structures GroundZero.Types 4 | open GroundZero.Theorems (funext) 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Types.Equiv 7 | 8 | namespace GroundZero 9 | universe u v w 10 | 11 | namespace HITs 12 | namespace Interval 13 | hott definition lift {B : Type u} (φ : 𝟐 → B) (H : prop B) : I → B := 14 | rec (φ false) (φ true) (H _ _) 15 | 16 | hott definition contrLeft : Π i, i₀ = i := 17 | ind (idp i₀) seg (pathoverFromTrans seg (idp i₀) seg (idp seg)) 18 | 19 | hott definition contrRight : Π i, i₁ = i := 20 | ind seg⁻¹ (idp i₁) (pathoverFromTrans seg seg⁻¹ (idp i₁) (Id.invComp seg)) 21 | 22 | hott theorem intervalContr : contr I := ⟨i₁, contrRight⟩ 23 | 24 | hott corollary intervalProp : prop I := 25 | contrImplProp intervalContr 26 | 27 | hott corollary transportOverHmtpy {A : Type u} {B : Type v} {C : Type w} 28 | (f : A → B) (g₁ g₂ : B → C) (h : A → C) (p : g₁ = g₂) (H : g₁ ∘ f ~ h) (x : A) : 29 | transport (λ (g : B → C), g ∘ f ~ h) p H x 30 | = @transport (B → C) (λ (g : B → C), g (f x) = h x) g₁ g₂ p (H x) := 31 | happly (transportOverPi _ _ _) x 32 | 33 | hott definition boolToInterval (φ : 𝟐 → 𝟐 → 𝟐) (a b : I) : I := 34 | lift (λ x, lift (ofBool ∘ φ x) intervalProp b) intervalProp a 35 | 36 | hott definition neg : I → I := rec i₁ i₀ seg⁻¹ 37 | noncomputable instance : Neg I := ⟨neg⟩ 38 | 39 | hott definition min (a b : I) : I := 40 | lift (λ | false => i₀ | true => a) intervalProp b 41 | 42 | hott definition max (a b : I) : I := 43 | lift (λ | false => a | true => i₁) intervalProp b 44 | 45 | infix:70 " ∧ " => min 46 | infix:70 " ∨ " => max 47 | 48 | hott abbreviation elim {A : Type u} {a b : A} (p : a = b) : I → A := rec a b p 49 | 50 | hott definition lam {A : Type u} (f : I → A) : f 0 = f 1 := ap f seg 51 | 52 | hott lemma mapExt {A : Type u} (f : I → A) : rec (f 0) (f 1) (ap f seg) ~ f := 53 | begin 54 | fapply ind; reflexivity; reflexivity; apply Id.trans; 55 | apply Equiv.transportOverHmtpy; transitivity; apply ap (· ⬝ _); 56 | transitivity; apply Id.rid; transitivity; apply Id.mapInv; 57 | apply ap; apply recβrule; apply Id.invComp 58 | end 59 | 60 | hott definition connAnd {A : Type u} {a b : A} 61 | (p : a = b) : Π i, a = elim p i := 62 | λ i, lam (λ j, elim p (i ∧ j)) 63 | 64 | hott definition cong {A : Type u} {B : Type v} {a b : A} 65 | (f : A → B) (p : a = b) : f a = f b := 66 | lam (λ i, f (elim p i)) 67 | 68 | hott lemma congRefl {A : Type u} {B : Type v} 69 | {a : A} (f : A → B) : cong f (idp a) = idp (f a) := 70 | begin 71 | transitivity; apply mapOverComp; 72 | transitivity; apply ap; 73 | apply recβrule; reflexivity 74 | end 75 | 76 | hott lemma mapEqCong {A : Type u} {B : Type v} {a b : A} 77 | (f : A → B) (p : a = b) : ap f p = cong f p := 78 | begin induction p; symmetry; apply congRefl end 79 | 80 | hott lemma negNeg : Π x, neg (neg x) = x := 81 | ind (idp i₀) (idp i₁) (calc 82 | transport (λ x, neg (neg x) = x) seg (idp i₀) = 83 | (@ap I I i₁ i₀ (neg ∘ neg) seg⁻¹) ⬝ idp i₀ ⬝ seg : 84 | by apply transportOverInvolution 85 | ... = ap neg (ap neg seg⁻¹) ⬝ idp i₀ ⬝ seg : 86 | begin apply ap (λ p, p ⬝ idp i₀ ⬝ seg); 87 | apply mapOverComp end 88 | ... = ap neg (ap neg seg)⁻¹ ⬝ idp i₀ ⬝ seg : 89 | begin apply ap (λ p, p ⬝ idp i₀ ⬝ seg); 90 | apply ap; apply Id.mapInv end 91 | ... = ap neg seg⁻¹⁻¹ ⬝ idp i₀ ⬝ seg : 92 | begin apply ap (λ p, p ⬝ idp i₀ ⬝ seg); 93 | apply ap; apply ap Types.Id.symm; 94 | apply recβrule end 95 | ... = ap neg seg ⬝ idp i₀ ⬝ seg : 96 | begin apply ap (λ (p : i₀ = i₁), ap neg p ⬝ idp i₀ ⬝ seg); 97 | apply Id.invInv end 98 | ... = seg⁻¹ ⬝ idp i₀ ⬝ seg : 99 | begin apply ap (· ⬝ idp i₀ ⬝ seg); 100 | apply recβrule end 101 | ... = seg⁻¹ ⬝ seg : 102 | begin apply ap (· ⬝ seg); 103 | apply Id.rid end 104 | ... = idp i₁ : by apply Id.invComp) 105 | 106 | hott lemma negNeg' (x : I) : neg (neg x) = x := 107 | (connAnd seg⁻¹ (neg x))⁻¹ ⬝ contrRight x 108 | 109 | hott definition twist : I ≃ I := 110 | ⟨neg, ⟨⟨neg, negNeg'⟩, ⟨neg, negNeg'⟩⟩⟩ 111 | 112 | hott corollary lineRec {A : Type u} (f : I → A) : rec (f 0) (f 1) (ap f seg) = f := 113 | begin apply Theorems.funext; apply mapExt; end 114 | 115 | hott lemma transportOverSeg {A : Type u} (B : A → Type v) {a b : A} (p : a = b) (u : B a) : 116 | @transport I (λ i, B (elim p i)) 0 1 seg u = transport B p u := 117 | begin 118 | transitivity; apply transportComp; 119 | transitivity; apply ap (transport B · u); 120 | apply recβrule; reflexivity 121 | end 122 | 123 | hott corollary transportconstWithSeg {A B : Type u} (p : A = B) (x : A) : 124 | @transport I (elim p) 0 1 seg x = transportconst p x := 125 | by apply transportOverSeg id 126 | end Interval 127 | 128 | end HITs 129 | end GroundZero 130 | -------------------------------------------------------------------------------- /GroundZero/HITs/Join.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Suspension 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types 6 | open GroundZero.Proto 7 | open Prod (pr₁ pr₂) 8 | 9 | /- 10 | Join. 11 | * HoTT 6.8 12 | -/ 13 | 14 | namespace GroundZero.HITs 15 | 16 | universe u v w u' v' w' 17 | 18 | hott definition Join (A : Type u) (B : Type v) := 19 | @Pushout A B (A × B) pr₁ pr₂ 20 | 21 | infixl:70 " ∗ " => Join 22 | 23 | namespace Join 24 | variable {A : Type u} {B : Type v} 25 | 26 | hott definition inl : A → A ∗ B := Pushout.inl 27 | hott definition inr : B → A ∗ B := Pushout.inr 28 | 29 | hott definition glue (a : A) (b : B) : inl a = inr b := 30 | Pushout.glue (a, b) 31 | 32 | hott definition ind {C : A ∗ B → Type w} 33 | (inlπ : Π (x : A), C (inl x)) (inrπ : Π (x : B), C (inr x)) 34 | (pushπ : Π (a : A) (b : B), inlπ a =[glue a b] inrπ b) : Π x, C x := 35 | Pushout.ind inlπ inrπ (λ w, pushπ w.1 w.2) 36 | 37 | attribute [induction_eliminator] ind 38 | 39 | hott definition rec {C : Type w} (f : A → C) (g : B → C) (H : Π a b, f a = g b) : A ∗ B → C := 40 | Pushout.rec f g (λ w, H w.1 w.2) 41 | 42 | hott definition recβrule {C : Type w} (f : A → C) (g : B → C) (H : Π a b, f a = g b) (a : A) (b : B) : 43 | ap (rec f g H) (glue a b) = H a b := 44 | by apply Pushout.recβrule 45 | 46 | hott definition fromSusp : ∑ A → 𝟐 ∗ A := 47 | Suspension.rec (inl false) (inl true) (λ x, glue false x ⬝ (glue true x)⁻¹) 48 | 49 | hott definition toSusp : 𝟐 ∗ A → ∑ A := 50 | rec (λ | false => Suspension.north 51 | | true => Suspension.south) 52 | (λ _, Suspension.south) 53 | (λ | false => Suspension.merid 54 | | true => λ _, idp _) 55 | end Join 56 | 57 | end GroundZero.HITs 58 | -------------------------------------------------------------------------------- /GroundZero/HITs/Merely.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Generalized 2 | import GroundZero.HITs.Colimit 3 | import GroundZero.Structures 4 | 5 | open GroundZero.Types.Equiv (transport apd pathoverFromTrans) 6 | open GroundZero.Structures 7 | open GroundZero.Types.Id 8 | open GroundZero.Types 9 | 10 | namespace GroundZero.HITs 11 | universe u v w 12 | 13 | /- 14 | Propositional truncation is colimit of a following sequence: 15 | A → {A} → {{A}} → ... 16 | 17 | * https://github.com/fpvandoorn/leansnippets/blob/master/truncation.hlean 18 | * https://github.com/fpvandoorn/leansnippets/blob/master/cpp.hlean (we use this proof here) 19 | * https://homotopytypetheory.org/2015/07/28/constructing-the-propositional-truncation-using-nonrecursive-hits/ 20 | * https://homotopytypetheory.org/2016/01/08/colimits-in-hott/ 21 | * https://arxiv.org/pdf/1512.02274 22 | -/ 23 | 24 | hott definition Merely (A : Type u) := 25 | Colimit (Generalized.rep A) (Generalized.dep A) 26 | 27 | notation "∥" A "∥" => Merely A 28 | 29 | namespace Merely 30 | hott definition elem {A : Type u} (x : A) : ∥A∥ := 31 | Colimit.inclusion 0 x 32 | 33 | -- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/absolute.20value 34 | macro:max atomic("|" noWs) x:term noWs "|" : term => `(Merely.elem $x) 35 | 36 | section 37 | variable {A : Type u} {B : ∥A∥ → Type v} (elemπ : Π x, B (elem x)) (uniqπ : Π x, prop (B x)) 38 | 39 | hott definition resp : Π (n : ℕ) (x : Generalized.rep A n), B (Colimit.incl x) 40 | | Nat.zero, x => elemπ x 41 | | Nat.succ n, w => @Generalized.ind _ (λ x, B (Colimit.inclusion (n + 1) x)) 42 | (λ x, transport B (Colimit.glue x)⁻¹ (resp n x)) 43 | (λ a b, uniqπ _ _ _) w 44 | 45 | hott definition ind : Π x, B x := 46 | Colimit.ind (resp elemπ uniqπ) (λ _ _, uniqπ _ _ _) 47 | end 48 | 49 | attribute [induction_eliminator] ind 50 | 51 | hott definition rec {A : Type u} {B : Type v} (H : prop B) (f : A → B) : ∥A∥ → B := 52 | ind f (λ _, H) 53 | 54 | hott lemma weakUniq {A : Type u} (x y : A) : @Id ∥A∥ |x| |y| := 55 | begin 56 | transitivity; { symmetry; apply Colimit.glue }; symmetry; 57 | transitivity; { symmetry; apply Colimit.glue }; 58 | apply ap; apply Generalized.glue 59 | end 60 | 61 | hott definition incl {A : Type u} {n : ℕ} := 62 | @Colimit.incl (Generalized.rep A) (Generalized.dep A) n 63 | 64 | hott definition glue {A : Type u} {n : ℕ} {x : Generalized.rep A n} : 65 | incl (Generalized.dep A n x) = incl x := 66 | Colimit.glue x 67 | 68 | hott definition exactNth {A : Type u} (a : A) : Π n, Generalized.rep A n 69 | | Nat.zero => a 70 | | Nat.succ n => Generalized.dep A n (exactNth a n) 71 | 72 | hott definition nthGlue {A : Type u} (a : A) : Π n, incl (exactNth a n) = @incl A 0 a 73 | | Nat.zero => idp _ 74 | | Nat.succ n => Colimit.glue (exactNth a n) ⬝ nthGlue a n 75 | 76 | hott lemma inclUniq {A : Type u} {n : ℕ} (a b : Generalized.rep A n) := 77 | calc incl a = incl (Generalized.dep A n a) : glue⁻¹ 78 | ... = incl (Generalized.dep A n b) : ap incl (Generalized.glue a b) 79 | ... = incl b : glue 80 | 81 | hott lemma inclZeroEqIncl {A : Type u} {n : ℕ} (x : A) (y : Generalized.rep A n) := 82 | calc @incl A 0 x = incl (exactNth x n) : (nthGlue x n)⁻¹ 83 | ... = incl y : inclUniq (exactNth x n) y 84 | 85 | hott theorem weaklyConstantAp {A : Type u} {B : Type v} (f : A → B) 86 | {a b : A} (p q : a = b) (H : Π a b, f a = f b) : ap f p = ap f q := 87 | let L : Π {u v : A} (r : u = v), (H a u)⁻¹ ⬝ H a v = ap f r := 88 | begin intros u v r; induction r; apply Types.Id.invComp end; (L p)⁻¹ ⬝ L q 89 | 90 | hott lemma congClose {A : Type u} {n : ℕ} {a b : Generalized.rep A n} (p : a = b) : 91 | glue⁻¹ ⬝ ap incl (ap (Generalized.dep A n) p) ⬝ glue = ap incl p := 92 | begin 93 | induction p; transitivity; symmetry; apply Id.assoc; 94 | apply Equiv.rewriteComp; symmetry; apply Id.rid 95 | end 96 | 97 | hott theorem congOverPath {A : Type u} {n : ℕ} {a b : Generalized.rep A n} 98 | (p q : a = b) : ap incl p = ap incl q := 99 | weaklyConstantAp incl p q inclUniq 100 | 101 | hott lemma glueClose {A : Type u} {n : ℕ} {a b : Generalized.rep A n} : 102 | glue⁻¹ ⬝ ap incl (Generalized.glue (Generalized.dep A n a) (Generalized.dep A n b)) ⬝ glue 103 | = ap incl (Generalized.glue a b) := 104 | begin 105 | symmetry; transitivity; { symmetry; apply @congClose A (n + 1) _ _ (Generalized.glue a b) }; 106 | apply ap (· ⬝ glue); apply ap; apply congOverPath 107 | end 108 | 109 | hott lemma inclUniqClose {A : Type u} {n : ℕ} (a b : Generalized.rep A n) : 110 | glue⁻¹ ⬝ inclUniq (Generalized.dep A n a) (Generalized.dep A n b) ⬝ glue = inclUniq a b := 111 | ap (· ⬝ glue) (ap _ glueClose) 112 | 113 | hott theorem uniq {A : Type u} : prop ∥A∥ := 114 | begin 115 | apply lemContr; fapply ind; 116 | { intro x; existsi elem x; fapply Colimit.ind <;> intros n y; 117 | { apply inclZeroEqIncl }; 118 | { apply pathoverFromTrans; symmetry; transitivity; 119 | apply ap (_ ⬝ ·); symmetry; apply inclUniqClose; 120 | symmetry; transitivity; apply ap (· ⬝ _ ⬝ _); apply Id.explodeInv; 121 | transitivity; symmetry; apply Id.assoc; 122 | transitivity; symmetry; apply Id.assoc; 123 | apply ap ((nthGlue x n)⁻¹ ⬝ ·); apply Id.assoc } }; 124 | { intro x; apply contrIsProp } 125 | end 126 | 127 | hott corollary hprop {A : Type u} : is-(−1)-type ∥A∥ := 128 | minusOneEqvProp.left uniq 129 | 130 | hott definition lift {A : Type u} {B : Type v} (f : A → B) : ∥A∥ → ∥B∥ := 131 | rec uniq (elem ∘ f) 132 | 133 | hott definition rec₂ {A : Type u} {B : Type v} {γ : Type w} (H : prop γ) 134 | (φ : A → B → γ) : ∥A∥ → ∥B∥ → γ := 135 | @rec A (∥B∥ → γ) (implProp H) (rec H ∘ φ) 136 | 137 | hott definition lift₂ {A : Type u} {B : Type v} {γ : Type w} 138 | (φ : A → B → γ) : ∥A∥ → ∥B∥ → ∥γ∥ := 139 | rec₂ uniq (λ a b, |φ a b|) 140 | 141 | hott theorem equivIffTrunc {A B : Type u} (f : A → B) (g : B → A) : ∥A∥ ≃ ∥B∥ := 142 | ⟨lift f, (⟨lift g, λ _, uniq _ _⟩, ⟨lift g, λ _, uniq _ _⟩)⟩ 143 | 144 | hott definition diag {A : Type u} (a : A) : A × A := ⟨a, a⟩ 145 | 146 | hott corollary productIdentity {A : Type u} : ∥A∥ ≃ ∥A × A∥ := 147 | equivIffTrunc diag Prod.fst 148 | 149 | hott corollary uninhabitedImpliesTruncUninhabited {A : Type u} : ¬A → ¬∥A∥ := 150 | rec Structures.emptyIsProp 151 | end Merely 152 | 153 | end GroundZero.HITs 154 | -------------------------------------------------------------------------------- /GroundZero/HITs/Moebius.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Circle 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero 5 | 6 | namespace GroundZero.HITs 7 | open GroundZero.Types GroundZero.HITs.Interval 8 | 9 | universe u v 10 | 11 | hott definition M : S¹ → Type := Circle.rec I (ua Interval.twist) 12 | hott definition moebius := Σ b, M b 13 | 14 | hott definition cylinder := S¹ × I 15 | 16 | hott definition C : S¹ → Type := Circle.rec I (idp I) 17 | hott definition cylinder' := Σ b, C b 18 | 19 | hott definition C.const : Π x, C x = I := 20 | begin 21 | intro x; induction x; reflexivity; change _ = _; 22 | transitivity; apply Equiv.transportOverContrMap; 23 | transitivity; apply ap (· ⬝ idp I); 24 | transitivity; apply Id.mapInv; apply ap; 25 | apply Circle.recβrule₂; reflexivity 26 | end 27 | 28 | hott definition cylEqv : cylinder' ≃ cylinder := 29 | begin 30 | transitivity; 31 | { apply Equiv.idtoeqv; apply ap; 32 | apply Theorems.funext; exact C.const }; 33 | { apply Sigma.const } 34 | end 35 | 36 | end GroundZero.HITs 37 | -------------------------------------------------------------------------------- /GroundZero/HITs/Pushout.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Quotient 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types 6 | 7 | /- 8 | Pushout. 9 | * HoTT 6.8 10 | -/ 11 | 12 | namespace GroundZero 13 | namespace HITs 14 | 15 | universe u v w k 16 | 17 | section 18 | variable {A : Type u} {B : Type v} {C : Type k} (f : C → A) (g : C → B) 19 | 20 | inductive Pushout.rel : Sum A B → Sum A B → Type k 21 | | mk : Π (x : C), rel (Sum.inl (f x)) (Sum.inr (g x)) 22 | 23 | hott definition Pushout := Quotient (Pushout.rel f g) 24 | end 25 | 26 | namespace Pushout 27 | -- https://github.com/leanprover/lean2/blob/master/hott/hit/Pushout.hlean 28 | variable {A : Type u} {B : Type v} {C : Type k} {f : C → A} {g : C → B} 29 | 30 | hott definition inl (x : A) : Pushout f g := 31 | Quotient.elem (Sum.inl x) 32 | 33 | hott definition inr (x : B) : Pushout f g := 34 | Quotient.elem (Sum.inr x) 35 | 36 | hott definition glue (x : C) : @inl _ _ _ f g (f x) = inr (g x) := 37 | Quotient.line (Pushout.rel.mk x) 38 | 39 | hott definition ind {P : Pushout f g → Type w} (inlπ : Π x, P (inl x)) (inrπ : Π x, P (inr x)) 40 | (glueπ : Π x, inlπ (f x) =[glue x] inrπ (g x)) : Π x, P x := 41 | begin 42 | fapply Quotient.ind; { intro x; induction x using Sum.casesOn; apply inlπ; apply inrπ }; 43 | { intros u v H; induction H using rel.casesOn; apply glueπ } 44 | end 45 | 46 | attribute [induction_eliminator] ind 47 | 48 | hott definition rec {D : Type w} (inlπ : A → D) (inrπ : B → D) 49 | (glueπ : Π x, inlπ (f x) = inrπ (g x)) : Pushout f g → D := 50 | ind inlπ inrπ (λ x, pathoverOfEq (glue x) (glueπ x)) 51 | 52 | hott definition indβrule {P : Pushout f g → Type w} 53 | (inlπ : Π x, P (inl x)) (inrπ : Π x, P (inr x)) 54 | (glueπ : Π x, inlπ (f x) =[glue x] inrπ (g x)) (x : C) : 55 | apd (ind inlπ inrπ glueπ) (glue x) = glueπ x := 56 | @Quotient.indβrule _ (rel f g) _ _ _ _ _ (rel.mk x) 57 | 58 | hott definition recβrule {D : Type w} (inlπ : A → D) (inrπ : B → D) 59 | (glueπ : Π x, inlπ (f x) = inrπ (g x)) (x : C) : 60 | ap (rec inlπ inrπ glueπ) (glue x) = glueπ x := 61 | begin 62 | apply pathoverOfEqInj (glue x); transitivity; 63 | symmetry; apply apdOverConstantFamily; 64 | transitivity; apply indβrule; reflexivity 65 | end 66 | end Pushout 67 | 68 | end HITs 69 | end GroundZero 70 | -------------------------------------------------------------------------------- /GroundZero/HITs/Quotient.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.HEq 2 | 3 | open GroundZero.Types.Equiv (apd) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Types 6 | 7 | namespace GroundZero.HITs 8 | universe u v w 9 | 10 | inductive Quotient.rel {A : Type u} (R : A → A → Type v) : A → A → Prop 11 | | line {n m : A} : R n m → rel R n m 12 | 13 | hott axiom Quotient {A : Type u} (R : A → A → Type v) : Type (max u v) := 14 | Resize.{u, v} (Quot (Quotient.rel R)) 15 | 16 | namespace Quotient 17 | hott axiom elem {A : Type u} {R : A → A → Type w} : A → Quotient R := 18 | Resize.intro ∘ Quot.mk (rel R) 19 | 20 | hott opaque axiom line {A : Type u} {R : A → A → Type w} {x y : A} 21 | (H : R x y) : @elem A R x = @elem A R y := 22 | trustHigherCtor (congrArg Resize.intro (Quot.sound (rel.line H))) 23 | 24 | hott axiom rec {A : Type u} {B : Type v} {R : A → A → Type w} 25 | (f : A → B) (H : Π x y, R x y → f x = f y) : Quotient R → B := 26 | λ x, Quot.withUseOf H (Quot.lift f (λ a b, λ (rel.line ε), elimEq (H a b ε)) x.elim) x.elim 27 | 28 | @[induction_eliminator] hott axiom ind {A : Type u} {R : A → A → Type v} {B : Quotient R → Type w} 29 | (f : Π x, B (elem x)) (ε : Π x y H, f x =[line H] f y) : Π x, B x := 30 | λ x, Quot.withUseOf ε (@Quot.hrecOn A (rel R) (B ∘ Resize.intro) x.elim f 31 | (λ a b, λ (rel.line H), HEq.fromPathover (line H) (ε a b H))) x.elim 32 | 33 | hott opaque axiom recβrule {A : Type u} {B : Type v} {R : A → A → Type w} 34 | (f : A → B) (ε : Π x y, R x y → f x = f y) {x y : A} 35 | (g : R x y) : ap (rec f ε) (line g) = ε x y g := 36 | trustCoherence 37 | 38 | hott opaque axiom indβrule {A : Type u} {R : A → A → Type v} {B : Quotient R → Type w} 39 | (f : Π x, B (elem x)) (ε : Π x y H, f x =[line H] f y) 40 | {x y : A} (g : R x y) : apd (ind f ε) (line g) = ε x y g := 41 | trustCoherence 42 | 43 | attribute [irreducible] Quotient 44 | 45 | section 46 | variable {A : Type u} {R : A → A → Type v} {B : Quotient R → Type w} 47 | (f : Π x, B (elem x)) (ε₁ ε₂ : Π x y H, f x =[line H] f y) 48 | 49 | #failure ind f ε₁ ≡ ind f ε₂ 50 | end 51 | 52 | section 53 | variable {A : Type u} {R : A → A → Type v} {B : Type w} 54 | (f : A → B) (ε₁ ε₂ : Π x y, R x y → f x = f y) 55 | 56 | #failure rec f ε₁ ≡ rec f ε₂ 57 | end 58 | end Quotient 59 | 60 | end GroundZero.HITs 61 | -------------------------------------------------------------------------------- /GroundZero/HITs/Reals.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Circle 2 | 3 | open GroundZero.Theorems.Functions (injective) 4 | open GroundZero.Theorems (funext) 5 | open GroundZero.Types.Equiv 6 | open GroundZero.HITs.Circle 7 | open GroundZero.Structures 8 | open GroundZero.Types.Id 9 | open GroundZero.Types 10 | open GroundZero.Proto 11 | open GroundZero 12 | 13 | /- 14 | Homotopical Reals R. 15 | * HoTT 8.1.5 16 | -/ 17 | 18 | namespace GroundZero.HITs 19 | universe u v w 20 | 21 | inductive Reals.rel : ℤ → ℤ → Type 22 | | glue (x : ℤ) : rel x (Integer.succ x) 23 | 24 | hott definition Reals := Quotient Reals.rel 25 | 26 | hott definition R := Reals 27 | 28 | namespace Reals 29 | hott definition elem : ℤ → R := Quotient.elem 30 | 31 | hott definition glue (z : ℤ) : elem z = elem (Integer.succ z) := 32 | Quotient.line (rel.glue z) 33 | 34 | hott definition indρ {C : R → Type u} (cz : Π x, C (elem x)) 35 | (sz : Π z, cz z =[glue z] cz (Integer.succ z)) 36 | (x y : ℤ) (ρ : rel x y) : cz x =[Quotient.line ρ] cz y := 37 | begin induction ρ using rel.casesOn; apply sz end 38 | 39 | hott definition ind {C : R → Type u} (cz : Π x, C (elem x)) 40 | (sz : Π z, cz z =[glue z] cz (Integer.succ z)) (u : R) : C u := 41 | Quotient.ind cz (indρ cz sz) u 42 | 43 | attribute [induction_eliminator] ind 44 | 45 | hott definition indβrule {C : R → Type u} 46 | (cz : Π x, C (elem x)) (sz : Π z, cz z =[glue z] cz (Integer.succ z)) 47 | (z : ℤ) : Equiv.apd (ind cz sz) (glue z) = sz z := 48 | @Quotient.indβrule _ _ C cz (indρ cz sz) _ _ (rel.glue z) 49 | 50 | hott definition rec {A : Type u} (cz : ℤ → A) 51 | (sz : Π z, cz z = cz (Integer.succ z)) : R → A := 52 | ind cz (λ x, Equiv.pathoverOfEq (glue x) (sz x)) 53 | 54 | hott definition recβrule {A : Type u} (cz : ℤ → A) 55 | (sz : Π z, cz z = cz (Integer.succ z)) (z : ℤ) : 56 | ap (rec cz sz) (glue z) = sz z := 57 | begin 58 | apply Equiv.pathoverOfEqInj (glue z); transitivity; 59 | symmetry; apply Equiv.apdOverConstantFamily; 60 | transitivity; apply indβrule; reflexivity 61 | end 62 | 63 | hott definition positive : Π n, elem 0 = elem (Integer.pos n) 64 | | Nat.zero => idp (elem 0) 65 | | Nat.succ n => positive n ⬝ glue (Integer.pos n) 66 | 67 | hott definition negative : Π n, elem 0 = elem (Integer.neg n) 68 | | Nat.zero => (glue (Integer.neg 0))⁻¹ 69 | | Nat.succ n => negative n ⬝ (glue (Integer.neg (n + 1)))⁻¹ 70 | 71 | hott definition center : Π z, elem 0 = elem z 72 | | Integer.pos n => positive n 73 | | Integer.neg n => negative n 74 | 75 | hott definition vect (u v : ℤ) : elem u = elem v := 76 | (center u)⁻¹ ⬝ center v 77 | 78 | hott theorem contractible : contr R := 79 | ⟨elem 0, @ind (elem 0 = ·) center (begin 80 | intro z; change _ = _; transitivity; 81 | apply Equiv.transportComposition; match z with 82 | | Integer.pos _ => reflexivity; 83 | | Integer.neg n => _; 84 | induction n using Nat.casesOn; apply Id.invComp; 85 | { transitivity; symmetry; apply Id.assoc; 86 | transitivity; apply ap; apply Id.invComp; 87 | apply Id.rid } 88 | end)⟩ 89 | 90 | hott definition dist : Π (u v : R), u = v := 91 | Structures.contrImplProp contractible 92 | 93 | hott definition lift (f : ℤ → ℤ) : R → R := 94 | rec (elem ∘ f) (λ _, dist _ _) 95 | 96 | noncomputable instance (n : ℕ) : OfNat R n := ⟨elem (Integer.pos n)⟩ 97 | 98 | section 99 | variable {A : Type⁎} (H : prop A.space) 100 | variable (φ : Map⁎ A ⟨S¹, base⟩) 101 | 102 | hott lemma helixOverHomo (x : A.1) : helix (φ.ap x) = ℤ := 103 | begin 104 | transitivity; apply ap (helix ∘ φ.ap); 105 | apply H x A.point; change _ = helix base; 106 | apply ap helix; apply φ.id 107 | end 108 | 109 | hott lemma fibOfHomo (x : S¹) := calc 110 | fib φ.ap x ≃ Σ (z : A.1), φ.ap z = x : Equiv.ideqv (fib φ.ap x) 111 | ... = Σ (z : A.1), φ.ap A.point = x : ap Sigma (funext (λ z, ap (φ.ap · = x) (H z A.point))) 112 | ... = Σ (z : A.1), base = x : ap Sigma (funext (λ _, ap (· = x) φ.id)) 113 | ... = Σ (z : A.1), helix x : ap Sigma (funext (λ _, GroundZero.ua (Circle.family x))) 114 | ... ≃ A.1 × (helix x) : Sigma.const A.1 (helix x) 115 | ... ≃ 𝟏 × (helix x) : productEquiv₃ (contrEquivUnit.{_, 0} ⟨A.point, H A.point⟩) (Equiv.ideqv (helix x)) 116 | ... ≃ helix x : prodUnitEquiv (helix x) 117 | 118 | hott corollary kerOfHomo : fib φ.ap base ≃ ℤ := 119 | fibOfHomo H φ base 120 | end 121 | 122 | /- 123 | ≃ 124 | S¹ ←–––– R/τℤ 125 | ↑ ↑ 126 | eⁱ⁻ | | 127 | | | 128 | R ════════ R 129 | -/ 130 | hott definition cis : R → S¹ := rec (λ _, base) (λ _, loop) 131 | 132 | hott theorem Euler : fib cis base ≃ ℤ := 133 | @kerOfHomo _ ⟨R, 0⟩ dist ⟨cis, idp base⟩ 134 | 135 | -- Another (more tricky) proof, but it does not use R contractibility 136 | hott lemma helixOverCis (x : R) : helix (cis x) = ℤ := 137 | begin 138 | induction x; 139 | { case cz x => apply (Integer.shift x)⁻¹ }; 140 | { case sz z => 141 | change _ = _; let p := Integer.shift z; apply calc 142 | Equiv.transport (λ x, helix (cis x) = ℤ) (glue z) (Integer.shift z)⁻¹ 143 | = @ap R Type _ _ (helix ∘ cis) (glue z)⁻¹ ⬝ (Integer.shift z)⁻¹ : 144 | Equiv.transportOverContrMap _ _ _ 145 | ... = (ap (helix ∘ cis) (glue z))⁻¹ ⬝ (Integer.shift z)⁻¹ : 146 | ap (· ⬝ p⁻¹) (Id.mapInv _ _) 147 | ... = (ap helix (ap cis (glue z)))⁻¹ ⬝ (Integer.shift z)⁻¹ : 148 | ap (·⁻¹ ⬝ p⁻¹) (Equiv.mapOverComp _ _ _) 149 | ... = (ap helix loop)⁻¹ ⬝ (Integer.shift z)⁻¹ : 150 | begin apply ap (·⁻¹ ⬝ p⁻¹); apply ap; apply recβrule end 151 | ... = Integer.succPath⁻¹ ⬝ (Integer.shift z)⁻¹ : 152 | begin apply ap (·⁻¹ ⬝ p⁻¹); apply Circle.recβrule₂ end 153 | ... = (Integer.shift z ⬝ Integer.succPath)⁻¹ : 154 | (Id.explodeInv _ _)⁻¹ 155 | ... = (Integer.shift (Integer.succ z))⁻¹ : 156 | ap _ (Integer.shiftComp _) 157 | } 158 | end 159 | 160 | hott lemma phiEqvBaseImplContr {A : Type u} {x : A} 161 | (H : Π (φ : A → S¹), φ x = base) : contr S¹ := 162 | ⟨base, λ y, (H (λ _, y))⁻¹⟩ 163 | 164 | hott lemma phiNeqBaseImplFalse {A : Type u} {x : A} (φ : A → S¹) : ¬¬(φ x = base) := 165 | begin induction φ x; intro p; apply p; reflexivity; apply implProp; apply emptyIsProp end 166 | 167 | hott lemma lemInfImplDnegInf (H : LEM∞) {A : Type u} (G : ¬¬A) : A := 168 | match H A with 169 | | Sum.inl x => x 170 | | Sum.inr y => explode (G y) 171 | 172 | hott remark circleNotHset : ¬(hset S¹) := 173 | begin intro H; apply Circle.loopNeqRefl; apply H end 174 | 175 | hott proposition lemInfDisproved : ¬LEM∞ := 176 | begin 177 | intro H; apply circleNotHset; apply propIsSet; apply contrImplProp; 178 | apply phiEqvBaseImplContr; intro φ; apply lemInfImplDnegInf H; 179 | apply phiNeqBaseImplFalse φ; exact R; exact 0 180 | end 181 | end Reals 182 | 183 | end GroundZero.HITs 184 | -------------------------------------------------------------------------------- /GroundZero/HITs/Setquot.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Trunc 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Structures 6 | open GroundZero.Theorems 7 | open GroundZero.Types 8 | open GroundZero 9 | 10 | namespace GroundZero.HITs 11 | universe u v w u' v' w' 12 | 13 | hott definition Setquot {A : Type u} (R : A → A → Prop v) := ∥Quotient (λ x y, (R x y).1)∥₀ 14 | 15 | hott definition Setquot.elem {A : Type u} {R : A → A → Prop v} : A → Setquot R := 16 | Trunc.elem ∘ Quotient.elem 17 | 18 | hott definition Setquot.sound {A : Type u} {R : A → A → Prop v} {a b : A} : 19 | (R a b).1 → @Id (Setquot R) (Setquot.elem a) (Setquot.elem b) := 20 | begin intro; dsimp [Setquot.elem]; apply ap Trunc.elem; apply Quotient.line; assumption end 21 | 22 | hott lemma Setquot.set {A : Type u} {R : A → A → Prop v} : hset (Setquot R) := 23 | zeroEqvSet.forward (Trunc.uniq 0) 24 | 25 | hott definition Setquot.ind {A : Type u} {R : A → A → Prop u'} {π : Setquot R → Type v} 26 | (elemπ : Π x, π (Setquot.elem x)) 27 | (lineπ : Π x y H, elemπ x =[Setquot.sound H] elemπ y) 28 | (set : Π x, hset (π x)) : Π x, π x := 29 | begin 30 | fapply Trunc.ind; 31 | { fapply Quotient.ind; apply elemπ; 32 | { intros x y H; apply Id.trans; 33 | apply transportComp; 34 | apply lineπ } }; 35 | { intro; apply zeroEqvSet.left; apply set } 36 | end 37 | 38 | attribute [induction_eliminator] Setquot.ind 39 | 40 | hott definition Setquot.rec {A : Type u} {R : A → A → Prop u'} {B : Type v} 41 | (elemπ : A → B) (lineπ : Π x y, (R x y).fst → elemπ x = elemπ y) (set : hset B) : Setquot R → B := 42 | @Setquot.ind A R (λ _, B) elemπ (λ x y H, pathoverOfEq (Setquot.sound H) (lineπ x y H)) (λ _, set) 43 | 44 | hott definition Setquot.lift₂ {A : Type u} {R₁ : A → A → Prop u'} {B : Type v} {R₂ : B → B → Prop v'} 45 | {γ : Type w} (R₁refl : Π x, (R₁ x x).fst) (R₂refl : Π x, (R₂ x x).fst) (f : A → B → γ) 46 | (h : hset γ) (p : Π a₁ a₂ b₁ b₂, (R₁ a₁ b₁).fst → (R₂ a₂ b₂).fst → f a₁ a₂ = f b₁ b₂) : Setquot R₁ → Setquot R₂ → γ := 47 | begin 48 | fapply @Setquot.rec A R₁ (Setquot R₂ → γ); 49 | { intro x; fapply Setquot.rec; exact f x; 50 | { intros y₁ y₂ H; apply p; apply R₁refl; exact H }; 51 | { assumption } }; 52 | { intros x y H; apply Theorems.funext; fapply Setquot.ind; 53 | { intro z; apply p; assumption; apply R₂refl }; 54 | { intros; apply h }; 55 | { intros; apply Structures.propIsSet; apply h } }; 56 | { apply zeroEqvSet.forward; apply Structures.piRespectsNType 0; 57 | intros; apply zeroEqvSet.left; apply h } 58 | end 59 | 60 | hott definition Relquot {A : Type u} (s : eqrel A) := Setquot s.rel 61 | 62 | hott definition Relquot.elem {A : Type u} {s : eqrel A} : A → Relquot s := 63 | Setquot.elem 64 | 65 | hott definition Relquot.sound {A : Type u} {s : eqrel A} {a b : A} : 66 | s.apply a b → @Id (Relquot s) (Relquot.elem a) (Relquot.elem b) := 67 | Setquot.sound 68 | 69 | hott corollary Relquot.set {A : Type u} {s : eqrel A} : hset (Relquot s) := 70 | by apply Setquot.set 71 | 72 | hott definition Relquot.ind {A : Type u} {s : eqrel A} 73 | {π : Relquot s → Type v} 74 | (elemπ : Π x, π (Relquot.elem x)) 75 | (lineπ : Π x y H, elemπ x =[Relquot.sound H] elemπ y) 76 | (set : Π x, hset (π x)) : Π x, π x := 77 | Setquot.ind elemπ lineπ set 78 | 79 | attribute [induction_eliminator] Relquot.ind 80 | 81 | hott definition Relquot.indProp {A : Type u} {s : eqrel A} 82 | {π : Relquot s → Type v} (elemπ : Π x, π (Relquot.elem x)) 83 | (propπ : Π x, prop (π x)) : Π x, π x := 84 | begin 85 | intro x; induction x; apply elemπ; apply propπ; 86 | apply Structures.propIsSet; apply propπ 87 | end 88 | 89 | hott definition Relquot.rec {A : Type u} {B : Type v} {s : eqrel A} 90 | (elemπ : A → B) 91 | (lineπ : Π x y, s.apply x y → elemπ x = elemπ y) 92 | (set : hset B) : Relquot s → B := 93 | by apply Setquot.rec <;> assumption 94 | 95 | hott definition Relquot.lift₂ {A : Type u} {B : Type v} {γ : Type w} 96 | {s₁ : eqrel A} {s₂ : eqrel B} (f : A → B → γ) (h : hset γ) 97 | (p : Π a₁ a₂ b₁ b₂, s₁.apply a₁ b₁ → s₂.apply a₂ b₂ → f a₁ a₂ = f b₁ b₂) : 98 | Relquot s₁ → Relquot s₂ → γ := 99 | begin 100 | fapply Setquot.lift₂; apply s₁.iseqv.fst; apply s₂.iseqv.fst; 101 | repeat { assumption } 102 | end 103 | 104 | end GroundZero.HITs 105 | -------------------------------------------------------------------------------- /GroundZero/HITs/Suspension.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Pushout 2 | import GroundZero.Types.Unit 3 | 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types.Id 6 | open GroundZero.Types 7 | 8 | /- 9 | Suspension. 10 | * HoTT 6.5 11 | -/ 12 | 13 | namespace GroundZero 14 | namespace HITs 15 | 16 | universe u v w 17 | 18 | hott definition Suspension (A : Type u) := 19 | @Pushout.{0, 0, u} 𝟏 𝟏 A (λ _, ★) (λ _, ★) 20 | 21 | notation "∑ " => Suspension 22 | 23 | namespace Suspension 24 | -- https://github.com/leanprover/lean2/blob/master/hott/homotopy/susp.hlean 25 | 26 | hott definition north {A : Type u} : ∑ A := Pushout.inl ★ 27 | hott definition south {A : Type u} : ∑ A := Pushout.inr ★ 28 | 29 | hott definition merid {A : Type u} (x : A) : @Id (∑ A) north south := 30 | Pushout.glue x 31 | 32 | hott definition ind {A : Type u} {B : ∑ A → Type v} (n : B north) (s : B south) 33 | (m : Π x, n =[merid x] s) : Π x, B x := 34 | Pushout.ind (λ ★, n) (λ ★, s) m 35 | 36 | attribute [induction_eliminator] ind 37 | 38 | hott definition rec {A : Type u} {B : Type v} (n s : B) (m : A → n = s) : ∑ A → B := 39 | Pushout.rec (λ _, n) (λ _, s) m 40 | 41 | hott definition indβrule {A : Type u} {B : ∑ A → Type v} 42 | (n : B north) (s : B south) (m : Π x, n =[merid x] s) (x : A) : 43 | apd (ind n s m) (merid x) = m x := 44 | by apply Pushout.indβrule 45 | 46 | hott definition recβrule {A : Type u} {B : Type v} (n s : B) 47 | (m : A → n = s) (x : A) : ap (rec n s m) (merid x) = m x := 48 | by apply Pushout.recβrule 49 | 50 | noncomputable instance (A : Type u) : isPointed (∑ A) := ⟨north⟩ 51 | 52 | hott definition σ {A : Type u} [isPointed A] : A → Ω¹(∑ A) := 53 | λ x, merid x ⬝ (merid (pointOf A))⁻¹ 54 | 55 | hott lemma σComMerid {A : Type u} [isPointed A] (x : A) : σ x ⬝ merid (pointOf A) = merid x := 56 | by apply Id.cancelInvComp 57 | 58 | hott lemma σRevComMerid {A : Type u} [isPointed A] (x : A) : (σ x)⁻¹ ⬝ merid x = merid (pointOf A) := 59 | begin apply rewriteComp; symmetry; apply σComMerid end 60 | 61 | section 62 | variable {A : Type u} [isPointed A] {n : ℕ} 63 | 64 | hott def suspΩ : Ωⁿ(A) → Ωⁿ⁺¹(∑ A) := 65 | λ ε, conjugateΩ (compInv (merid (pointOf A))) (apΩ σ ε) 66 | 67 | hott lemma suspIdΩ : suspΩ (idΩ (pointOf A) n) = idΩ north (n + 1) := 68 | begin transitivity; apply ap (conjugateΩ _); apply apIdΩ; apply conjugateIdΩ end 69 | 70 | hott lemma suspRevΩ (α : Ωⁿ⁺¹(A)) : suspΩ (revΩ α) = revΩ (suspΩ α) := 71 | begin transitivity; apply ap (conjugateΩ _); apply apRevΩ; apply conjugateRevΩ end 72 | 73 | hott lemma suspMultΩ (α β : Ωⁿ⁺¹(A)) : suspΩ (comΩ α β) = comΩ (suspΩ α) (suspΩ β) := 74 | begin transitivity; apply ap (conjugateΩ _); apply apFunctorialityΩ; apply conjugateComΩ end 75 | end 76 | end Suspension 77 | 78 | end HITs 79 | end GroundZero 80 | -------------------------------------------------------------------------------- /GroundZero/HITs/Trunc.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Merely 2 | 3 | open GroundZero.HITs.Interval (happly funext) 4 | open GroundZero.Structures.hlevel (succ) 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Proto (idfun) 7 | open GroundZero.Types.Equiv 8 | open GroundZero.Structures 9 | open GroundZero.Types 10 | 11 | namespace GroundZero.HITs 12 | universe u v w 13 | 14 | private def Trunc.aux (n : ℕ₋₂) (A : Type u) := Opaque A 15 | 16 | attribute [nothott] Trunc.aux 17 | 18 | hott axiom Trunc : ℕ₋₂ → Type u → Type u 19 | | −2, A => 𝟏 20 | | −1, A => ∥A∥ 21 | | succ (succ n), A => Trunc.aux n A 22 | 23 | namespace Trunc 24 | variable {A : Type u} {n : ℕ₋₂} 25 | 26 | hott axiom elem : Π {n : ℕ₋₂} (x : A), Trunc n A 27 | | −2, _ => ★ 28 | | −1, x => Merely.elem x 29 | | succ (succ n), x => Opaque.intro x 30 | 31 | hott opaque axiom uniq (n : ℕ₋₂) : is-n-type (Trunc n A) := 32 | match n with 33 | | −2 => unitIsContr 34 | | −1 => Merely.hprop 35 | | succ (succ n) => λ _ _, propIsNType (λ _ _, trustCoherence) n 36 | 37 | @[induction_eliminator] hott axiom ind {B : Trunc n A → Type v} (elemπ : Π x, B (elem x)) (uniqπ : Π x, is-n-type (B x)) : Π x, B x := 38 | match n with 39 | | −2 => λ x, (uniqπ x).1 40 | | −1 => Merely.ind elemπ (λ _, minusOneEqvProp.forward (uniqπ _)) 41 | | succ (succ n) => λ x, Quot.withUseOf uniqπ (Opaque.ind elemπ x) x 42 | 43 | attribute [irreducible] Trunc 44 | 45 | notation "∥" A "∥₋₂" => Trunc −2 A 46 | notation "∥" A "∥₋₁" => Trunc −1 A 47 | 48 | macro:max "∥" A:term "∥" n:subscript : term => do 49 | `(Trunc $(← Meta.Notation.parseSubscript n) $A) 50 | 51 | -- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/absolute.20value 52 | macro:max atomic("|" noWs) x:term noWs "|" n:subscript : term => 53 | do `(@Trunc.elem _ $(← Meta.Notation.parseSubscript n) $x) 54 | 55 | hott lemma indβrule {B : ∥A∥ₙ → Type v} (elemπ : Π x, B |x|ₙ) 56 | (uniqπ : Π x, is-n-type (B x)) (x : A) : ind elemπ uniqπ |x|ₙ = elemπ x := 57 | begin 58 | match n with | −2 => _ | −1 => _ | succ (succ n) => _; 59 | apply (uniqπ (elem x)).2; reflexivity; reflexivity 60 | end 61 | 62 | section 63 | variable {B : Type v} (elemπ : A → B) (uniqπ : is-n-type B) 64 | 65 | hott definition rec : ∥A∥ₙ → B := @ind A n (λ _, B) elemπ (λ _, uniqπ) 66 | 67 | hott corollary recβrule (x : A) : rec elemπ uniqπ |x|ₙ = elemπ x := 68 | by apply indβrule 69 | end 70 | 71 | hott definition elemClose {B : Type v} (G : is-n-type B) 72 | (f g : ∥A∥ₙ → B) (H : f ∘ elem = g ∘ elem) : f = g := 73 | begin 74 | apply Theorems.funext; fapply ind <;> intro x; 75 | { exact ap (λ (f : A → B), f x) H }; 76 | { apply hlevel.cumulative; assumption } 77 | end 78 | 79 | hott definition nthTrunc (H : is-n-type A) : A ≃ ∥A∥ₙ := 80 | begin 81 | existsi elem; apply Prod.mk <;> existsi rec id H; 82 | { intro; apply recβrule; }; 83 | { apply Interval.happly; apply elemClose; apply uniq; 84 | apply Theorems.funext; intro; apply ap elem; apply recβrule; } 85 | end 86 | 87 | hott definition setEquiv {A : Type u} (H : hset A) : A ≃ ∥A∥₀ := 88 | begin apply nthTrunc; apply zeroEqvSet.left; assumption end 89 | 90 | hott definition ap {A : Type u} {B : Type v} {n : ℕ₋₂} (f : A → B) : ∥A∥ₙ → ∥B∥ₙ := 91 | rec (elem ∘ f) (uniq n) 92 | 93 | hott definition ap₂ {A : Type u} {B : Type v} {C : Type w} 94 | {n : ℕ₋₂} (f : A → B → C) : ∥A∥ₙ → ∥B∥ₙ → ∥C∥ₙ := 95 | rec (ap ∘ f) (piRespectsNType n (λ _, uniq n)) 96 | 97 | hott corollary apβrule {A : Type u} {B : Type v} {n : ℕ₋₂} 98 | {f : A → B} (a : A) : ap f |a|ₙ = |f a|ₙ := 99 | by apply recβrule 100 | 101 | hott corollary apβrule₂ {A : Type u} {B : Type v} {C : Type w} 102 | {n : ℕ₋₂} {f : A → B → C} (a : A) (b : B) : ap₂ f |a|ₙ |b|ₙ = |f a b|ₙ := 103 | begin transitivity; apply happly; apply recβrule; apply apβrule end 104 | 105 | hott lemma idmap {A : Type u} {n : ℕ₋₂} : ap idfun ~ @idfun ∥A∥ₙ := 106 | begin 107 | fapply ind; intro; apply recβrule; intro; 108 | apply hlevel.cumulative; apply uniq 109 | end 110 | 111 | hott lemma apCom {A : Type u} {B : Type v} {C : Type w} {n : ℕ₋₂} 112 | (f : B → C) (g : A → B) : ap f ∘ ap g ~ @ap A C n (f ∘ g) := 113 | begin 114 | fapply ind; intro; transitivity; apply Id.ap (ap _); 115 | apply recβrule; transitivity; apply recβrule; symmetry; 116 | apply recβrule; intro; apply hlevel.cumulative; apply uniq 117 | end 118 | 119 | hott theorem respectsEquiv {A : Type u} {B : Type v} {n : ℕ₋₂} (φ : A ≃ B) : ∥A∥ₙ ≃ ∥B∥ₙ := 120 | ⟨ap φ.forward, (⟨ap φ.left, (apCom _ _).trans ((happly (Id.ap ap (funext φ.leftForward))).trans idmap)⟩, 121 | ⟨ap φ.right, (apCom _ _).trans ((happly (Id.ap ap (funext φ.forwardRight))).trans idmap)⟩)⟩ 122 | 123 | hott lemma transportOverTrunc {A : Type u} {n : ℕ₋₂} {B : A → Type v} {a b : A} 124 | (p : a = b) (u : ∥B a∥ₙ) : transport (∥B ·∥ₙ) p u = Trunc.ap (transport B p) u := 125 | begin induction p; symmetry; apply Trunc.idmap end 126 | end Trunc 127 | 128 | end GroundZero.HITs 129 | -------------------------------------------------------------------------------- /GroundZero/HITs/Wedge.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Pushout 2 | import GroundZero.Types.Unit 3 | 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types 6 | 7 | /- 8 | Wedge sum. 9 | * HoTT 6.8 10 | -/ 11 | 12 | namespace GroundZero 13 | namespace HITs 14 | 15 | universe u 16 | 17 | hott definition Wedge (A B : Type⁎) := 18 | @Pushout.{_, _, 0} A.1 B.1 𝟏 (λ _, A.2) (λ _, B.2) 19 | 20 | infix:50 " ∨ " => Wedge 21 | 22 | namespace Wedge 23 | variable {A B : Type⁎} 24 | 25 | hott definition inl : A.1 → A ∨ B := Pushout.inl 26 | hott definition inr : B.1 → A ∨ B := Pushout.inr 27 | 28 | hott definition glue : inl A.2 = inr B.2 := 29 | Pushout.glue ★ 30 | 31 | hott definition ind {C : A ∨ B → Type u} (inlπ : Π x, C (inl x)) (inrπ : Π x, C (inr x)) 32 | (glueπ : inlπ A.2 =[glue] inrπ B.2) : Π x, C x := 33 | Pushout.ind inlπ inrπ (λ ★, glueπ) 34 | 35 | attribute [induction_eliminator] ind 36 | 37 | hott definition rec {C : Type u} (inlπ : A.1 → C) (inrπ : B.1 → C) 38 | (glueπ : inlπ A.2 = inrπ B.2) : A ∨ B → C := 39 | Pushout.rec inlπ inrπ (λ ★, glueπ) 40 | end Wedge 41 | 42 | end HITs 43 | end GroundZero 44 | -------------------------------------------------------------------------------- /GroundZero/Meta/Basic.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Meta.HottTheory 2 | import GroundZero.Meta.Notation 3 | import GroundZero.Meta.Tactic -------------------------------------------------------------------------------- /GroundZero/Meta/Tactic.lean: -------------------------------------------------------------------------------- 1 | import Lean.PrettyPrinter.Delaborator.Basic 2 | import Lean.Elab.Tactic.ElabTerm 3 | import Lean.Meta.Tactic.Replace 4 | import Lean.Elab.Command 5 | 6 | open Lean 7 | 8 | universe u v w u' v' w' 9 | 10 | section 11 | variable {A : Sort u} (ρ : A → A → Sort v) 12 | 13 | class Reflexive := 14 | (intro (a : A) : ρ a a) 15 | 16 | class Symmetric := 17 | (intro (a b : A) : ρ a b → ρ b a) 18 | 19 | class Transitive := 20 | (intro (a b c : A) : ρ a b → ρ b c → ρ a c) 21 | end 22 | 23 | section 24 | variable {A : Sort u} {B : Sort v} {C : Sort w} 25 | 26 | variable (ρ : A → B → Sort u') 27 | variable (η : B → C → Sort v') 28 | variable (μ : outParam (A → C → Sort w')) 29 | 30 | class Rewrite := 31 | (intro (a : A) (b : B) (c : C) : ρ a b → η b c → μ a c) 32 | end 33 | 34 | namespace GroundZero.Meta.Tactic 35 | 36 | -- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Tactic/Ring.lean#L411-L419 37 | def applyOnBinRel (name : Name) (rel : Name) : Elab.Tactic.TacticM Unit := do 38 | let mvars ← Elab.Tactic.liftMetaMAtMain (λ mvar => do 39 | let ε ← instantiateMVars (← MVarId.getDecl mvar).type 40 | ε.consumeMData.withApp λ e es => do 41 | unless (es.size > 1) do Meta.throwTacticEx name mvar s!"expected binary relation, got “{e} {es}”" 42 | 43 | let e₃ := es.back!; let es := es.pop; 44 | let e₂ := es.back!; let es := es.pop; 45 | 46 | let ty ← Meta.inferType e₂ 47 | let ty' ← Meta.inferType e₃ 48 | 49 | unless (← Meta.isDefEq ty ty') do Meta.throwTacticEx name mvar s!"{ty} ≠ {ty'}" 50 | 51 | let u ← Meta.getLevel ty 52 | let v ← Meta.getLevel ε 53 | 54 | let ι ← Meta.synthInstance (mkApp2 (Lean.mkConst rel [u, v]) ty (mkAppN e es)) 55 | let φ := (← Meta.reduceProj? (mkProj rel 0 ι)).getD ι 56 | 57 | MVarId.apply mvar φ) 58 | Elab.Tactic.replaceMainGoal mvars 59 | 60 | section 61 | elab "reflexivity" : tactic => applyOnBinRel `reflexivity `Reflexive 62 | elab "symmetry" : tactic => applyOnBinRel `symmetry `Symmetric 63 | elab "transitivity" : tactic => applyOnBinRel `transitivity `Transitive 64 | end 65 | 66 | elab "fapply " e:term : tactic => 67 | Elab.Tactic.evalApplyLikeTactic (MVarId.apply (cfg := {newGoals := Meta.ApplyNewGoals.all})) e 68 | 69 | macro_rules | `(tactic| change $e:term) => `(tactic| show $e) 70 | 71 | -- https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Tactic/LeftRight.lean 72 | -- Author: Siddhartha Gadgil 73 | def getCtors (name : Name) (mvar : MVarId) : MetaM (List Name × List Level) := do 74 | MVarId.checkNotAssigned mvar name 75 | let target ← MVarId.getType' mvar 76 | matchConstInduct target.getAppFn 77 | (λ _ => Meta.throwTacticEx `constructor mvar "target is not an inductive datatype") 78 | (λ ival us => return (ival.ctors, us)) 79 | 80 | def leftRightMeta (pickLeft : Bool) (mvar : MVarId) : MetaM (List MVarId) := do 81 | MVarId.withContext mvar do 82 | let name := if pickLeft then `left else `right 83 | let (ctors, us) ← getCtors name mvar 84 | unless ctors.length == 2 do 85 | Meta.throwTacticEx `constructor mvar 86 | s!"{name} target applies for inductive types with exactly two constructors" 87 | let ctor := ctors.get! (if pickLeft then 0 else 1) 88 | MVarId.apply mvar (mkConst ctor us) 89 | 90 | elab "left" : tactic => Elab.Tactic.liftMetaTactic (leftRightMeta true) 91 | elab "right" : tactic => Elab.Tactic.liftMetaTactic (leftRightMeta false) 92 | 93 | elab "whnf" : tactic => do 94 | let mvarId ← Elab.Tactic.getMainGoal 95 | let target ← Elab.Tactic.getMainTarget 96 | let targetNew ← Meta.whnf target 97 | Elab.Tactic.replaceMainGoal [← MVarId.replaceTargetDefEq mvarId targetNew] 98 | 99 | def getExistsiCtor (mvar : MVarId) : MetaM Name := do 100 | MVarId.withContext mvar do 101 | let (ctors, us) ← getCtors `existsi mvar 102 | unless ctors.length == 1 do 103 | Meta.throwTacticEx `constructor mvar 104 | "existsi target applies for inductive types with exactly one constructor" 105 | return (ctors.get! 0) 106 | 107 | elab "existsi" e:term : tactic => do 108 | let ctor ← Elab.Tactic.liftMetaMAtMain getExistsiCtor 109 | let ε := Syntax.mkApp (mkIdent ctor) #[e] 110 | Elab.Tactic.evalTactic (← `(tactic| apply $ε)) 111 | 112 | -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/How.20to.20use.20hand.20written.20parsers/near/245760023 113 | -- Author: Mario Carneiro 114 | 115 | -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Parser.2EtrailingLoop 116 | def calcLHS : Parser.Parser := 117 | Parser.leadingNode `ellipsis Parser.maxPrec (Parser.symbol "...") >> 118 | Parser.withFn (λ _ c s => let category := (Parser.getCategory (Parser.parserExtension.getState c.env).categories `term).get! 119 | Parser.trailingLoop category.tables c s) Parser.termParser 120 | 121 | open PrettyPrinter Elab.Term 122 | 123 | @[combinator_formatter GroundZero.Meta.Tactic.calcLHS] def calcLHS.formatter : Formatter := pure () 124 | @[combinator_parenthesizer GroundZero.Meta.Tactic.calcLHS] def calcLHS.parenthesizer : Parenthesizer := pure () 125 | 126 | def extRelation (e : Expr) : TermElabM (Expr × Expr) := 127 | e.withApp λ e es => do 128 | unless (es.size > 1) do throwError "expected binary relation" 129 | return (es.back!, mkAppN e es.pop.pop) 130 | 131 | def getEqn (e : Syntax) : TermElabM (Syntax × Syntax) := do 132 | unless (e.getArgs.size > 2) do throwError "expected binary relation" 133 | return (e.getArgs.get! 0, e.getArgs.get! 2) 134 | 135 | elab (priority := high) "calc " ε:term " : " τ:term σ:(calcLHS " : " term)* : term => do 136 | let σ ← Array.mapM getEqn σ 137 | 138 | let ε ← Elab.Term.elabTerm ε none 139 | let ε ← instantiateMVars ε 140 | 141 | let e₁ := ε.withApp (λ _ es => es.pop.back!) 142 | let ty₁ ← Meta.inferType e₁ 143 | let u₁ ← Meta.getLevel ty₁ 144 | 145 | let mut (e₂, ρ₁) ← extRelation ε 146 | let mut η ← Elab.Term.elabTermEnsuringType τ ε 147 | 148 | let mut ty₂ ← Meta.inferType e₂ 149 | let mut u₂ ← Meta.getLevel ty₂ 150 | 151 | let mut v₁ ← Meta.getLevel ε 152 | 153 | for (e, τ) in σ do 154 | let ε ← Elab.Term.elabTerm (e.setArg 0 (← PrettyPrinter.delab e₂)) none 155 | let ε ← instantiateMVars ε 156 | 157 | let τ ← Elab.Term.elabTermEnsuringType τ ε 158 | let mut v₂ ← Meta.getLevel ε 159 | 160 | let (e₃, ρ₂) ← extRelation ε 161 | 162 | let ty₃ ← Meta.inferType e₃ 163 | let u₃ ← Meta.getLevel ty₃ 164 | 165 | let v₃ ← Meta.mkFreshLevelMVar 166 | let ρ₃ ← Meta.mkFreshExprMVar none 167 | 168 | let ι ← Meta.synthInstance (mkApp6 (Lean.mkConst `Rewrite [u₁, u₂, u₃, v₁, v₂, v₃]) ty₁ ty₂ ty₃ ρ₁ ρ₂ ρ₃) 169 | let φ := (← Meta.reduceProj? (mkProj `Rewrite 0 ι)).getD ι 170 | 171 | η := mkAppN φ #[e₁, e₂, e₃, η, τ] 172 | (ty₂, u₂, e₂, v₁, ρ₁) := (ty₃, u₃, e₃, v₃, ρ₃) 173 | 174 | return η 175 | 176 | end GroundZero.Meta.Tactic 177 | -------------------------------------------------------------------------------- /GroundZero/Meta/Trust.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Id 2 | open GroundZero.Types 3 | 4 | universe u v w w' 5 | 6 | /-- 7 | `Quot.withUseOf a b x` isn’t definitionally equal to `b` unless `x` is an constructor (i.e. `Quot.mk a`). 8 | 9 | It’s used to ensure that `Quot.withUseOf a₁ b x` and `Quot.withUseOf a₂ b x` aren’t 10 | definitionally equal unless `a₁` and `a₂` are. 11 | 12 | This is crucial in the definition of induction principles for HITs as there are 13 | *provably* unequal functions that definitionally agree on all point constructors 14 | (for examples see `HITs/Circle.lean`). 15 | 16 | See also: 17 | * https://github.com/gebner/hott3/blob/7ead7a8a2503049eacd45cbff6587802bae2add2/src/hott/init/hit.lean#L119-L129. 18 | * “The HoTT Library: A formalization of homotopy type theory in Coq” (https://arxiv.org/pdf/1610.04591.pdf), section 4. 19 | -/ 20 | def Quot.withUseOf {X : Type u} {R : X → X → Sort 0} {A : Type v} {B : Type w} (a : A) (b : B) : Quot R → B := 21 | λ y, (@Quot.lift X R (A × B) (λ _, (a, b)) (λ _ _ _, rfl) y).2 22 | 23 | section 24 | variable (X : Type u) (R : X → X → Sort 0) (A : Type u) (B : Type w) (a₁ a₂ : A) (b : B) 25 | #failure @Quot.withUseOf X R A B a₁ b ≡ @Quot.withUseOf X R A B a₂ b : Quot R → B 26 | end 27 | 28 | /-- 29 | Behaves just like structure with one field of a given type `A`, but lacks definitional eta. 30 | 31 | Useful for defining HITs through Dan Licata’s trick (see https://github.com/gebner/hott3), 32 | because it seems impossible to define combinator similar to `Quot.withUseOf` for private structures 33 | in Lean 4 due to the availability of definitional eta for them. 34 | -/ 35 | def Opaque (A : Type u) := @Quot A (λ _ _, False) 36 | 37 | namespace EtaFailure 38 | inductive Opaque (A : Type u) 39 | | intro : A → Opaque A 40 | 41 | def withUseOf {X : Type u} {A : Type v} {B : Type w} (a : A) (b : B) : Opaque X → B := 42 | λ y, (@Opaque.casesOn X (λ _, A × B) y (λ _, (a, b))).2 43 | 44 | variable (X : Type u) (A : Type u) (B : Type w) (a₁ a₂ : A) (b : B) 45 | 46 | #success @withUseOf X A B a₁ b ≡ @withUseOf X A B a₂ b : Opaque X → B 47 | 48 | variable (x : Opaque X) 49 | #success @withUseOf X A B a₁ b x ≡ b : B 50 | #success @withUseOf X A B a₂ b x ≡ b : B 51 | end EtaFailure 52 | 53 | namespace Opaque 54 | def intro {A : Type u} : A → Opaque A := Quot.mk (λ _ _, False) 55 | 56 | def elim {A : Type u} {B : Type v} (f : A → B) : Opaque A → B := 57 | Quot.lift f (λ _ _ ε, nomatch ε) 58 | 59 | def elim₂ {A : Type u} {B : Type v} {C : Type w} (f : A → B → C) : Opaque A → Opaque B → C := 60 | elim (elim ∘ f) 61 | 62 | def elim₃ {A : Type u} {B : Type v} {C : Type w} {D : Type w} (f : A → B → C → D) : Opaque A → Opaque B → Opaque C → D := 63 | elim (elim₂ ∘ f) 64 | 65 | def value {A : Type u} : Opaque A → A := elim (λ x, x) 66 | 67 | def ind {A : Type u} {B : Opaque A → Type v} (f : Π x, B (intro x)) : Π x, B x := 68 | λ x, Quot.hrecOn x f (λ _ _ ε, nomatch ε) 69 | end Opaque 70 | 71 | namespace GroundZero 72 | /-- 73 | Used to postulate propositional computation rules for higher constructors. 74 | 75 | Shouldn’t be used directly (hence marked as `nothott`). 76 | -/ 77 | opaque trustCoherence {A : Type u} {a b : A} {p q : a = b} : p = q := 78 | match p, q with | idp _, idp _ => idp _ 79 | 80 | /-- 81 | Used to generate 1-path constructors out of `Quot.sound`. 82 | 83 | Should be used only within of `opaque` (hence marked as `nothott`). 84 | -/ 85 | def trustHigherCtor {A : Type u} {a b : A} (p : Eq a b) : a = b := 86 | begin induction p; reflexivity end 87 | 88 | attribute [nothott] trustCoherence trustHigherCtor 89 | 90 | hott def elimEq {A : Type u} {a b : A} (p : a = b) : Eq a b := 91 | begin induction p; reflexivity end 92 | end GroundZero 93 | -------------------------------------------------------------------------------- /GroundZero/Modal/Disc.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Modal.Infinitesimal 2 | import GroundZero.Structures 3 | 4 | open GroundZero.Types GroundZero.Proto 5 | open GroundZero.Types.Equiv 6 | open GroundZero 7 | 8 | namespace GroundZero.HITs.Infinitesimal 9 | universe u v w 10 | 11 | -- infinitesimally close 12 | hott definition infinitesimallyClose {A : Type u} (a b : A) := ι a = ι b 13 | infix:80 " ~ " => infinitesimallyClose 14 | 15 | hott definition Disc {A : Type u} (a : A) := Σ b, a ~ b 16 | notation "𝔻" => Disc 17 | 18 | hott definition discBundle (A : Type u) := Σ (a : A), 𝔻 a 19 | notation "T∞" => discBundle 20 | 21 | hott definition center {A : Type u} (a : A) : 𝔻 a := ⟨a, idp (ι a)⟩ 22 | 23 | section 24 | variable {A : Type u} {B : Type v} (f : A → B) 25 | 26 | hott definition infProxAp {a b : A} : a ~ b → f a ~ f b := 27 | λ ρ, Id.ap (Im.ap f) ρ 28 | 29 | hott definition d (x : A) : 𝔻 x → 𝔻 (f x) := 30 | λ ε, ⟨f ε.1, infProxAp f ε.2⟩ 31 | 32 | hott definition bundleAp : T∞ A → T∞ B := 33 | λ τ, ⟨f τ.1, d f τ.1 τ.2⟩ 34 | end 35 | 36 | hott lemma infProxApIdp {A : Type u} {a b : A} (ρ : a ~ b) : infProxAp idfun ρ = ρ := 37 | begin 38 | transitivity; apply mapWithHomotopy; apply Im.apIdfun; 39 | transitivity; apply Id.rid; apply Equiv.idmap 40 | end 41 | 42 | hott lemma infProxApCom {A : Type u} {B : Type v} {C : Type w} (f : B → C) (g : A → B) 43 | {a b : A} (ρ : a ~ b) : infProxAp (f ∘ g) ρ = infProxAp f (infProxAp g ρ) := 44 | begin 45 | transitivity; apply mapWithHomotopy; apply Im.apCom; 46 | transitivity; apply Id.rid; apply mapOverComp 47 | end 48 | 49 | hott definition diffComHom {A : Type u} {B : Type v} {C : Type w} 50 | (f : B → C) (g : A → B) {x : A} (ε : 𝔻 x) : d (f ∘ g) x ε = d f (g x) (d g x ε) := 51 | Id.ap (Sigma.mk _) (infProxApCom f g _) 52 | 53 | hott theorem diffCom {A : Type u} {B : Type v} {C : Type w} (f : B → C) (g : A → B) 54 | {x : A} : d (f ∘ g) x = (d f) (g x) ∘ d g x := 55 | Theorems.funext (diffComHom f g) 56 | 57 | hott lemma diffIdfun {A : Type u} (x : A) (ε : 𝔻 x) : d idfun x ε = ε := 58 | Id.ap (Sigma.mk _) (infProxApIdp _) 59 | 60 | hott definition isHomogeneous (A : Type u) := 61 | Σ (e : A) (t : A → A ≃ A), Π x, t x e = x 62 | 63 | hott definition Homogeneous := 64 | Σ (A : Type u), isHomogeneous A 65 | 66 | noncomputable instance : Coe Homogeneous (Type u) := ⟨Sigma.fst⟩ 67 | 68 | hott definition Homogeneous.trivial : Homogeneous := 69 | ⟨𝟏, ★, λ _, ideqv 𝟏, λ ★, idp ★⟩ 70 | 71 | hott definition Homogeneous.cart (A B : Homogeneous) : Homogeneous := 72 | ⟨A.1 × B.1, ⟨(A.2.1, B.2.1), λ w, prodEquiv (A.2.2.1 w.1) (B.2.2.1 w.2), 73 | λ w, Product.prod (A.2.2.2 w.1) (B.2.2.2 w.2)⟩⟩ 74 | 75 | noncomputable instance : HMul Homogeneous Homogeneous Homogeneous := ⟨Homogeneous.cart⟩ 76 | 77 | end GroundZero.HITs.Infinitesimal 78 | -------------------------------------------------------------------------------- /GroundZero/Modal/Etale.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Functions 2 | import GroundZero.Modal.Disc 3 | 4 | open GroundZero.Theorems.Functions 5 | open GroundZero GroundZero.Types 6 | open GroundZero.Proto 7 | 8 | namespace GroundZero.HITs.Infinitesimal 9 | universe u v w 10 | 11 | section 12 | variable {A : Type u} {B : Type v} (f : A → B) 13 | 14 | hott definition naturalitySquare : hcommSquare A (ℑ A) B (ℑ B) := 15 | ⟨Im.ap f, ι, ι, f, Theorems.funext (Im.naturality f)⟩ 16 | 17 | hott definition etale := (naturalitySquare f).isPullback 18 | notation "étale" => etale 19 | end 20 | 21 | section 22 | hott definition EtaleMap (A : Type u) (B : Type v) := 23 | Σ (f : A → B), étale f 24 | infixr:70 " ─ét→ " => EtaleMap 25 | 26 | hott definition SurjectiveEtaleMap (A : Type u) (B : Type v) := 27 | Σ (f : A → B), étale f × surjective f 28 | infixr:70 " ─ét↠ " => SurjectiveEtaleMap 29 | end 30 | 31 | section 32 | variable (A : Type u) (B : Type v) 33 | 34 | instance : CoeFun (A ─ét→ B) (λ _, A → B) := ⟨Sigma.fst⟩ 35 | instance : CoeFun (A ─ét↠ B) (λ _, A → B) := ⟨Sigma.fst⟩ 36 | end 37 | 38 | section 39 | hott definition isManifold (V : Type u) (M : Type v) := 40 | Σ (U : Type (max u v)), (U ─ét→ V) × (U ─ét↠ M) 41 | 42 | hott definition Manifold (V : Type u) := 43 | Σ (M : Type v), isManifold V M 44 | end 45 | 46 | end GroundZero.HITs.Infinitesimal 47 | -------------------------------------------------------------------------------- /GroundZero/Modal/Infinitesimal.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | 3 | open GroundZero.Types.Equiv (biinv) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Types 6 | open GroundZero.Proto 7 | 8 | /- 9 | Infinitesimal shape modality or coreduction. 10 | 11 | https://github.com/rzrn/anders/blob/master/library/modal/infinitesimal.anders 12 | https://www.math.kit.edu/iag3/~wellen/media/diss.pdf 13 | https://arxiv.org/pdf/1806.05966.pdf 14 | 15 | * HoTT 7.7 Modalities 16 | -/ 17 | 18 | namespace GroundZero.HITs.Infinitesimal 19 | universe u v w 20 | 21 | hott axiom Im (A : Type u) : Type u := Opaque A 22 | 23 | notation "ℑ" => Im 24 | 25 | section 26 | variable {A : Type u} 27 | 28 | hott axiom ι : A → ℑ A := Opaque.intro 29 | hott axiom μ : ℑ (ℑ A) → ℑ A := Opaque.value 30 | 31 | hott axiom Im.ind {B : ℑ A → Type v} (f : Π x, ℑ (B (ι x))) : Π x, ℑ (B x) := Opaque.ind f 32 | 33 | hott axiom κ {a b : ℑ A} : ℑ (a = b) → a = b := Opaque.value 34 | end 35 | 36 | hott definition Im.indβrule {A : Type u} {B : ℑ A → Type v} {f : Π x, ℑ (B (ι x))} (a : A) : Im.ind f (ι a) = f a := 37 | idp (f a) 38 | 39 | hott definition μcom {A : Type u} : μ ∘ ι ~ @idfun (ℑ A) := 40 | idp 41 | 42 | hott definition ιcoh {A : Type u} : ι ∘ μ ~ @idfun (ℑ (ℑ A)) := 43 | λ w, κ (@Im.ind (ℑ A) (λ x, ι (μ x) = x) (λ x, ι (idp (ι x))) w) 44 | 45 | hott definition κ.right {A : Type u} {a b : ℑ A} : @κ A a b ∘ ι ~ idfun := 46 | idp 47 | 48 | hott definition κ.left {A : Type u} {a b : ℑ A} : ι ∘ @κ A a b ~ idfun := 49 | λ ρ, κ (@Im.ind (a = b) (λ ρ, ι (κ ρ) = ρ) (λ p, ι (ap ι (κ.right p))) ρ) 50 | 51 | hott definition isCoreduced (A : Type u) := biinv (@ι A) 52 | 53 | hott definition Im.coreduced (A : Type u) : isCoreduced (ℑ A) := 54 | Qinv.toBiinv ι ⟨μ, (ιcoh, μcom)⟩ 55 | 56 | hott definition Im.idCoreduced {A : Type u} (a b : ℑ A) : isCoreduced (a = b) := 57 | Qinv.toBiinv ι ⟨κ, (κ.left, κ.right)⟩ 58 | 59 | hott definition Im.indε {A : Type u} {B : ℑ A → Type v} 60 | (η : Π i, isCoreduced (B i)) (f : Π x, B (ι x)) : Π x, B x := 61 | λ a, (η a).1.1 (@Im.ind A B (λ x, ι (f x)) a) 62 | 63 | hott definition Im.indεβrule {A : Type u} {B : ℑ A → Type v} 64 | (η : Π i, isCoreduced (B i)) (f : Π x, B (ι x)) : Π x, Im.indε η f (ι x) = f x := 65 | λ x, (η (ι x)).1.2 (f x) 66 | 67 | section 68 | variable {A : Type u} {B : Type v} (f : A → ℑ B) 69 | 70 | hott definition Im.rec : Im A → ℑ B := Im.ind f 71 | hott definition Im.recβrule : Π x, Im.rec f (ι x) = f x := Im.indβrule 72 | end 73 | 74 | section 75 | variable {A : Type u} {B : Type v} (η : isCoreduced B) (f : A → B) 76 | 77 | hott definition Im.recε : Im A → B := Im.indε (λ _, η) f 78 | 79 | hott definition Im.recεβrule : Π x, Im.recε η f (ι x) = f x := 80 | Im.indεβrule (λ _, η) f 81 | end 82 | 83 | section 84 | variable {A : Type u} {B : Type v} (f : A → B) 85 | 86 | hott definition Im.ap : ℑ A → ℑ B := Im.rec (ι ∘ f) 87 | hott definition Im.naturality (x : A) : Im.ap f (ι x) = ι (f x) := idp (ι (f x)) 88 | end 89 | 90 | hott definition Im.apIdfun {A : Type u} : Im.ap idfun ~ @idfun (ℑ A) := 91 | Im.indε (λ _, Im.idCoreduced _ _) (λ x, idp (ι x)) 92 | 93 | hott definition Im.apCom {A : Type u} {B : Type v} {C : Type w} 94 | (f : B → C) (g : A → B) : Im.ap (f ∘ g) ~ Im.ap f ∘ Im.ap g := 95 | Im.indε (λ _, Im.idCoreduced _ _) (λ x, idp (ι (f (g x)))) 96 | 97 | end GroundZero.HITs.Infinitesimal 98 | -------------------------------------------------------------------------------- /GroundZero/Proto.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Meta.Basic 2 | 3 | namespace GroundZero.Proto 4 | universe u v w 5 | 6 | hott definition idfun {A : Sort u} : A → A := 7 | λ a, a 8 | 9 | inductive Empty : Type u 10 | 11 | attribute [induction_eliminator] Empty.casesOn 12 | 13 | hott definition Iff (A : Type u) (B : Type v) := (A → B) × (B → A) 14 | 15 | infix:30 (priority := high) " ↔ " => Iff 16 | 17 | hott definition Iff.left {A : Type u} {B : Type v} (w : A ↔ B) : A → B := w.1 18 | hott definition Iff.right {A : Type u} {B : Type v} (w : A ↔ B) : B → A := w.2 19 | 20 | hott definition Iff.refl {A : Type u} : A ↔ A := 21 | ⟨idfun, idfun⟩ 22 | 23 | hott definition Iff.symm {A : Type u} {B : Type v} : (A ↔ B) → (B ↔ A) := 24 | λ p, ⟨p.right, p.left⟩ 25 | 26 | hott definition Iff.comp {A : Type u} {B : Type v} {C : Type w} : 27 | (A ↔ B) → (B ↔ C) → (A ↔ C) := 28 | λ p q, ⟨q.left ∘ p.left, p.right ∘ q.right⟩ 29 | 30 | noncomputable instance : @Reflexive (Type u) Iff := ⟨@Iff.refl⟩ 31 | noncomputable instance : @Symmetric (Type u) Iff := ⟨@Iff.symm⟩ 32 | noncomputable instance : @Transitive (Type u) Iff := ⟨@Iff.comp⟩ 33 | 34 | notation "𝟎" => Empty 35 | notation "𝟐" => Bool 36 | notation "ℕ" => Nat 37 | 38 | hott definition explode {A : Sort u} (xs : 𝟎) : A := 39 | nomatch xs 40 | 41 | hott definition Bool.elim {A : Sort u} : A → A → 𝟐 → A := 42 | λ b₁ b₂ b, @Bool.casesOn (λ _, A) b b₁ b₂ 43 | 44 | hott abbreviation Bottom := Empty.{0} 45 | notation (priority := low) "⊥" => Bottom 46 | 47 | inductive Identity (A : Type u) 48 | | elem : A → Identity A 49 | 50 | attribute [induction_eliminator] Identity.casesOn 51 | 52 | hott definition Identity.elim {A : Type u} : Identity A → A 53 | | Identity.elem a => a 54 | 55 | hott definition Identity.lift {A : Type u} {B : Type v} 56 | (f : A → B) : Identity A → Identity B 57 | | Identity.elem a => Identity.elem (f a) 58 | 59 | hott definition Identity.lift₂ {A : Type u} {B : Type v} {C : Type w} 60 | (f : A → B → C) : Identity A → Identity B → Identity C 61 | | Identity.elem a, Identity.elem b => Identity.elem (f a b) 62 | 63 | end GroundZero.Proto 64 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Classical.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | 3 | open GroundZero.Types.Equiv (transport) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | open GroundZero.Types 7 | open GroundZero.Proto 8 | 9 | namespace GroundZero 10 | universe u v w 11 | 12 | namespace Theorems.Classical 13 | 14 | axiom choice {A : Type u} (B : A → Type v) (η : Π x, B x → Type w) : 15 | hset A → (Π x, hset (B x)) → (Π x y, prop (η x y)) → 16 | (Π (x : A), ∥(Σ (y : B x), η x y)∥) → 17 | ∥(Σ (φ : Π x, B x), Π x, η x (φ x))∥ 18 | 19 | hott lemma choiceOfRel {A : Type u} {B : Type v} 20 | (R : A → B → Prop w) (H : hset A) (G : hset B) : 21 | (Π x, ∥(Σ y, (R x y).fst)∥) → ∥(Σ (φ : A → B), Π x, (R x (φ x)).fst)∥ := 22 | begin 23 | apply @choice A (λ _, B) (λ x y, (R x y).1); 24 | { intros x y; apply H }; 25 | { intros x y z; apply G }; 26 | { intros x y; apply (R x y).2 } 27 | end 28 | 29 | hott theorem cartesian {A : Type u} (B : A → Type v) : 30 | hset A → (Π x, hset (B x)) → (Π x, ∥B x∥) → ∥(Π x, B x)∥ := 31 | begin 32 | intros p q φ; apply transport; apply ua; 33 | change (Σ (φ : Π x, B x), Π (x : A), (𝟏 : Type)) ≃ _; 34 | transitivity; apply Sigma.const; apply Equiv.trans; 35 | { apply productEquiv₃; reflexivity; apply zeroMorphismEqv.{_, _, 1} }; 36 | apply Equiv.trans; apply Product.comm; apply prodUnitEquiv; 37 | apply choice B (λ _ _, 𝟏); apply p; apply q; 38 | { intros; apply unitIsProp }; intro x; fapply HITs.Merely.rec _ _ (φ x); 39 | apply HITs.Merely.uniq; intro y; apply HITs.Merely.elem; exact ⟨y, ★⟩ 40 | end 41 | 42 | section 43 | variable {A : Type u} (H : prop A) 44 | hott definition inh := Σ (φ : 𝟐 → Prop), ∥(Σ (x : 𝟐), (φ x).fst)∥ 45 | 46 | hott lemma inh.hset : hset inh := 47 | begin 48 | apply hsetRespectsSigma; apply piHset; 49 | intro x; apply Theorems.Equiv.propsetIsSet; 50 | intro φ; apply propIsSet; apply HITs.Merely.uniq 51 | end 52 | 53 | -- due to http://www.cs.ioc.ee/ewscs/2017/altenkirch/altenkirch-notes.pdf 54 | hott theorem lem {A : Type u} (H : prop A) : A + ¬A := 55 | begin 56 | have f := @choiceOfRel inh 𝟐 (λ φ x, φ.fst x) inh.hset boolIsSet (λ x, HITs.Merely.lift id x.2); 57 | induction f; 58 | { case elemπ w => 59 | let ⟨φ, p⟩ := w; 60 | let U : 𝟐 → Prop := λ x, ⟨∥(x = true) + A∥, HITs.Merely.uniq⟩; 61 | let V : 𝟐 → Prop := λ x, ⟨∥(x = false) + A∥, HITs.Merely.uniq⟩; 62 | have r : ∥_∥ := p ⟨U, HITs.Merely.elem ⟨true, HITs.Merely.elem (Sum.inl (idp _))⟩⟩; 63 | have s : ∥_∥ := p ⟨V, HITs.Merely.elem ⟨false, HITs.Merely.elem (Sum.inl (idp _))⟩⟩; 64 | induction r; 65 | { case elemπ r' => 66 | induction s; 67 | { case elemπ s' => 68 | induction r' using Sum.casesOn; 69 | { case inl r' => 70 | induction s' using Sum.casesOn; 71 | { case inl s' => 72 | right; intro z; apply ffNeqTt; 73 | transitivity; exact s'⁻¹; symmetry; transitivity; exact r'⁻¹; 74 | apply ap; fapply Types.Sigma.prod; apply Theorems.funext; 75 | intro x; apply Theorems.Equiv.propset.Id; apply propext; 76 | apply HITs.Merely.uniq; apply HITs.Merely.uniq; apply Prod.mk <;> 77 | intro <;> apply HITs.Merely.elem <;> right <;> exact z; apply HITs.Merely.uniq }; 78 | { case inr => left; assumption } }; 79 | { case inr => left; assumption } }; 80 | apply propEM H }; 81 | apply propEM H }; 82 | apply propEM H 83 | end 84 | end 85 | 86 | hott definition dneg.decode {A : Type u} (H : prop A) : ¬¬A → A := 87 | λ G, match lem H with 88 | | Sum.inl z => z 89 | | Sum.inr φ => explode (G φ) 90 | 91 | hott definition dneg.encode {A : Type u} : A → ¬¬A := 92 | λ x p, p x 93 | 94 | hott definition dneg {A : Type u} (H : prop A) : A ≃ ¬¬A := 95 | propEquivLemma H notIsProp dneg.encode (dneg.decode H) 96 | 97 | section 98 | variable {A : Type u} {B : Type v} (H : prop B) 99 | 100 | hott definition Contrapos.intro : (A → B) → (¬B → ¬A) := 101 | λ f p a, p (f a) 102 | 103 | hott definition Contrapos.elim : (¬B → ¬A) → (A → B) := 104 | λ f p, match lem H with 105 | | Sum.inl z => z 106 | | Sum.inr φ => explode (f φ p) 107 | 108 | hott definition Contrapos : (A → B) ↔ (¬B → ¬A) := 109 | ⟨Contrapos.intro, Contrapos.elim H⟩ 110 | 111 | hott definition Contrapos.eq (H : prop B) : (A → B) = (¬B → ¬A) := 112 | begin 113 | apply ua; apply propEquivLemma; 114 | apply piProp; intro; assumption; 115 | apply piProp; intro; apply notIsProp; 116 | apply Contrapos.intro; apply Contrapos.elim H 117 | end 118 | end 119 | end Theorems.Classical 120 | 121 | end GroundZero 122 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Connectedness.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | import GroundZero.HITs.Trunc 3 | 4 | open GroundZero.HITs.Interval (happly) 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Types.Equiv 7 | open GroundZero.Structures 8 | open GroundZero.Types 9 | open GroundZero.HITs 10 | 11 | universe u v w 12 | 13 | namespace GroundZero 14 | namespace Theorems 15 | 16 | hott def conn {A : Type u} {B : Type v} (n : ℕ₋₂) (f : A → B) := 17 | Π (b : B), contr ∥fib f b∥ₙ 18 | 19 | hott def isConnected (n : ℕ₋₂) (A : Type u) := 20 | contr ∥A∥ₙ 21 | 22 | notation "is-" n "-connected" => isConnected n 23 | 24 | namespace Connectedness 25 | hott proposition isProp {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} : prop (conn n f) := 26 | begin apply piProp; intro; apply contrIsProp end 27 | 28 | -- HoTT Book Lemma 7.5.14 29 | hott lemma isQinv {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} (c : conn n f) : @qinv ∥A∥ₙ ∥B∥ₙ (Trunc.ap f) := 30 | begin 31 | fapply Sigma.mk; apply Trunc.rec; 32 | { intro b; exact Trunc.ap Sigma.fst (c b).1 }; 33 | { apply Trunc.uniq }; 34 | 35 | apply Prod.mk; 36 | { fapply Trunc.ind; 37 | { intro y; transitivity; apply ap (Trunc.ap _); 38 | apply Trunc.recβrule; induction (c y).1; 39 | { case elemπ w => 40 | transitivity; apply ap (Trunc.ap f); apply Trunc.recβrule; 41 | transitivity; apply Trunc.recβrule; apply ap Trunc.elem; exact w.2 }; 42 | { apply hlevel.cumulative; apply Trunc.uniq } }; 43 | { intro; apply hlevel.cumulative; apply Trunc.uniq } }; 44 | { fapply Trunc.ind; 45 | { intro x; transitivity; apply ap (Trunc.rec _ _); 46 | apply Trunc.recβrule; transitivity; apply Trunc.recβrule; 47 | transitivity; apply ap; apply (c (f x)).2 (Trunc.elem ⟨x, idp (f x)⟩); 48 | apply Trunc.recβrule }; 49 | { intro; apply hlevel.cumulative; apply Trunc.uniq } } 50 | end 51 | 52 | hott corollary induce {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} (c : conn n f) : ∥A∥ₙ ≃ ∥B∥ₙ := 53 | ⟨Trunc.ap f, Qinv.toBiinv _ (isQinv c)⟩ 54 | 55 | hott def com {A : Type u} {B : Type v} {n : ℕ₋₂} (f : A → B) 56 | (P : B → n-Type) : (Π b, (P b).1) → (Π a, (P (f a)).1) := 57 | λ s a, s (f a) 58 | 59 | hott lemma connImplQinv {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} 60 | (c : conn n f) (P : B → n-Type) : qinv (com f P) := 61 | begin 62 | fapply Sigma.mk; intros s b; apply Trunc.rec _ _ (c b).1; intro w; 63 | apply transport (λ b, (P b).1) w.2; apply s; exact (P b).2; apply Prod.mk; 64 | { intro s; apply Theorems.funext; intro a; transitivity; 65 | apply ap (Trunc.rec _ _); apply (c (f a)).2; apply Trunc.elem; 66 | exact ⟨a, idp (f a)⟩; apply Trunc.recβrule }; 67 | { intro s; apply Theorems.funext; intro b; induction (c b).1; 68 | { case elemπ w => 69 | transitivity; apply ap (Trunc.rec _ _); apply (c b).2 (Trunc.elem w); 70 | transitivity; apply Trunc.recβrule; apply apd s w.2 }; 71 | { apply hlevel.cumulative; apply (P b).2 } } 72 | end 73 | 74 | hott lemma rinvImplConn {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} 75 | (s : Π (P : B → n-Type), rinv (com f P)) : conn n f := 76 | begin 77 | let P : B → n-Type := λ b, ⟨∥fib f b∥ₙ, Trunc.uniq n⟩; intro b; fapply Sigma.mk; 78 | apply (s P).1 (λ a, Trunc.elem ⟨a, idp (f a)⟩); fapply Trunc.ind; 79 | { intro ⟨a, w⟩; induction w; apply happly ((s P).2 (λ a, Trunc.elem ⟨a, idp (f a)⟩)) a }; 80 | { intro; apply hlevel.cumulative; apply Trunc.uniq } 81 | end 82 | 83 | hott lemma rinvComProp {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} : 84 | prop (Π (P : B → n-Type), rinv (com f P)) := 85 | begin 86 | apply lemProp; intro s; apply piProp; intro P; apply contrImplProp; 87 | apply Equiv.rinvContr; apply connImplQinv; apply rinvImplConn; exact s 88 | end 89 | 90 | -- HoTT Book Lemma 7.5.7 91 | hott corollary induct {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} : 92 | (conn n f) ≃ (Π (P : B → n-Type), rinv (com f P)) := 93 | begin 94 | apply propEquivLemma; apply Connectedness.isProp; apply rinvComProp; intro c P; 95 | exact (Qinv.toBiinv _ (connImplQinv c P)).2; apply rinvImplConn 96 | end 97 | 98 | hott lemma apComHapply {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} (P : B → n-Type) 99 | {φ ψ : Π b, (P b).1} (p : φ = ψ) : ap (com f P) p = funext (λ a, happly p (f a)) := 100 | begin induction p; symmetry; apply funextId end 101 | 102 | hott lemma fibCom {A : Type u} {B : Type v} {n : ℕ₋₂} (f : A → B) (P : B → (hlevel.succ n)-Type) 103 | {s : Π a, (P (f a)).1} (w₁ w₂ : fib (com f P) s) := 104 | calc (w₁ = w₂) ≃ Σ (p : w₁.1 = w₂.1), transport (λ r, com f P r = s) p w₁.2 = w₂.2 105 | : Sigma.sigmaPath 106 | ... ≃ Σ (p : w₁.1 = w₂.1), (ap (com f P) p)⁻¹ ⬝ w₁.2 = w₂.2 107 | : Sigma.respectsEquiv (λ _, idtoeqv (ap (· = _) (transportOverContrMap _ _ _ ⬝ 108 | ap (· ⬝ _) (Id.mapInv _ _)))) 109 | ... ≃ Σ (p : w₁.1 = w₂.1), ap (com f P) p ⬝ w₂.2 = w₁.2 110 | : Sigma.respectsEquiv (λ _, Equiv.trans rewriteCompEquiv.symm inveqv) 111 | ... ≃ Σ (p : w₁.1 = w₂.1), ap (com f P) p = w₁.2 ⬝ w₂.2⁻¹ 112 | : Sigma.respectsEquiv (λ _, compRewriteEquiv.symm) 113 | ... ≃ Σ (H : w₁.1 ~ w₂.1), ap (com f P) (funext H) = w₁.2 ⬝ w₂.2⁻¹ 114 | : Equiv.respectsEquivOverFst full _ 115 | ... ≃ Σ (H : w₁.1 ~ w₂.1), happly (ap (com f P) (funext H)) = happly (w₁.2 ⬝ w₂.2⁻¹) 116 | : Sigma.respectsEquiv (λ _, apEquivOnEquiv Theorems.full) 117 | ... ≃ Σ (H : w₁.1 ~ w₂.1), (λ a, H (f a)) = (happly w₁.2).trans (happly w₂.2).symm 118 | : Sigma.respectsEquiv 119 | (λ H, idtoeqv (bimap _ (ap happly (apComHapply P (funext H)) ⬝ happlyFunext _ _ _ ⬝ 120 | funext (λ a, happly (happlyFunext _ _ _) (f a))) 121 | (Interval.happlyCom _ _ ⬝ ap _ (Interval.happlyRev _)))) 122 | ... ≃ fib (com f (λ b, ⟨w₁.1 b = w₂.1 b, (P b).2 _ _⟩)) 123 | (λ a, happly w₁.2 a ⬝ (happly w₂.2 a)⁻¹) 124 | : ideqv _ 125 | 126 | -- HoTT Book Lemma 8.6.1 127 | hott corollary indTrunc {A : Type u} {B : Type v} {n : ℕ₋₂} {f : A → B} (c : conn n f) : 128 | Π (k : ℕ) (P : B → (n + hlevel.ofNat k)-Type w), is-(hlevel.predPred k)-truncated (com f P) 129 | | Nat.zero, P => Equiv.ishaeImplContrFib _ (Equiv.qinvImplsIshae _ (connImplQinv c P)) 130 | | Nat.succ k, P => λ s w₁ w₂, ntypeRespectsEquiv _ (fibCom f P w₁ w₂).symm (indTrunc c k _ _) 131 | 132 | hott lemma connImplTerminalConn {A : Type u} {n : ℕ₋₂} (a : A) (c : is-(hlevel.succ n)-connected A) : @conn 𝟏 A n (λ _, a) := 133 | begin 134 | apply rinvImplConn; intro P; 135 | 136 | let Q : Trunc (hlevel.succ n) A → n-Type := 137 | Trunc.rec P (Equiv.ntypeIsSuccNType n); 138 | 139 | let r := λ a b, contrImplProp c (Trunc.elem a) (Trunc.elem b); 140 | let s := λ a b, (Trunc.recβrule _ _ _)⁻¹ ⬝ ap Q (r a b) ⬝ Trunc.recβrule _ _ _; 141 | 142 | fapply Sigma.mk; intro r b; exact transport Sigma.fst (s a b) (r ★); 143 | intro φ; apply funext; apply Unit.ind; transitivity; 144 | apply ap (transport _ · _); transitivity; apply ap (· ⬝ _); 145 | transitivity; apply ap (_ ⬝ ap Q ·); show _ = idp (Trunc.elem a); 146 | apply propIsSet; apply contrImplProp; apply c; 147 | apply Id.rid; apply Id.invComp; reflexivity 148 | end 149 | end Connectedness 150 | 151 | end Theorems 152 | end GroundZero 153 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Fibration.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Interval 2 | open GroundZero GroundZero.Types GroundZero.Types.Equiv 3 | open GroundZero.HITs GroundZero.HITs.Interval 4 | open GroundZero.Structures 5 | 6 | namespace GroundZero.Theorems.Fibration 7 | universe u v 8 | 9 | hott definition forward {A : Type u} {B : A → Type v} (x : A) : 10 | fib (@Sigma.fst A B) x → B x := 11 | λ ⟨⟨y, u⟩, H⟩, transport B H u 12 | 13 | hott definition left {A : Type u} {B : A → Type v} (x : A) (u : B x) : 14 | fib (@Sigma.fst A B) x := 15 | ⟨⟨x, u⟩, idp _⟩ 16 | 17 | hott definition fiberOver {A : Type u} {B : A → Type v} (x : A) : 18 | fib (@Sigma.fst A B) x ≃ B x := 19 | begin 20 | existsi forward x; apply Prod.mk <;> existsi (@left A B x); 21 | { intro ⟨⟨y, u⟩, (H : y = x)⟩; induction H; apply idp }; 22 | { intro; reflexivity } 23 | end 24 | 25 | inductive Left {A : Type u} : A → Type u 26 | | lam (f : I → A) : Left (f 0) 27 | 28 | inductive Right {A : Type u} : A → Type u 29 | | lam (f : I → A) : Right (f 1) 30 | 31 | hott definition hasLifting {A : Type u} {B : Type v} (f : A → B) := 32 | Π x, Left (f x) → Left x 33 | 34 | hott definition Fibration (A : Type u) (B : Type v) := 35 | Σ (f : A → B), hasLifting f 36 | 37 | infix:60 " ↠ " => Fibration 38 | 39 | hott definition lifting {A : Type u} {B : A → Type v} (f : I → A) (u : B (f 0)) : @Left (Σ x, B x) ⟨f 0, u⟩ := 40 | @Left.lam (Sigma B) (λ i, ⟨f i, transport (B ∘ f) (Interval.contrLeft i) u⟩) 41 | 42 | hott definition typeFamily {A : Type u} (B : A → Type v) : (Σ x, B x) ↠ A := 43 | begin existsi Sigma.fst; intro ⟨x, u⟩ f; apply @Left.casesOn A (λ x f, Π u, @Left (Σ x, B x) ⟨x, u⟩) x f; apply lifting end 44 | end GroundZero.Theorems.Fibration 45 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Functions.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Merely 2 | 3 | open GroundZero.Types GroundZero.HITs 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Structures 6 | 7 | namespace GroundZero.Theorems.Functions 8 | universe u v 9 | 10 | hott definition injective {A : Type u} {B : Type v} (f : A → B) := 11 | Π x y, f x = f y → x = y 12 | 13 | hott definition surjective {A : Type u} {B : Type v} (f : A → B) := 14 | Π b, ∥Σ a, f a = b∥ 15 | 16 | hott definition Surjection (A : Type u) (B : Type v) := 17 | Σ (f : A → B), surjective f 18 | infixr:70 " ↠ " => Surjection 19 | 20 | instance (A : Type u) (B : Type v) : CoeFun (A ↠ B) (λ _, A → B) := ⟨Sigma.fst⟩ 21 | 22 | hott definition fibInh {A : Type u} {B : Type v} (f : A → B) := 23 | λ b, ∥fib f b∥ 24 | 25 | hott definition Ran {A : Type u} {B : Type v} (f : A → B) := 26 | total (fibInh f) 27 | 28 | hott definition cut {A : Type u} {B : Type v} (f : A → B) : A → Ran f := 29 | λ x, ⟨f x, |⟨x, idp (f x)⟩|⟩ 30 | 31 | hott lemma cutIsSurj {A : Type u} {B : Type v} (f : A → B) : surjective (cut f) := 32 | begin 33 | intro ⟨x, (H : ∥_∥)⟩; induction H; 34 | { case elemπ G => 35 | apply Merely.elem; existsi G.1; fapply Sigma.prod; 36 | exact G.2; apply Merely.uniq }; 37 | apply Merely.uniq 38 | end 39 | 40 | hott definition Ran.subset {A : Type u} {B : Type v} (f : A → B) : Ran f → B := 41 | Sigma.fst 42 | 43 | hott definition Ran.incl {A : Type u} {B : Type v} {f : A → B} (H : surjective f) : B → Ran f := 44 | λ x, ⟨x, H x⟩ 45 | 46 | hott lemma surjImplRanEqv {A : Type u} {B : Type v} (f : A → B) (H : surjective f) : Ran f ≃ B := 47 | begin 48 | existsi Sigma.fst; fapply Prod.mk <;> existsi Ran.incl H; 49 | { intro ⟨_, _⟩; fapply Sigma.prod; reflexivity; apply Merely.uniq }; 50 | { intro; reflexivity } 51 | end 52 | 53 | hott definition ranConst {A : Type u} (a : A) {B : Type v} (b : B) : Ran (Function.const A b) := 54 | ⟨b, |⟨a, idp b⟩|⟩ 55 | 56 | hott lemma ranConstEqv {A : Type u} (a : A) {B : Type v} 57 | (H : hset B) (b : B) : Ran (Function.const A b) ≃ 𝟏 := 58 | begin 59 | existsi (λ _, ★); fapply Prod.mk <;> existsi (λ _, ranConst a b); 60 | { intro ⟨b', (G : ∥_∥)⟩; fapply Sigma.prod; change b = b'; 61 | induction G; { case elemπ w => exact w.2 }; 62 | apply H; apply Merely.uniq }; 63 | { intro ★; reflexivity } 64 | end 65 | 66 | hott definition isEmbedding {A : Type u} {B : Type v} (f : A → B) := 67 | Π x y, @Equiv.biinv (x = y) (f x = f y) (ap f) 68 | 69 | hott definition Embedding (A : Type u) (B : Type v) := 70 | Σ (f : A → B), isEmbedding f 71 | 72 | infix:55 " ↪ " => Embedding 73 | 74 | section 75 | variable {A : Type u} {B : Type v} (f : A ↪ B) 76 | 77 | hott abbreviation Embedding.ap : A → B := f.1 78 | 79 | hott abbreviation Embedding.eqv (x y : A) : (x = y) ≃ (f.ap x = f.ap y) := 80 | ⟨Id.ap f.ap, f.2 x y⟩ 81 | end 82 | 83 | hott theorem ntypeOverEmbedding {A : Type u} {B : Type v} (f : A ↪ B) (n : ℕ₋₂) : 84 | is-(hlevel.succ n)-type B → is-(hlevel.succ n)-type A := 85 | begin 86 | intros H x y; apply ntypeRespectsEquiv; apply Equiv.symm; 87 | existsi ap f.1; apply f.2; apply H 88 | end 89 | 90 | hott definition eqvMapForward {A : Type u} {B : Type v} (e : A ≃ B) 91 | (x y : A) (p : e x = e y) : x = y := 92 | (e.leftForward x)⁻¹ ⬝ (@ap B A _ _ e.left p) ⬝ (e.leftForward y) 93 | 94 | hott lemma sigmaPropEq {A : Type u} {B : A → Type v} 95 | (H : Π x, prop (B x)) {x y : Sigma B} (p : x.1 = y.1) : x = y := 96 | begin fapply Sigma.prod; exact p; apply H end 97 | 98 | hott lemma propSigmaEquiv {A : Type u} {B : A → Type v} (H : Π x, prop (B x)) 99 | (x y : Σ x, B x) : (x = y) ≃ (x.1 = y.1) := 100 | begin 101 | apply Equiv.trans; apply Sigma.sigmaPath; 102 | apply Equiv.trans; apply Sigma.respectsEquiv; 103 | { intro; apply contrEquivUnit.{_, 1}; fapply Sigma.mk; 104 | apply H; intro; apply propIsSet; apply H }; 105 | apply Equiv.trans; apply Sigma.const; apply unitProdEquiv 106 | end 107 | 108 | hott definition propSigmaEmbedding {A : Type u} {B : A → Type v} 109 | (H : Π x, prop (B x)) : (Σ x, B x) ↪ A := 110 | begin 111 | existsi Sigma.fst; intro x y; 112 | apply Equiv.transport Equiv.biinv _ (propSigmaEquiv H x y).2; 113 | apply Theorems.funext; intro p; induction p; reflexivity 114 | end 115 | 116 | hott definition isConnected (A : Type u) := 117 | Σ (x : A), Π y, ∥x = y∥ 118 | 119 | end GroundZero.Theorems.Functions 120 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Funext.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.HEq 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Types 6 | 7 | /- 8 | The unit Interval I as Higher Inductive Type. 9 | Proof of functional extensionality from it. 10 | * HoTT 6.3 11 | 12 | It is primitive HIT. 13 | * HoTT, chapter 6, exercise 6.13 14 | -/ 15 | 16 | namespace GroundZero.HITs 17 | universe u v w 18 | 19 | inductive I.rel : 𝟐 → 𝟐 → Prop 20 | | intro : rel false true 21 | 22 | hott axiom I : Type := Quot I.rel 23 | hott abbreviation Interval := I 24 | 25 | namespace Interval 26 | hott axiom ofBool : 𝟐 → I := Quot.mk I.rel 27 | 28 | hott definition i₀ : I := ofBool false 29 | hott definition i₁ : I := ofBool true 30 | 31 | hott opaque axiom seg : i₀ = i₁ := 32 | trustHigherCtor (Quot.sound I.rel.intro) 33 | 34 | def hrec (B : I → Type u) (b₀ : B i₀) (b₁ : B i₁) (s : HEq b₀ b₁) (x : I) : B x := 35 | Quot.hrecOn x (λ | false => b₀ | true => b₁) 36 | (λ | false, false, _ => HEq.refl b₀ 37 | | false, true, _ => s 38 | | true, false, _ => HEq.symm s 39 | | true, true, _ => HEq.refl b₁) 40 | 41 | @[induction_eliminator] hott axiom ind {B : I → Type u} (b₀ : B i₀) (b₁ : B i₁) (s : b₀ =[seg] b₁) (x : I) : B x := 42 | Quot.withUseOf s (hrec B b₀ b₁ (HEq.fromPathover seg s) x) x 43 | 44 | hott opaque axiom indβrule {B : I → Type u} (b₀ : B i₀) (b₁ : B i₁) 45 | (s : b₀ =[seg] b₁) : apd (ind b₀ b₁ s) seg = s := 46 | trustCoherence 47 | 48 | attribute [irreducible] I 49 | 50 | noncomputable instance : OfNat I Nat.zero := ⟨i₀⟩ 51 | noncomputable instance : OfNat I (Nat.succ Nat.zero) := ⟨i₁⟩ 52 | 53 | hott abbreviation left := i₀ 54 | hott abbreviation right := i₁ 55 | 56 | hott abbreviation zero := i₀ 57 | hott abbreviation one := i₁ 58 | 59 | @[inline] hott definition rec {B : Type u} (b₀ : B) (b₁ : B) (s : b₀ = b₁) : I → B := 60 | ind b₀ b₁ (Equiv.pathoverOfEq seg s) 61 | 62 | hott definition recβrule {B : Type u} (b₀ b₁ : B) 63 | (s : b₀ = b₁) : ap (rec b₀ b₁ s) seg = s := 64 | begin 65 | apply Equiv.pathoverOfEqInj seg; transitivity; 66 | symmetry; apply Equiv.apdOverConstantFamily; apply indβrule 67 | end 68 | 69 | hott definition homotopy {A : Type u} {B : A → Type v} 70 | {f g : Π x, B x} (p : f ~ g) (x : A) : I → B x := 71 | Interval.rec (f x) (g x) (p x) 72 | 73 | hott definition funext {A : Type u} {B : A → Type v} 74 | {f g : Π x, B x} (p : f ~ g) : f = g := 75 | @ap I (Π x, B x) 0 1 (λ i x, homotopy p x i) seg 76 | 77 | hott definition happly {A : Type u} {B : A → Type v} 78 | {f g : Π x, B x} (p : f = g) : f ~ g := 79 | transport (λ g, f ~ g) p (Homotopy.id f) 80 | 81 | hott lemma happlyRev {A : Type u} {B : A → Type v} 82 | {f g : Π x, B x} (p : f = g) : happly p⁻¹ = Homotopy.symm _ _ (happly p) := 83 | begin induction p; reflexivity end 84 | 85 | hott lemma happlyCom {A : Type u} {B : A → Type v} {f g h : Π x, B x} 86 | (p : f = g) (q : g = h) : happly (p ⬝ q) = Homotopy.trans (happly p) (happly q) := 87 | begin induction p; reflexivity end 88 | 89 | hott definition mapHapply {A : Type u} {B : Type v} {C : Type w} {a b : A} {c : B} 90 | (f : A → B → C) (p : a = b) : ap (f · c) p = happly (ap f p) c := 91 | begin induction p; reflexivity end 92 | end Interval 93 | 94 | end GroundZero.HITs 95 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Hopf.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Fibration 2 | import GroundZero.HITs.Circle 3 | 4 | open GroundZero GroundZero.HITs GroundZero.Types.Equiv 5 | open GroundZero.Structures GroundZero.Types 6 | open GroundZero.Types.Id (ap) 7 | open GroundZero.Proto (idfun) 8 | 9 | namespace GroundZero.Theorems.Hopf 10 | 11 | namespace Real 12 | open HITs.Circle 13 | 14 | -- Real (S⁰ ↪ S¹ ↠ S¹) 15 | hott definition family : S¹ → Type := Circle.rec S⁰ (ua negBoolEquiv) 16 | hott definition total : Type := Σ x, family x 17 | 18 | hott definition inj (x : S⁰) : total := ⟨base, x⟩ 19 | 20 | hott definition map : total → S¹ := Sigma.fst 21 | 22 | hott def μ₁ : total := ⟨base, false⟩ 23 | hott def μ₂ : total := ⟨base, true⟩ 24 | 25 | hott abbreviation μ := μ₁ 26 | 27 | hott definition μLoop : μ = μ := 28 | Sigma.prod (loop ⬝ loop) (Circle.Ωrecβ₂ false not not negNeg negNeg loop ⬝ 29 | ap not (Circle.Ωrecβ₂ false not not negNeg negNeg (idp base))) 30 | 31 | hott statement mapRecμ : map ∘ rec μ μLoop ~ rec base (loop ⬝ loop) := 32 | begin 33 | fapply ind; exact idp base; apply Id.trans; apply Equiv.transportOverHmtpy; 34 | transitivity; apply ap (· ⬝ _ ⬝ _); transitivity; apply Id.mapInv; apply ap; 35 | transitivity; apply Equiv.mapOverComp; transitivity; apply ap; apply recβrule₂; 36 | apply Sigma.mapFstOverProd; transitivity; symmetry; apply Id.assoc; 37 | apply Id.compReflIfEq; symmetry; apply recβrule₂ 38 | end 39 | 40 | hott lemma family.transport₁ : transport family loop ~ not := 41 | begin 42 | intro b; transitivity; apply transportToTransportconst; 43 | transitivity; apply ap (transportconst · b); 44 | apply recβrule₂; apply uaβ 45 | end 46 | 47 | hott lemma family.transport₂ : transport family loop⁻¹ ~ not := 48 | begin 49 | intro b; transitivity; apply transportToTransportconst; 50 | transitivity; apply ap (transportconst · b); 51 | transitivity; apply Id.mapInv; apply ap; 52 | apply recβrule₂; apply uaβrev 53 | end 54 | end Real 55 | 56 | namespace Complex 57 | -- Complex (S¹ ↪ S³ ↠ S²) 58 | hott def family : S² → Type := Suspension.rec S¹ S¹ (ua ∘ Circle.μₑ) 59 | end Complex 60 | 61 | end GroundZero.Theorems.Hopf 62 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Pullback.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Equiv 2 | 3 | open GroundZero GroundZero.Types 4 | open GroundZero.Structures 5 | 6 | open GroundZero.Types.Id (ap) 7 | open HITs.Interval (happly) 8 | 9 | universe u v w k 10 | 11 | namespace GroundZero.Theorems 12 | 13 | section 14 | variable {P : Type k} {A : Type u} {B : Type v} {C : Type w} (η : hcommSquare P A B C) 15 | 16 | hott lemma terminalPullback : pullback (𝟏 → C) (λ f, η.right ∘ f) (λ g, η.bot ∘ g) ≃ pullback C η.right η.bot := 17 | begin 18 | fapply Sigma.mk; { intro w; existsi (w.1.1 ★, w.1.2 ★); apply happly w.2 ★ }; apply Qinv.toBiinv; 19 | fapply Sigma.mk; { intro w; existsi (λ _, w.1.1, λ _, w.1.2); apply funext; intro; apply w.2 }; apply Prod.mk <;> intro w; 20 | { apply ap (Sigma.mk _); apply happly (happlyFunext _ _ _) }; 21 | { apply ap (Sigma.mk _); transitivity; 22 | apply ap funext; change _ = happly w.2; apply funext; 23 | intro c; induction c; reflexivity; apply funextHapply } 24 | end 25 | end 26 | 27 | section 28 | variable {P : Type k} {A : Type u} {B : Type v} {C : Type w} (η : pullbackSquare P A B C) 29 | 30 | hott theorem pullbackCorner : P ≃ pullback C η.1.right η.1.bot := 31 | begin 32 | apply Equiv.trans; apply Structures.terminalArrow; 33 | apply Equiv.trans; fapply Sigma.mk; exact η.1.induced 𝟏; 34 | apply η.2; apply terminalPullback 35 | end 36 | end 37 | 38 | end GroundZero.Theorems 39 | -------------------------------------------------------------------------------- /GroundZero/Theorems/Weak.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Structures 2 | open GroundZero.Types.Equiv 3 | open GroundZero.Structures 4 | open GroundZero.Types.Id 5 | open GroundZero.Types 6 | 7 | /- 8 | See Appendix A in “On the homotopy groups of spheres in homotopy type theory”, Guillaume Brunerie. 9 | https://arxiv.org/abs/1606.05916 10 | 11 | Directed version is given in the “A Type-Theoretical Definition of Weak ω-Categories”, Eric Finster, Samuel Mimram. 12 | * https://arxiv.org/abs/1706.02866 13 | * https://github.com/ericfinster/catt.io 14 | * https://github.com/ericfinster/catt 15 | * https://github.com/smimram/catt 16 | * https://github.com/thibautbenjamin/catt 17 | -/ 18 | 19 | universe u v 20 | 21 | def Array.push₂ {A : Type u} (α : Array A) (x y : A) := (α.push x).push y 22 | def Array.tail {A : Type u} (α : Array A) := α.extract 1 α.size 23 | 24 | namespace GroundZero 25 | 26 | hott definition Con.bundle (A : Type u) : ℕ → Σ (X : Type (u + 1)), X → Type (u + 1) 27 | | Nat.zero => ⟨𝟏, λ _, 𝟏⟩ 28 | | Nat.succ n => ⟨Σ (w : (Con.bundle A n).1), (Con.bundle A n).2 w → Type⁎ u, 29 | λ T, Σ (Δ : (Con.bundle A n).2 T.1) (y : (T.2 Δ).1), (T.2 Δ).2 = y⟩ 30 | 31 | /-- Type of *contractible contexts* used to define the coherence operations. -/ 32 | hott definition Con (A : Type u) (n : ℕ) := 33 | (Con.bundle A n).1 34 | 35 | /-- Reflection of contractible context into our type theory. -/ 36 | hott definition Con.ref {A : Type u} {n : ℕ} (Γ : Con A n) := 37 | (Con.bundle A n).2 Γ 38 | 39 | macro:max atomic("ǀ" noWs) Γ:term noWs "ǀ" : term => `(Con.ref $Γ) 40 | 41 | -- Reflection of a contractible context is truly contractible. 42 | hott lemma Con.contr (A : Type u) : Π (n : ℕ) (Γ : Con A n), contr ǀΓǀ 43 | | Nat.zero, _ => unitIsContr 44 | | Nat.succ n, Γ => contrRespectsSigma (Con.contr A n Γ.1) (λ _, singl.contr _) 45 | 46 | hott definition idcon (A : Type u) {n : ℕ} {Γ : Con A n} : ǀΓǀ := 47 | (Con.contr A n Γ).1 48 | 49 | section 50 | variable {A : Type u} 51 | 52 | hott definition Con.nil : Con A 0 := ★ 53 | hott definition Ref.nil : ǀ@Con.nil Aǀ := ★ 54 | 55 | variable {n : ℕ} {Γ : Con A n} 56 | 57 | hott definition Con.cons (T : ǀΓǀ → Type u) (u : Π Δ, T Δ) : Con A (n + 1) := 58 | ⟨Γ, λ Δ, ⟨T Δ, u Δ⟩⟩ 59 | 60 | variable {T : ǀΓǀ → Type u} {u : Π Δ, T Δ} 61 | hott definition Ref.cons (Δ : ǀΓǀ) (x : T Δ) (p : u Δ = x) : ǀCon.cons T uǀ := 62 | ⟨Δ, ⟨x, p⟩⟩ 63 | end 64 | 65 | section 66 | variable {A : Type u} {n : ℕ} (ε : A → Con A n) (C : Π (a : A), ǀε aǀ → Type v) (c : Π (a : A), C a (idcon A)) 67 | 68 | hott definition Coh : Π a Δ, C a Δ := 69 | λ a Δ, transport (C a) ((Con.contr A n (ε a)).2 Δ) (c a) 70 | 71 | hott lemma cohβ (a : A) : Coh ε C c a (idcon A) = c a := 72 | begin 73 | transitivity; apply ap (transport _ · _); show _ = idp _; 74 | apply propIsSet; apply contrImplProp; apply Con.contr; reflexivity 75 | end 76 | end 77 | 78 | section 79 | open Lean Lean.Elab 80 | 81 | abbrev natLit := mkLit ∘ Literal.natVal 82 | abbrev sigfst := mkProj ``Sigma 0 83 | abbrev sigsnd := mkProj ``Sigma 1 84 | 85 | elab tag:"coh " σs:many1(bracketedBinder) ", " σ:term : term => do { 86 | Term.elabBinders σs fun con => do { 87 | let C ← Term.elabType σ; 88 | let lctx ← MonadLCtx.getLCtx; 89 | 90 | let mut tele := con.toList; 91 | let fv := tele.head!; 92 | let fvdecl := lctx.getFVar! fv 93 | let A := fvdecl.type; 94 | 95 | let some l₁ := (← Meta.inferType A).sortLevel!.dec | throwErrorAt (σs.get! 0) "expected to be a Type"; 96 | let some l₂ := (← Meta.inferType C).sortLevel!.dec | throwErrorAt σ "expected to be a Type"; 97 | 98 | let ref := mkApp (mkConst ``Con.ref [l₁]) A; 99 | let conCons := mkApp (mkConst ``Con.cons [l₁]) A; 100 | let refCons := mkApp (mkConst ``Ref.cons [l₁]) A; 101 | 102 | let mut Δ := mkApp (mkConst ``Con.nil [l₁]) A; 103 | let mut δ := mkApp (mkConst ``Ref.nil [l₁]) A; 104 | 105 | let mut k := 0; 106 | 107 | let mut fvs : Array Expr := #[]; 108 | let mut evs : Array Expr := #[]; 109 | 110 | tele := tele.tail!; 111 | 112 | while !tele.isEmpty do { 113 | if tele.length < 2 then throwErrorAt σs.back! 114 | "contractible context expected to be in the form “... (b : A) (p : u = b)”"; 115 | 116 | let b₁ := tele.head!; 117 | let b₂ := tele.tail!.head!; 118 | let T := (lctx.getFVar! b₁).type; 119 | let U := (lctx.getFVar! b₂).type; 120 | 121 | unless (U.isAppOfArity ``GroundZero.Types.Id 3) 122 | do throwErrorAt (σs.get! (2 * k + 2)) 123 | "expected to be a path type"; 124 | 125 | let #[_, u, y] := U.getAppArgs | unreachable!; 126 | unless (← Meta.isDefEq y b₁) 127 | do throwErrorAt (σs.get! (2 * k + 2)) 128 | "expected to be in the form “... = {← Meta.ppExpr b₁}”"; 129 | 130 | let ρ' := mkApp2 ref (natLit k) Δ; 131 | let Δ' := mkLambda `Δ BinderInfo.default ρ' (Expr.replaceFVars T fvs evs); 132 | let u' := mkLambda `Δ BinderInfo.default ρ' (Expr.replaceFVars u fvs evs); 133 | 134 | δ := mkApp7 refCons (natLit k) Δ Δ' u' δ b₁ b₂; 135 | Δ := mkApp4 conCons (natLit k) Δ Δ' u'; 136 | 137 | k := k + 1; 138 | 139 | evs := evs.map (·.instantiate #[sigfst (mkBVar 0)]); 140 | 141 | fvs := fvs.push₂ b₁ b₂; 142 | evs := evs.push₂ (sigfst (sigsnd (mkBVar 0))) (sigsnd (sigsnd (mkBVar 0))); 143 | 144 | tele := tele.tail!.tail!; 145 | } 146 | 147 | Meta.withNewBinderInfos #[(fvdecl.fvarId, BinderInfo.default)] do { 148 | let ρ := mkApp2 ref (natLit k) Δ; 149 | let C := (← instantiateMVars C).replaceFVars fvs evs; 150 | 151 | let idcon := mkApp3 (mkConst ``idcon [l₁]) A (natLit k) Δ; 152 | let apcoh := (← Meta.mkLambdaFVars #[fv] (mkLambda `Δ BinderInfo.default ρ C)) 153 | |> mkApp4 (mkConst ``Coh [l₁, l₂]) A (natLit k) 154 | (← Meta.mkLambdaFVars #[fv] Δ); 155 | 156 | let idc ← Meta.mkForallFVars #[fv] (mkLet `Δ ρ idcon C); 157 | return (← mkApp3 apcoh (mkBVar (2 * k + 2)) (mkBVar (2 * k + 1)) δ 158 | |> Meta.mkLambdaFVars con.tail) 159 | |>.replaceFVar fv (mkBVar 0) 160 | |> mkLambda fvdecl.userName fvdecl.binderInfo fvdecl.type 161 | |> mkLambda `ε BinderInfo.default idc 162 | }; 163 | } 164 | } 165 | end 166 | 167 | namespace Example 168 | hott definition rev {A : Type u} {a b : A} (p : a = b) : b = a := 169 | (coh (a : A) (b : A) (p : a = b), b = a) idp a b p 170 | 171 | hott definition com {A : Type u} {a b c : A} (p : a = b) (q : b = c) : a = c := 172 | (coh (a : A) (b : A) (p : a = b) (c : A) (q : b = c), a = c) idp a b p c q 173 | 174 | hott definition invol {A : Type u} {a b : A} (p : a = b) : p = rev (rev p) := 175 | (coh {a : A} {b : A} (p : a = b), p = rev (rev p)) (λ x, idp (idp x)) p 176 | 177 | -- p⁻¹ is defined directly in terms of J rule 178 | hott remark revRev {A : Type u} {a b : A} (p : a = b) : rev p = p⁻¹ := 179 | (coh {a : A} {b : A} (p : a = b), rev p = p⁻¹) (λ x, idp (idp x)) p 180 | 181 | hott definition lu {A : Type u} {a b : A} (p : a = b) : com (idp a) p = p := 182 | (coh {a : A} {b : A} (p : a = b), com (idp a) p = p) (λ x, idp (idp x)) p 183 | 184 | hott definition ru {A : Type u} {a b : A} (p : a = b) : com p (idp b) = p := 185 | (coh {a : A} {b : A} (p : a = b), com p (idp b) = p) (λ x, idp (idp x)) p 186 | 187 | hott definition assoc {A : Type u} {a b c d : A} (p : a = b) (q : b = c) (r : c = d) : p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r := 188 | (coh {a : A} {b : A} (p : a = b) {c : A} (q : b = c) {d : A} (r : c = d), p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r) (λ x, idp (idp x)) p q r 189 | 190 | variable (A : Type u) (a : A) 191 | #success assoc (idp a) (idp a) (idp a) ≡ idp (idp a) 192 | end Example 193 | 194 | end GroundZero 195 | -------------------------------------------------------------------------------- /GroundZero/Types/Category.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Precategory 2 | 3 | open GroundZero.Types.Precategory (idtoiso) 4 | open GroundZero.Types.Equiv 5 | open GroundZero.Structures 6 | 7 | namespace GroundZero.Types 8 | universe u v 9 | 10 | hott definition Category := 11 | Σ (A : Precategory), Π a b, biinv (@idtoiso A a b) 12 | 13 | namespace Category 14 | variable (A : Category) 15 | 16 | hott abbreviation obj := A.1.obj 17 | hott abbreviation hom := A.1.hom 18 | 19 | hott definition set : Π (x y : A.obj), hset (hom A x y) := A.1.set 20 | 21 | attribute [irreducible] set 22 | 23 | hott abbreviation id : Π {a : A.obj}, hom A a a := A.1.id 24 | 25 | hott abbreviation comp {A : Category} {a b c : A.obj} 26 | (f : hom A b c) (g : hom A a b) : hom A a c := 27 | A.1.com f g 28 | 29 | local infix:60 " ∘ " => comp 30 | 31 | hott abbreviation lu : Π {a b : A.obj} (f : hom A a b), id A ∘ f = f := A.1.lu 32 | hott abbreviation ru : Π {a b : A.obj} (f : hom A a b), f ∘ id A = f := A.1.ru 33 | hott abbreviation assoc : Π {a b c d : A.obj} (f : hom A a b) (g : hom A b c) (h : hom A c d), h ∘ (g ∘ f) = (h ∘ g) ∘ f := A.1.assoc 34 | 35 | hott abbreviation iso (a b : A.obj) := Precategory.iso A.1 a b 36 | 37 | hott abbreviation idtoiso {a b : A.obj} : a = b → iso A a b := 38 | Precategory.idtoiso A.1 39 | 40 | hott definition univalence {a b : A.obj} : (a = b) ≃ (iso A a b) := 41 | ⟨idtoiso A, A.snd a b⟩ 42 | 43 | hott definition ua {a b : A.obj} : iso A a b → a = b := 44 | (univalence A).left 45 | 46 | hott definition uaβrule₁ {a b : A.obj} (φ : iso A a b) : idtoiso A (ua A φ) = φ := 47 | (univalence A).forwardLeft φ 48 | 49 | hott definition uaβrule₂ {a b : A.obj} (φ : a = b) : ua A (idtoiso A φ) = φ := 50 | (univalence A).leftForward φ 51 | 52 | hott definition Mor (A : Category) := Σ (x y : A.obj), hom A x y 53 | 54 | hott definition twoOutOfThree {a b c : A.obj} (g : hom A b c) (f : hom A a b) (K : Π (x y : A.obj), hom A x y → Type v) := 55 | (K a b f → K b c g → K a c (g ∘ f)) × (K a c (g ∘ f) → K b c g → K a b f) × (K a b f → K a c (g ∘ f) → K b c g) 56 | end Category 57 | 58 | end GroundZero.Types 59 | -------------------------------------------------------------------------------- /GroundZero/Types/CellComplex.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.HITs.Sphere 2 | open GroundZero.HITs 3 | 4 | universe u v w 5 | 6 | namespace GroundZero 7 | namespace Types 8 | 9 | /- https://github.com/leanprover/lean2/blob/master/hott/homotopy/cellcomplex.hlean 10 | Cellular Cohomology in Homotopy Type Theory, https://arxiv.org/abs/1802.02191 11 | -/ 12 | 13 | hott definition Model := 14 | Σ (X : Type u), X → Type v 15 | 16 | hott definition FdCC : ℕ → Model 17 | | Nat.zero => ⟨Set u, Sigma.pr₁⟩ 18 | | Nat.succ n => ⟨Σ (X : (FdCC n).1) (A : Set u), A.1 × Sⁿ → (FdCC n).2 X, λ w, Pushout Prod.pr₁ w.2.2⟩ 19 | 20 | -- finite-dimensional cell complex 21 | hott definition fdcc (n : ℕ) := (FdCC n).1 22 | 23 | -- and its homotopy type (i.e. ∞-groupoid) 24 | hott definition fdcc.ωGroupoid {n : ℕ} (X : fdcc n) := (FdCC n).2 X 25 | notation "Πω" => fdcc.ωGroupoid 26 | 27 | end Types 28 | end GroundZero 29 | -------------------------------------------------------------------------------- /GroundZero/Types/Coproduct.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | 3 | open GroundZero.Types.Id (ap) 4 | open GroundZero.Proto 5 | 6 | namespace GroundZero.Types 7 | universe u v w w' 8 | 9 | hott definition Coproduct (A : Type u) (B : Type v) := Sum A B 10 | 11 | infixl:65 " + " => Coproduct 12 | 13 | attribute [induction_eliminator] Sum.casesOn 14 | 15 | namespace Coproduct 16 | variable {A : Type u} {B : Type v} 17 | 18 | @[match_pattern] hott abbreviation inl : A → A + B := Sum.inl 19 | @[match_pattern] hott abbreviation inr : B → A + B := Sum.inr 20 | 21 | hott definition elim {C : Type w} (g₀ : A → C) (g₁ : B → C) : A + B → C 22 | | inl a => g₀ a 23 | | inr b => g₁ b 24 | 25 | hott definition bimap {C : Type w} {C' : Type w'} (f : A → C) (g : B → C') : A + B → C + C' := 26 | elim (Sum.inl ∘ f) (Sum.inr ∘ g) 27 | 28 | hott definition inv : A + B → B + A 29 | | inl x => inr x 30 | | inr x => inl x 31 | 32 | hott definition symm : A + B ≃ B + A := 33 | begin 34 | existsi inv; apply Qinv.toBiinv; existsi inv; 35 | apply Prod.mk <;> { intro x; induction x using Sum.casesOn <;> reflexivity } 36 | end 37 | 38 | namespace inl 39 | hott definition code (a₀ : A) : A + B → Type u 40 | | inl a => a₀ = a 41 | | inr b => 𝟎 42 | 43 | hott definition encode {a₀ : A} {x : A + B} (p : inl a₀ = x) : code a₀ x := 44 | Equiv.transport (code a₀) p (idp a₀) 45 | 46 | hott definition decode {a₀ : A} : Π {x : A + B} (c : code a₀ x), inl a₀ = x 47 | | inl a, c => ap inl c 48 | | inr b, c => explode c 49 | 50 | hott statement decodeEncode {a₀ : A} {x : A + B} 51 | (p : inl a₀ = x) : decode (encode p) = p := 52 | begin induction p; reflexivity end 53 | 54 | hott lemma encodeDecode {a₀ : A} {x : A + B} : Π (c : code a₀ x), encode (decode c) = c := 55 | begin 56 | induction x using Sum.casesOn; intro (p : a₀ = _); 57 | induction p; apply idp; apply Proto.Empty.casesOn 58 | end 59 | 60 | hott lemma recognize (a₀ : A) (x : A + B) : (inl a₀ = x) ≃ code a₀ x := 61 | begin 62 | existsi encode; apply Qinv.toBiinv; existsi decode; 63 | apply Prod.mk; apply encodeDecode; apply decodeEncode 64 | end 65 | 66 | hott corollary inj' (x y : A) : @Id (A + B) (inl x) (inl y) ≃ (x = y) := 67 | recognize x (inl y) 68 | 69 | hott corollary inlInr (x : A) (y : B) : @Id (A + B) (inl x) (inr y) ≃ 𝟎 := 70 | recognize x (inr y) 71 | end inl 72 | 73 | namespace inr 74 | hott definition code (b₀ : B) : A + B → Type v 75 | | inl a => 𝟎 76 | | inr b => b₀ = b 77 | 78 | hott definition encode {b₀ : B} {x : A + B} (p : inr b₀ = x) : code b₀ x := 79 | Equiv.transport (code b₀) p (idp b₀) 80 | 81 | hott definition decode {b₀ : B} : Π {x : A + B} (c : code b₀ x), inr b₀ = x 82 | | inl a, c => explode c 83 | | inr b, c => ap inr c 84 | 85 | hott statement decodeEncode {b₀ : B} {x : A + B} 86 | (p : inr b₀ = x) : decode (encode p) = p := 87 | begin induction p; reflexivity end 88 | 89 | hott lemma encodeDecode {b₀ : B} {x : A + B} : Π (c : code b₀ x), encode (decode c) = c := 90 | begin 91 | induction x using Sum.casesOn; apply Proto.Empty.casesOn; 92 | intro (p : b₀ = _); induction p; apply idp; 93 | end 94 | 95 | hott lemma recognize (b₀ : B) (x : A + B) : (inr b₀ = x) ≃ code b₀ x := 96 | begin 97 | existsi encode; apply Qinv.toBiinv; existsi decode; 98 | apply Prod.mk; apply encodeDecode; apply decodeEncode 99 | end 100 | 101 | hott corollary inj' (x y : B) : @Id (A + B) (inr x) (inr y) ≃ (x = y) := 102 | recognize x (inr y) 103 | 104 | hott corollary inrInl (x : B) (y : A) : @Id (A + B) (inr x) (inl y) ≃ 𝟎 := 105 | recognize x (inl y) 106 | end inr 107 | 108 | hott definition code {A B : Type u} : A + B → A + B → Type u 109 | | inl a => inl.code a 110 | | inr b => inr.code b 111 | 112 | hott definition pathSum {A B : Type u} (z₁ z₂ : A + B) (p : code z₁ z₂) : z₁ = z₂ := 113 | begin 114 | induction z₁ using Sum.casesOn <;> induction z₂ using Sum.casesOn; 115 | apply ap; assumption; apply explode p; 116 | apply explode p; apply ap; assumption 117 | end 118 | end Coproduct 119 | 120 | end GroundZero.Types 121 | -------------------------------------------------------------------------------- /GroundZero/Types/Ens.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Univalence 2 | open GroundZero.Structures 3 | 4 | namespace GroundZero 5 | 6 | namespace Types 7 | universe u v w 8 | 9 | hott definition Ens (A : Type u) : Type (max u (v + 1)) := 10 | Σ (φ : A → Type v), Π x, prop (φ x) 11 | 12 | hott abbreviation Ens.contains {A : Type u} (x : A) (s : Ens A) : Type v := s.1 x 13 | infix:80 (priority := high) " ∈ " => Ens.contains 14 | 15 | hott definition Ens.prop {A : Type u} (x : A) (s : Ens A) : prop (x ∈ s) := s.2 x 16 | attribute [irreducible] Ens.prop 17 | 18 | hott abbreviation Ens.subtype {A : Type u} (s : Ens A) := Σ x, s.1 x 19 | 20 | hott definition Ens.univ (A : Type u) : Ens A := 21 | ⟨λ _, 𝟏, λ _, unitIsProp⟩ 22 | 23 | hott definition Ens.empty (A : Type u) : Ens A := 24 | ⟨λ _, 𝟎, λ _, emptyIsProp⟩ 25 | 26 | notation "∅" => Ens.empty _ 27 | 28 | hott definition Ens.union {A : Type u} (a b : Ens A) : Ens A := 29 | ⟨λ x, ∥(x ∈ a) + (x ∈ b)∥, λ _, HITs.Merely.uniq⟩ 30 | infixl:60 " ∪ " => Ens.union 31 | 32 | hott definition Ens.sunion {A : Type u} (φ : Ens.{u, v} A → Type w) : Ens A := 33 | ⟨λ x, ∥(Σ (s : Ens.{u, v} A), x ∈ s × φ s)∥, λ _, HITs.Merely.uniq⟩ 34 | 35 | hott definition Ens.iunion {A : Type u} {β : Type v} (φ : A → Ens β) : Ens β := 36 | ⟨λ x, ∥(Σ y, x ∈ φ y)∥, λ _, HITs.Merely.uniq⟩ 37 | prefix:110 "⋃" => Ens.iunion 38 | 39 | hott definition Ens.inter {A : Type u} (a b : Ens A) : Ens A := 40 | ⟨λ x, x ∈ a × x ∈ b, begin intro; apply Structures.productProp <;> apply Ens.prop end⟩ 41 | infixl:60 " ∩ " => Ens.inter 42 | 43 | hott definition Ens.smallest {A : Type u} (φ : Ens.{u, v} A → Type w) : Ens A := 44 | ⟨λ x, ∀ (s : Ens.{u, v} A), φ s → x ∈ s, λ y, begin 45 | apply Structures.piProp; intro; 46 | apply Structures.implProp; apply Ens.prop 47 | end⟩ 48 | 49 | hott definition Ens.infInter {A : Type u} (φ : Ens (Ens A)) : Ens A := Ens.smallest φ.1 50 | 51 | hott definition Ens.ssubset {A : Type u} (φ : Ens.{u, v} A) (ψ : Ens.{u, w} A) := 52 | Π x, x ∈ φ → x ∈ ψ 53 | 54 | infix:50 " ⊆ " => Ens.ssubset 55 | 56 | hott lemma Ens.ssubset.prop {A : Type u} (φ : Ens.{u, v} A) (ψ : Ens.{u, w} A) : Structures.prop (φ ⊆ ψ) := 57 | begin apply piProp; intro; apply implProp; apply Ens.prop end 58 | 59 | hott lemma Ens.ssubset.refl {A : Type u} (φ : Ens A) : φ ⊆ φ := 60 | begin intro; apply id end 61 | 62 | hott lemma Ens.ssubset.trans {A : Type u} {a b c : Ens A} : a ⊆ b → b ⊆ c → a ⊆ c := 63 | λ G H x p, H x (G x p) 64 | 65 | noncomputable instance {A : Type u} : @Reflexive (Ens A) Ens.ssubset := ⟨Ens.ssubset.refl⟩ 66 | noncomputable instance {A : Type u} : @Transitive (Ens A) Ens.ssubset := ⟨@Ens.ssubset.trans A⟩ 67 | 68 | hott definition Ens.parallel {A : Type u} (a b : Ens A) := a ∩ b ⊆ ∅ 69 | 70 | hott definition Ens.image {A : Type u} {β : Type v} (φ : Ens A) (f : A → β) : Ens β := 71 | ⟨λ y, ∥(Σ x, f x = y × x ∈ φ)∥, λ _, HITs.Merely.uniq⟩ 72 | 73 | hott definition Ens.ext {A : Type u} {φ ψ : Ens A} (H : Π x, x ∈ φ ↔ x ∈ ψ) : φ = ψ := 74 | begin 75 | fapply Sigma.prod; apply Theorems.funext; intro x; 76 | { apply ua; apply Structures.propEquivLemma; 77 | apply φ.2; apply ψ.2; apply (H x).left; apply (H x).right }; 78 | { apply piProp; intro; apply propIsProp } 79 | end 80 | 81 | hott definition Ens.ssubset.asymm {A : Type u} {φ ψ : Ens A} 82 | (f : φ ⊆ ψ) (g : ψ ⊆ φ) : φ = ψ := 83 | Ens.ext (λ x, ⟨f x, g x⟩) 84 | 85 | hott lemma Ens.hset {A : Type u} (s : Ens A) (H : hset A) : hset s.subtype := 86 | begin 87 | apply hsetRespectsSigma; apply H; 88 | { intro; apply propIsSet; apply s.2 } 89 | end 90 | 91 | hott definition predicate (A : Type u) := A → Prop v 92 | 93 | hott lemma Ens.eqvPredicate {A : Type u} : Ens A ≃ predicate A := 94 | begin 95 | fapply Sigma.mk; { intros φ x; existsi φ.1 x; apply φ.2 }; apply Qinv.toBiinv; fapply Sigma.mk; 96 | { intro φ; existsi (λ x, (φ x).1); intro x; apply (φ x).2 }; fapply Prod.mk <;> intro φ; 97 | { apply Theorems.funext; intro; apply Theorems.Equiv.propset.Id; reflexivity }; 98 | { fapply Sigma.prod <;> apply Theorems.funext <;> intro x; reflexivity; apply propIsProp } 99 | end 100 | 101 | hott lemma Ens.isset {A : Type u} : Structures.hset (Ens A) := 102 | begin 103 | apply hsetRespectsEquiv; symmetry; apply Ens.eqvPredicate; 104 | apply piHset; intro; apply Theorems.Equiv.propsetIsSet 105 | end 106 | 107 | hott definition Ens.inh {A : Type u} (φ : Ens A) := ∥φ.subtype∥ 108 | 109 | hott definition Ens.singleton {A : Type u} (H : Structures.hset A) (x : A) : Ens A := 110 | ⟨λ y, x = y, @H x⟩ 111 | 112 | hott definition Ens.singletonInh {A : Type u} (H : Structures.hset A) (x : A) : Ens.inh (Ens.singleton @H x) := 113 | HITs.Merely.elem ⟨x, Id.refl⟩ 114 | 115 | end Types 116 | end GroundZero 117 | -------------------------------------------------------------------------------- /GroundZero/Types/HEq.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | 3 | open GroundZero.Types.Equiv (transport) 4 | 5 | namespace GroundZero.Types.HEq 6 | 7 | universe u v 8 | 9 | hott definition inclusion {A : Type u} {a b : A} (p : a = b) : HEq a b := 10 | begin induction p; apply HEq.refl end 11 | 12 | hott definition map {A : Type u} {B : A → Type v} {a b : A} 13 | (f : Π x, B x) (p : a = b) : HEq (f a) (f b) := 14 | begin induction p; apply HEq.refl end 15 | 16 | hott definition onlyRefl {A : Type u} {a b : A} (p : a = b) : HEq p (idp a) := 17 | begin induction p; apply HEq.refl end 18 | 19 | hott definition eqSubstHEq {A : Type u} {B : A → Type v} {a b : A} 20 | (p : a = b) (x : B a) : HEq x (transport B p x) := 21 | begin induction p; apply HEq.refl end 22 | 23 | hott definition fromPathover {A : Type u} {B : A → Type v} {a b : A} 24 | (p : a = b) {u : B a} {v : B b} (q : u =[p] v) : HEq u v := 25 | begin induction p; induction q; apply HEq.refl end 26 | 27 | end GroundZero.Types.HEq 28 | -------------------------------------------------------------------------------- /GroundZero/Types/Lost.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | open GroundZero.Proto 3 | 4 | namespace GroundZero.Types 5 | 6 | universe u 7 | 8 | hott definition uninhabitedType {A : Type u} (f : A → 𝟎) : A ≃ 𝟎 := 9 | begin 10 | apply Sigma.mk f; apply Qinv.toBiinv; 11 | apply Sigma.mk (@explode A); 12 | apply Prod.mk <;> intro x; 13 | induction x; induction f x 14 | end 15 | 16 | inductive Lost (A : Type u) 17 | | cons : A → Lost A → Lost A 18 | 19 | namespace Lost 20 | 21 | hott definition code {A : Type u} : Lost A → 𝟎 22 | | cons x xs => code xs 23 | 24 | hott definition isZero {A : Type u} : Lost A ≃ 𝟎 := 25 | uninhabitedType code 26 | 27 | end Lost 28 | 29 | end GroundZero.Types 30 | -------------------------------------------------------------------------------- /GroundZero/Types/Nat.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Structures 2 | 3 | open GroundZero.Types.Equiv (transport) 4 | open GroundZero.Types.Id (ap) 5 | open GroundZero.Proto 6 | open GroundZero.Types 7 | open GroundZero 8 | 9 | namespace GroundZero.Types.Nat 10 | 11 | universe u v w 12 | 13 | hott definition ind {C : ℕ → Type u} (zero : C 0) (succ : Π n, C n → C (n + 1)) : Π n, C n 14 | | Nat.zero => zero 15 | | Nat.succ n => succ n (ind zero succ n) 16 | 17 | hott definition inw : ℕ → ℕ + 𝟏 18 | | Nat.zero => Coproduct.inr ★ 19 | | Nat.succ n => Coproduct.inl n 20 | 21 | hott definition outw : ℕ + 𝟏 → ℕ 22 | | Coproduct.inr _ => Nat.zero 23 | | Coproduct.inl n => Nat.succ n 24 | 25 | hott lemma natUnitEqv : ℕ ≃ ℕ + 𝟏 := 26 | begin 27 | fapply Equiv.intro; exact inw; exact outw; 28 | { intro n; induction n using Nat.casesOn <;> reflexivity }; 29 | { intro n; induction n using Sum.casesOn <;> reflexivity } 30 | end 31 | 32 | hott theorem equivAddition {A : Type u} {B : Type v} (C : Type w) (e : A ≃ B) : A + C ≃ B + C := 33 | begin 34 | let f : A + C → B + C := λ x, match x with 35 | | Coproduct.inl a => Coproduct.inl (e a) 36 | | Coproduct.inr c => Coproduct.inr c; 37 | let g : B + C → A + C := λ x, match x with 38 | | Coproduct.inl b => Coproduct.inl (e.left b) 39 | | Coproduct.inr c => Coproduct.inr c; 40 | 41 | fapply Equiv.intro; exact f; exact g; 42 | { intro x; induction x using Sum.casesOn; 43 | apply ap Sum.inl; apply e.leftForward; reflexivity }; 44 | { intro x; induction x using Sum.casesOn; 45 | apply ap Sum.inl; apply e.forwardLeft; reflexivity } 46 | end 47 | 48 | hott example : ℕ ≃ (ℕ + 𝟏) + 𝟏 := 49 | begin transitivity; exact natUnitEqv; apply equivAddition; exact natUnitEqv end 50 | 51 | hott definition natPlusUnit : Π n, ℕ ≃ pt ℕ n 52 | | Nat.zero => Equiv.ideqv _ 53 | | Nat.succ n => Equiv.trans natUnitEqv (equivAddition 𝟏 (natPlusUnit n)) 54 | 55 | hott definition liftUnit (n : ℕ) : pt 𝟏 n → pt 𝟏 (n + 1) := 56 | Coproduct.inl 57 | 58 | hott definition liftToTop (x : 𝟏) : Π n, pt 𝟏 n 59 | | Nat.zero => x 60 | | Nat.succ n => Coproduct.inl (liftToTop x n) 61 | 62 | hott definition code : ℕ → ℕ → Type 63 | | Nat.zero, Nat.zero => 𝟏 64 | | Nat.succ m, Nat.zero => 𝟎 65 | | Nat.zero, Nat.succ n => 𝟎 66 | | Nat.succ m, Nat.succ n => code m n 67 | 68 | hott definition r : Π n, code n n 69 | | Nat.zero => ★ 70 | | Nat.succ n => r n 71 | 72 | hott definition encode {m n : ℕ} (p : m = n) : code m n := 73 | transport (code m) p (r m) 74 | 75 | hott definition decode : Π {m n : ℕ}, code m n → m = n 76 | | Nat.zero, Nat.zero, p => idp 0 77 | | Nat.succ m, Nat.zero, p => explode p 78 | | Nat.zero, Nat.succ n, p => explode p 79 | | Nat.succ m, Nat.succ n, p => ap Nat.succ (decode p) 80 | 81 | hott lemma decodeEncodeIdp : Π m, decode (encode (idp m)) = idp m 82 | | Nat.zero => idp _ 83 | | Nat.succ m => ap _ (decodeEncodeIdp m) 84 | 85 | hott corollary decodeEncode {m n : ℕ} (p : m = n) : decode (encode p) = p := 86 | begin induction p; apply decodeEncodeIdp end 87 | 88 | hott lemma encodeDecode : Π {m n : ℕ} (p : code m n), encode (decode p) = p 89 | | Nat.zero, Nat.zero, ★ => idp ★ 90 | | Nat.succ m, Nat.zero, p => explode p 91 | | Nat.zero, Nat.succ n, p => explode p 92 | | Nat.succ m, Nat.succ n, p => 93 | begin 94 | transitivity; symmetry; 95 | apply @Equiv.transportComp ℕ ℕ (code (m + 1)) m n 96 | Nat.succ (decode p) (r (m + 1)); 97 | apply encodeDecode 98 | end 99 | 100 | hott theorem recognize (m n : ℕ) : m = n ≃ code m n := 101 | Equiv.intro encode decode decodeEncode encodeDecode 102 | 103 | end GroundZero.Types.Nat 104 | -------------------------------------------------------------------------------- /GroundZero/Types/Precategory.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Functions 2 | import GroundZero.Theorems.Equiv 3 | 4 | open GroundZero.Theorems.Functions 5 | open GroundZero.Types.Id (ap) 6 | open GroundZero.Types.Equiv 7 | open GroundZero.Structures 8 | open GroundZero.Theorems 9 | 10 | namespace GroundZero.Types 11 | universe u v 12 | 13 | record Precategory : Type (max u v + 1) := 14 | (obj : Type u) 15 | (hom : obj → obj → Type v) 16 | (set : Π (x y : obj), hset (hom x y)) 17 | (id : Π {a : obj}, hom a a) 18 | (com : Π {a b c : obj}, hom b c → hom a b → hom a c) 19 | (lu : Π {a b : obj} (f : hom a b), com id f = f) 20 | (ru : Π {a b : obj} (f : hom a b), com f id = f) 21 | (assoc : Π {a b c d : obj} (f : hom a b) (g : hom b c) (h : hom c d), com h (com g f) = com (com h g) f) 22 | 23 | section 24 | variable (A : Precategory) 25 | 26 | instance : Reflexive A.hom := ⟨λ _, A.id⟩ 27 | instance : Transitive A.hom := ⟨λ _ _ _ p q, A.com q p⟩ 28 | end 29 | 30 | namespace Precategory 31 | hott abbreviation compose {A : Precategory} {a b c : A.obj} (g : hom A b c) (f : hom A a b) : hom A a c := 32 | A.com g f 33 | 34 | local infix:60 " ∘ " => compose 35 | 36 | hott definition hasInv(A : Precategory) {a b : A.obj} (f : hom A a b) := 37 | Σ (g : hom A b a), (f ∘ g = id A) × (g ∘ f = id A) 38 | 39 | hott definition iso (A : Precategory) (a b : A.obj) := 40 | Σ (f : hom A a b), hasInv A f 41 | 42 | hott definition idiso (A : Precategory) {a : A.obj} : iso A a a := 43 | ⟨id A, ⟨id A, (lu A (id A), lu A (id A))⟩⟩ 44 | 45 | noncomputable instance (A : Precategory) : Reflexive (iso A) := ⟨@idiso A⟩ 46 | 47 | hott definition idtoiso (A : Precategory) {a b : A.obj} (p : a = b) : iso A a b := 48 | begin induction p; reflexivity end 49 | 50 | hott definition invProp (A : Precategory) {a b : A.obj} (f : hom A a b) : prop (hasInv A f) := 51 | begin 52 | intro ⟨g', (H₁, H₂)⟩ ⟨g, (G₁, G₂)⟩; 53 | fapply Sigma.prod; apply calc 54 | g' = id A ∘ g' : (lu _ _)⁻¹ 55 | ... = (g ∘ f) ∘ g' : ap (compose · g') G₂⁻¹ 56 | ... = g ∘ (f ∘ g') : (assoc _ _ _ _)⁻¹ 57 | ... = g ∘ id A : ap (compose g) H₁ 58 | ... = g : ru _ _; 59 | apply productProp <;> apply set 60 | end 61 | 62 | hott definition op (A : Precategory) : Precategory := 63 | ⟨A.obj, λ a b, hom A b a, λ a b, set A b a, id A, 64 | λ p q, A.com q p, λ p, A.ru p, λ p, A.lu p, λ f g h, (A.assoc h g f)⁻¹⟩ 65 | 66 | hott definition Path (A : Type u) (H : groupoid A) : Precategory := 67 | ⟨A, Id, H, idp _, λ p q, q ⬝ p, Id.rid, Id.lid, λ f g h, (Id.assoc f g h)⁻¹⟩ 68 | 69 | hott definition univalent (A : Precategory) := 70 | Π a b, biinv (@idtoiso A a b) 71 | 72 | hott definition isGroupoidIfUnivalent (A : Precategory) : univalent A → groupoid A.obj := 73 | begin 74 | intros H a b; change hset (a = b); apply hsetRespectsEquiv; 75 | symmetry; existsi idtoiso A; apply H; apply hsetRespectsSigma; 76 | apply A.set; intro; apply propIsSet; apply invProp 77 | end 78 | 79 | record Functor (A B : Precategory) := 80 | (apo : A.obj → B.obj) 81 | (apf : Π {a b : A.obj}, hom A a b → hom B (apo a) (apo b)) 82 | (apid : Π (a : A.obj), apf (@id A a) = id B) 83 | (apcom : Π {a b c : A.obj} (f : hom A b c) (g : hom A a b), apf (f ∘ g) = apf f ∘ apf g) 84 | 85 | instance (A B : Precategory) : CoeFun (Functor A B) (λ _, A.obj → B.obj) := ⟨Functor.apo⟩ 86 | 87 | section 88 | variable {A B : Precategory} (F : Functor A B) 89 | 90 | hott definition isFaithful := Π a b, injective (@Functor.apf A B F a b) 91 | hott definition isFull := Π a b, surjective (@Functor.apf A B F a b) 92 | end 93 | 94 | section 95 | variable {A B C : Precategory} 96 | 97 | hott definition Functor.com (F : Functor B C) (G : Functor A B) : Functor A C := 98 | ⟨F.apo ∘ G.apo, F.apf ∘ G.apf, λ x, ap F.apf (G.apid x) ⬝ F.apid (G x), 99 | λ f g, ap F.apf (G.apcom f g) ⬝ F.apcom (G.apf f) (G.apf g)⟩ 100 | end 101 | 102 | record Natural {A B : Precategory} (F G : Functor A B) := 103 | (com : Π x, hom B (F x) (G x)) 104 | (nat : Π {a b : A.obj} (f : hom A a b), com b ∘ F.apf f = G.apf f ∘ com a) 105 | 106 | section 107 | variable (A B : Precategory) (F G : Functor A B) 108 | instance : CoeFun (Natural F G) (λ _, Π x, hom B (F x) (G x)) := ⟨Natural.com⟩ 109 | end 110 | 111 | section 112 | variable {A B : Precategory} 113 | 114 | hott definition idn (F : Functor A B) : Natural F F := 115 | ⟨λ _, id B, λ f, lu B (F.apf f) ⬝ (ru B (F.apf f))⁻¹⟩ 116 | 117 | hott definition Natural.vert {F G H : Functor A B} (ε : Natural G H) (η : Natural F G) : Natural F H := 118 | ⟨λ x, ε x ∘ η x, λ {a b} f, (assoc B _ _ _)⁻¹ ⬝ ap (B.com (ε b)) (η.nat f) ⬝ assoc B _ _ _ ⬝ 119 | ap (B.com · (η a)) (ε.nat f) ⬝ (assoc B _ _ _)⁻¹⟩ 120 | end 121 | 122 | section 123 | variable {A B C : Precategory} {F₁ F₂ : Functor B C} {G₁ G₂ : Functor A B} 124 | 125 | hott definition Natural.horiz (ε : Natural F₁ F₂) (η : Natural G₁ G₂) : Natural (F₁.com G₁) (F₂.com G₂) := 126 | ⟨λ x, ε (G₂ x) ∘ F₁.apf (η x), λ f, ap (C.com · _) (ε.nat _) ⬝ (assoc C _ _ _)⁻¹ ⬝ ap (C.com _ ·) (ε.nat _) ⬝ 127 | assoc C _ _ _ ⬝ ap (C.com · _) ((F₂.apcom _ _)⁻¹ ⬝ ap F₂.apf (η.nat _) ⬝ 128 | F₂.apcom _ _) ⬝ (assoc C _ _ _)⁻¹ ⬝ ap (C.com _) (ε.nat _)⁻¹⟩ 129 | end 130 | 131 | hott definition isProduct (A : Precategory) (a b c : A.obj) := 132 | Σ (i : hom A c a) (j : hom A c b), 133 | ∀ (x : A.obj) (f₁ : hom A x a) (f₂ : hom A x b), 134 | contr (Σ (f : hom A x c), i ∘ f = f₁ × j ∘ f = f₂) 135 | 136 | hott definition isCoproduct (A : Precategory) (a b c : A.obj) := 137 | isProduct (op A) a b c 138 | end Precategory 139 | 140 | end GroundZero.Types 141 | -------------------------------------------------------------------------------- /GroundZero/Types/Product.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Theorems.Funext 2 | 3 | open GroundZero.Types.Equiv (bimap) 4 | open GroundZero.Types.Id (ap) 5 | 6 | namespace GroundZero.Types 7 | 8 | universe u v u' v' w 9 | 10 | namespace Product 11 | open Prod (pr₁ pr₂) 12 | 13 | variable {A : Type u} {B : Type v} 14 | 15 | hott definition elim {C : Type w} (g : A → B → C) (x : A × B) : C := 16 | g x.pr₁ x.pr₂ 17 | 18 | hott remark uniq : Π (x : A × B), (x.pr₁, x.pr₂) = x := idp 19 | 20 | hott definition prod {a b : A} {c d : B} (p : a = b) (q : c = d) : (a, c) = (b, d) := 21 | begin induction p; induction q; reflexivity end 22 | 23 | hott definition eqOfProdEq {w₁ w₂ : A × B} (ω : w₁.1 = w₂.1 × w₁.2 = w₂.2) : w₁ = w₂ := 24 | prod ω.1 ω.2 25 | 26 | hott lemma apFstProd {a b : A} {c d : B} (p : a = b) (q : c = d) : ap pr₁ (prod p q) = p := 27 | begin induction p; induction q; reflexivity end 28 | 29 | hott lemma apSndProd {a b : A} {c d : B} (p : a = b) (q : c = d) : ap pr₂ (prod p q) = q := 30 | begin induction p; induction q; reflexivity end 31 | 32 | hott corollary apFst {w₁ w₂ : A × B} (ω : w₁.1 = w₂.1 × w₁.2 = w₂.2) : ap pr₁ (eqOfProdEq ω) = ω.1 := 33 | apFstProd ω.1 ω.2 34 | 35 | hott corollary apSnd {w₁ w₂ : A × B} (ω : w₁.1 = w₂.1 × w₁.2 = w₂.2) : ap pr₂ (eqOfProdEq ω) = ω.2 := 36 | apSndProd ω.1 ω.2 37 | 38 | hott lemma mapProd {C : Type w} {a₁ a₂ : A} {b₁ b₂ : B} (f : A → B → C) 39 | (p : a₁ = a₂) (q : b₁ = b₂) : ap (λ w, f w.1 w.2) (prod p q) = bimap f p q := 40 | begin induction p; induction q; reflexivity end 41 | 42 | hott definition prod' {x y : A × B} (p : x.1 = y.1) (q : x.2 = y.2) : x = y := 43 | prod p q 44 | 45 | hott definition ind {π : A × B → Type w} (g : Π x y, π (x, y)) : Π x, π x := 46 | λ w, g w.1 w.2 47 | 48 | hott theorem univ {ν : Type w} : (ν → A × B) ≃ (ν → A) × (ν → B) := 49 | begin 50 | let e₁ : (ν → A × B) → (ν → A) × (ν → B) := 51 | λ f, (Prod.pr₁ ∘ f, Prod.pr₂ ∘ f); 52 | let e₂ : (ν → A) × (ν → B) → (ν → A × B) := 53 | λ f x, (f.pr₁ x, f.pr₂ x); 54 | existsi e₁; apply Qinv.toBiinv; 55 | existsi e₂; apply Prod.mk <;> reflexivity 56 | end 57 | 58 | hott definition bimap {C : Type u'} {D : Type v'} (f : A → C) (g : B → D) (w : A × B) : C × D := (f w.1, g w.2) 59 | 60 | hott definition swap (w : A × B) : B × A := (w.2, w.1) 61 | 62 | hott lemma comm : A × B ≃ B × A := 63 | ⟨swap, (⟨swap, idp⟩, ⟨swap, idp⟩)⟩ 64 | 65 | instance {A : Type u} {B : Type v} 66 | [OfNat A 1] [OfNat B 1] : 67 | OfNat (A × B) (Nat.succ Nat.zero) := 68 | ⟨(1, 1)⟩ 69 | end Product 70 | 71 | end GroundZero.Types 72 | -------------------------------------------------------------------------------- /GroundZero/Types/Setquot.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Ens 2 | open GroundZero.Structures 3 | 4 | namespace GroundZero 5 | universe u v w 6 | 7 | namespace Types 8 | 9 | hott definition iseqclass {A : Type u} (R : eqrel A) (φ : Ens A) := 10 | φ.inh × (Π x y, R.apply x y → x ∈ φ → y ∈ φ) × (Π x y, x ∈ φ → y ∈ φ → R.apply x y) 11 | 12 | hott definition iseqclass.prop {A : Type u} {R : eqrel A} (φ : Ens A) : prop (iseqclass R φ) := 13 | begin 14 | apply productProp; apply HITs.Merely.uniq; apply productProp; 15 | { repeat first | (apply piProp; intro) | apply Ens.prop }; 16 | { repeat first | (apply piProp; intro) | apply R.prop } 17 | end 18 | 19 | hott definition setquot {A : Type u} (R : eqrel A) := 20 | Σ (φ : Ens A), iseqclass R φ 21 | 22 | hott definition setquot.set {A : Type u} (R : eqrel A) : hset (setquot R) := 23 | begin 24 | fapply hsetRespectsSigma; apply Ens.isset; 25 | intro; apply propIsSet; apply iseqclass.prop 26 | end 27 | 28 | hott definition setquot.elem {A : Type u} {R : eqrel A} (x : A) : setquot R := 29 | ⟨⟨λ y, R.apply x y, R.prop x⟩, 30 | (HITs.Merely.elem ⟨x, R.refl x⟩, 31 | λ _ _ p q, R.trans q p, 32 | λ _ _ p q, R.trans (R.symm p) q)⟩ 33 | 34 | hott definition setquot.sound {A : Type u} {R : eqrel A} {x y : A} : 35 | R.apply x y → @setquot.elem A R x = setquot.elem y := 36 | begin 37 | intro p; fapply Types.Sigma.prod; 38 | { apply Ens.ext; intro z; apply Prod.mk <;> intro q; 39 | { apply R.trans; exact R.symm p; exact q }; 40 | { apply R.trans; exact p; exact q } }; 41 | { apply iseqclass.prop } 42 | end 43 | 44 | end Types 45 | 46 | end GroundZero 47 | -------------------------------------------------------------------------------- /GroundZero/Types/Sigma.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | 3 | open GroundZero.Types.Equiv (apd pathOverAp transport) 4 | open GroundZero.Types.Id (ap) 5 | 6 | namespace GroundZero.Types 7 | universe u v w 8 | 9 | namespace Sigma 10 | variable {A : Type u} {B : A → Type v} 11 | 12 | hott definition pr₁ (x : Σ x, B x) := x.1 13 | hott definition pr₂ (x : Σ x, B x) := x.2 14 | 15 | hott definition elim {C : Type w} (g : Π x, B x → C) (w : Sigma B) : C := g w.1 w.2 16 | 17 | hott definition Ind {π : Sigma B → Type w} (g : Π (a : A) (b : B a), π ⟨a, b⟩) : Π x, π x := 18 | λ w, g w.1 w.2 19 | 20 | hott remark uniq : Π (x : Σ x, B x), ⟨pr₁ x, pr₂ x⟩ = x := idp 21 | 22 | hott definition prod : Π {u v : Sigma B} (p : u.1 = v.1) (q : transport B p u.2 = v.2), u = v := 23 | begin 24 | intro ⟨x, u⟩ ⟨y, v⟩ (p : x = y); induction p; 25 | intro (q : u = v); induction q; apply idp 26 | end 27 | 28 | hott theorem mapFstOverProd : Π {u v : Sigma B} (p : u.1 = v.1) (q : transport B p u.2 = v.2), ap pr₁ (prod p q) = p := 29 | begin 30 | intro ⟨x, u⟩ ⟨y, v⟩ (p : x = y); induction p; 31 | intro (q : u = v); induction q; apply idp 32 | end 33 | 34 | hott theorem mapSndOverProd : Π {u v : Sigma B} (p : u.1 = v.1) (q : transport B p u.2 = v.2), 35 | apd pr₂ (prod p q) = pathOverAp Sigma.fst (prod p q) (transport (λ s, u.2 =[s] v.2) (mapFstOverProd p q)⁻¹ q) := 36 | begin 37 | intro ⟨x, u⟩ ⟨y, v⟩ (p : x = y); induction p; 38 | intro (q : u = v); induction q; reflexivity 39 | end 40 | 41 | hott lemma apOverSigma (f : Π x, B x) {a b : A} (p : a = b) : 42 | @ap A (Σ x, B x) a b (λ x, ⟨x, f x⟩) p = Sigma.prod p (apd f p) := 43 | begin induction p; reflexivity end 44 | 45 | hott lemma prodRefl (u : Sigma B) : prod (idp u.1) (idp u.2) = idp u := 46 | idp (idp u) 47 | 48 | hott lemma prodComp : Π {x y z : Sigma B} (p : x.1 = y.1) (q : y.1 = z.1) 49 | (r : x.2 =[p] y.2) (s : y.2 =[q] z.2), prod (p ⬝ q) (r ⬝′ s) = prod p r ⬝ prod q s := 50 | begin 51 | intro ⟨x, X⟩ ⟨y, Y⟩ ⟨z, Z⟩ (p : x = y) (q : y = z); 52 | induction p; induction q; intro (r : X = Y) (s : Y = Z); 53 | induction r; induction s; apply idp 54 | end 55 | 56 | hott lemma prodEq : Π {u v : Sigma B} (p p' : u.1 = v.1) 57 | (q : transport B p u.2 = v.2) (q' : transport B p' u.2 = v.2) 58 | (r : p = p') (s : q =[λ ρ, transport B ρ u.2 = v.2, r] q'), 59 | Sigma.prod p q = Sigma.prod p' q' := 60 | begin 61 | intro ⟨x, u⟩ ⟨y, v⟩ (p : x = y) (p' : x = y) q q' r; 62 | induction r; induction p; intro (s : q = q'); induction s; apply idp 63 | end 64 | 65 | hott definition spec {A : Type u} {B : Type v} (w : Σ (a : A), B) : A × B := (w.1, w.2) 66 | hott definition gen {A : Type u} {B : Type v} (w : A × B) : Σ (a : A), B := ⟨w.1, w.2⟩ 67 | 68 | hott lemma const (A : Type u) (B : Type v) : (Σ (a : A), B) ≃ A × B := 69 | Equiv.intro spec gen idp idp 70 | 71 | hott definition hmtpyInv {A : Type v} {B : Type u} (f g : A → B) 72 | (w : Σ x, f x = g x) : (Σ x, g x = f x) := 73 | ⟨w.1, w.2⁻¹⟩ 74 | 75 | hott definition map {A : Type v} {η : A → Type u} {ε : A → Type w} 76 | (f : Π x, η x → ε x) (w : Σ x, η x) : (Σ x, ε x) := 77 | ⟨w.1, f w.1 w.2⟩ 78 | 79 | hott theorem respectsEquiv {A : Type u} {η : A → Type v} {ε : A → Type w} 80 | (e : Π x, η x ≃ ε x) : (Σ x, η x) ≃ (Σ x, ε x) := 81 | begin 82 | existsi (map (λ x, (e x).forward)); apply Prod.mk; 83 | { existsi (map (λ x, (e x).left)); intro w; 84 | apply ap (Sigma.mk w.1); apply (e w.1).leftForward }; 85 | { existsi (map (λ x, (e x).right)); intro w; 86 | apply ap (Sigma.mk w.1); apply (e w.1).forwardRight } 87 | end 88 | 89 | hott lemma replaceIshae {A : Type u} {B : Type v} {C : A → Type w} 90 | (g : B → A) (ρ : ishae g) : (Σ x, C x) ≃ (Σ x, C (g x)) := 91 | begin 92 | existsi (λ w, ⟨ρ.1 w.1, Equiv.transport C (ρ.2.2.1 w.1)⁻¹ w.2⟩); 93 | apply Qinv.toBiinv; existsi (λ w, ⟨g w.1, w.2⟩); apply Prod.mk <;> intro w; 94 | { apply @prod B (C ∘ g) ⟨ρ.1 (g w.1), _⟩ w (ρ.2.1 w.1); 95 | transitivity; apply Equiv.transportComp; 96 | transitivity; symmetry; apply Equiv.transportcom; 97 | transitivity; apply ap (λ p, transport C p w.2); 98 | apply Id.compReflIfEq; symmetry; apply ρ.2.2.2; reflexivity }; 99 | { apply prod; apply Equiv.transportBackAndForward } 100 | end 101 | 102 | hott corollary hmtpyInvEqv {A : Type v} {B : Type u} (f g : A → B) : (Σ x, f x = g x) ≃ (Σ x, g x = f x) := 103 | respectsEquiv (λ _, Equiv.inveqv) 104 | 105 | hott definition sigmaEqOfEq {a b : Σ x, B x} (p : a = b) : (Σ (p : a.1 = b.1), transport B p a.2 = b.2) := 106 | begin induction p; existsi idp a.1; reflexivity end 107 | 108 | hott definition eqOfSigmaEq {a b : Σ x, B x} (p : Σ (p : a.1 = b.1), transport B p a.2 = b.2) : (a = b) := 109 | Sigma.prod p.1 p.2 110 | 111 | hott lemma prodRepr {a b : Σ x, B x} : @eqOfSigmaEq A B a b ∘ @sigmaEqOfEq A B a b ~ id := 112 | begin intro p; induction p; reflexivity end 113 | 114 | hott lemma reprProd : Π {a b : Σ x, B x}, @sigmaEqOfEq A B a b ∘ @eqOfSigmaEq A B a b ~ id := 115 | begin intro ⟨a, u⟩ ⟨b, v⟩ ⟨(p : a = b), q⟩; induction p; dsimp at q; induction q; apply idp end 116 | 117 | hott theorem sigmaPath {a b : Σ x, B x} : (a = b) ≃ (Σ (p : a.1 = b.1), transport B p a.2 = b.2) := 118 | begin 119 | existsi sigmaEqOfEq; apply Qinv.toBiinv; 120 | existsi eqOfSigmaEq; apply Prod.mk; apply reprProd; apply prodRepr 121 | end 122 | 123 | hott theorem assoc (C : (Σ x, B x) → Type w) : (Σ x, Σ y, C ⟨x, y⟩) ≃ (Σ p, C p) := 124 | begin 125 | fapply Equiv.intro; 126 | { intro w; existsi ⟨w.1, w.2.1⟩; exact w.2.2 }; 127 | { intro w; existsi w.1.1; existsi w.1.2; exact w.2 }; 128 | { intro; reflexivity }; 129 | { intro; reflexivity } 130 | end 131 | end Sigma 132 | 133 | end GroundZero.Types 134 | -------------------------------------------------------------------------------- /GroundZero/Types/Unit.lean: -------------------------------------------------------------------------------- 1 | import GroundZero.Types.Equiv 2 | 3 | namespace GroundZero.Types 4 | universe u 5 | 6 | inductive Unit : Type u 7 | | star : Unit 8 | 9 | attribute [induction_eliminator] Unit.casesOn 10 | 11 | notation "𝟏" => Unit 12 | notation "★" => Unit.star 13 | 14 | namespace Unit 15 | hott definition elim {A : Type u} (a : A) : 𝟏 → A := λ ★, a 16 | 17 | hott definition ind {B : 𝟏 → Type u} (g : B ★) : Π x, B x := λ ★, g 18 | 19 | hott definition uniq : Π x, x = ★ := λ ★, idp ★ 20 | end Unit 21 | 22 | end GroundZero.Types 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | library: index 2 | lake build 3 | 4 | index: 5 | lake script run updateIndex 6 | 7 | clean: 8 | lake clean 9 | 10 | all: index library 11 | lake script run updateDependencyMap pictures/dependency-map.svg 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ground Zero 2 | 3 | This is an attempt to develop Homotopy Type Theory in [Lean 4](https://github.com/leanprover/lean4/). 4 | 5 | As in [gebner/hott3](https://github.com/gebner/hott3), no modifications to the Lean kernel are made, because library uses [large eliminator checker](https://github.com/rzrn/ground_zero/blob/master/GroundZero/Meta/HottTheory.lean) ported [from Lean 3](https://github.com/gebner/hott3/blob/master/src/hott/init/meta/support.lean). So stuff like this will print an error: 6 | 7 | ```lean 8 | hott example {α : Type u} {a b : α} (p q : a = b) : p = q := 9 | begin cases p; cases q; apply Id.refl end 10 | ``` 11 | 12 | ## HITs 13 | 14 | [Most HITs in the library](https://github.com/rzrn/lean/tree/master/ground_zero/HITs) constructed using [quotients](https://leanprover.github.io/theorem_proving_in_lean/axioms_and_computation.html#quotients). Quotients in Lean have good computational properties (`Quot.ind` computes), so we can define HITs with them without any other changes in Lean’s kernel. 15 | 16 | There are: 17 | 18 | * [Interval](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Interval.lean) $I$. 19 | * [Pushout](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Pushout.lean) $\alpha \sqcup^\sigma \beta $. 20 | * [Homotopical reals](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Reals.lean) $R$. 21 | * (Sequential) [colimit](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Colimit.lean). 22 | * [Generalized circle](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Generalized.lean) $\{\alpha\}$. 23 | * [Propositional truncation](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Merely.lean) as a colimit of a following sequence: 24 | $` \alpha \rightarrow \{\alpha\} \rightarrow \{\{\alpha\}\} \rightarrow \ldots `$ 25 | * [Suspension](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Suspension.lean) $\Sigma \alpha$ is defined as the pushout of the span $\mathbf{1} \leftarrow \alpha \rightarrow \mathbf{1}$. 26 | * [Circle](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Circle.lean) $S^1$ is the suspension of the bool $\mathbf{2}$. 27 | * Sphere $S^2$ is the suspension of the circle $S^1$. 28 | * [Join](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Join.lean) $\alpha \ast \beta$. 29 | 30 | There are also HITs that cannot be constructed this way. These HITs are defined using standard trick with [private structures](https://github.com/rzrn/ground_zero/blob/master/GroundZero/HITs/Trunc.lean). 31 | 32 | ## Dependency map 33 | 34 | ![dependency map](pictures/dependency-map.svg "dependency map") 35 | 36 | 37 | ## License 38 | 39 | Copyright © 2018–2025 rzrn <rzrngh@outlook.com> 40 | 41 | Licensed under the Apache License, Version 2.0 (the “License”); 42 | you may not use this project except in compliance with the License. 43 | You may obtain a copy of the License at 44 | 45 | http://www.apache.org/licenses/LICENSE-2.0 46 | 47 | Unless required by applicable law or agreed to in writing, software 48 | distributed under the License is distributed on an “AS IS” BASIS, 49 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 50 | See the License for the specific language governing permissions and 51 | limitations under the License. 52 | -------------------------------------------------------------------------------- /lake-manifest.json: -------------------------------------------------------------------------------- 1 | {"version": 6, 2 | "packagesDir": "lake-packages", 3 | "packages": [], 4 | "name": "GroundZero"} 5 | -------------------------------------------------------------------------------- /lakefile.lean: -------------------------------------------------------------------------------- 1 | import Lake 2 | open Lake DSL 3 | 4 | package GroundZero { 5 | leanOptions := #[ 6 | ⟨`linter.deprecated, false⟩, 7 | ⟨`linter.unusedVariables, false⟩, 8 | ⟨`relaxedAutoImplicit, false⟩, 9 | ⟨`autoImplicit, false⟩ 10 | ] 11 | } 12 | 13 | @[default_target] 14 | lean_lib GroundZero 15 | 16 | set_option linter.unusedVariables false 17 | set_option autoImplicit false 18 | 19 | section 20 | open System (FilePath) 21 | 22 | def hasExtension (e : String) : FilePath → Bool := 23 | λ fp => fp.extension = some e 24 | 25 | def isTracked (fp : FilePath) : IO Bool := 26 | do { 27 | let retval ← IO.Process.run { cmd := "git", args := #["ls-files", fp.toString] }; 28 | return retval.length > 0 29 | } 30 | 31 | def modOfPath (fp : FilePath) := 32 | ".".intercalate (fp.withExtension "").components 33 | 34 | def modsOfDir (fp : FilePath) := 35 | do { 36 | let fs := (← fp.walkDir).qsort (·.toString < ·.toString) 37 | |>.filter (hasExtension "lean"); 38 | return (← fs.filterM isTracked).map modOfPath 39 | } 40 | end 41 | 42 | def scriptNotice := "Automatically generated by `lake script run updateIndex`, do not edit it manually." 43 | 44 | script updateIndex (argv) do { 45 | let mods ← modsOfDir "GroundZero"; 46 | 47 | IO.FS.withFile "GroundZero.lean" IO.FS.Mode.write fun fd => 48 | do { fd.putStrLn s!"-- {scriptNotice}"; for mod in mods do fd.putStrLn s!"import {mod}" }; 49 | 50 | return 0 51 | } 52 | 53 | section 54 | universe u v 55 | 56 | open Lean IO 57 | 58 | -- Taken from https://github.com/leanprover-community/mathlib4/blob/master/Mathlib/Util/Imports.lean. 59 | def importsOf (env : Environment) (n : Name) : Array Name := 60 | if n = env.header.mainModule then 61 | env.header.imports.map Import.module 62 | else match env.getModuleIdx? n with 63 | | some idx => env.header.moduleData[idx.toNat]!.imports.map Import.module |>.erase `Init 64 | | none => #[] 65 | 66 | def removePrefix (n : Name) := 67 | n.replacePrefix `GroundZero Name.anonymous 68 | 69 | def ppName (n : Name) := "/".intercalate (removePrefix n |>.components.map toString) 70 | 71 | def importGraph (E : Environment) : IO (Array (String × String)) := do { 72 | let mut edges := @Array.empty (String × String); 73 | 74 | for mod₁ in importsOf E `GroundZero do { 75 | for mod₂ in importsOf E mod₁ do 76 | if mod₂.getRoot = `GroundZero then 77 | edges := edges.push (ppName mod₂, ppName mod₁); 78 | } 79 | 80 | return edges.qsort (λ w₁ w₂ => if w₁.1 = w₂.1 then w₁.2 < w₂.2 else w₁.1 < w₂.1); 81 | } 82 | 83 | def writeGraph (E : Environment) (outname : String) : IO Unit := do { 84 | let edges ← importGraph E; 85 | 86 | let child ← Process.spawn { 87 | cmd := "dot", args := #["-Tsvg", "-o", outname], 88 | stdout := .inherit, stderr := .inherit, stdin := .piped 89 | }; 90 | 91 | let fd := child.stdin; 92 | 93 | fd.putStrLn "digraph dependencyMap {"; 94 | fd.putStrLn " splines=polyline"; 95 | for (A, B) in edges do 96 | fd.putStrLn s!" \"{A}\" -> \"{B}\"" 97 | fd.putStrLn "}"; 98 | 99 | let (_, child) ← child.takeStdin; 100 | discard child.wait 101 | } 102 | end 103 | 104 | script updateDependencyMap (argv) do { 105 | Lean.searchPathRef.set (← getWorkspace).augmentedLeanPath; 106 | let E ← Lean.importModules #[`GroundZero] {} (trustLevel := 1024); 107 | writeGraph E (argv.getD 0 "/dev/stdout"); return 0 108 | } 109 | -------------------------------------------------------------------------------- /lean-toolchain: -------------------------------------------------------------------------------- 1 | leanprover/lean4:4.20.1 2 | --------------------------------------------------------------------------------