michael/lean2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(hott): small changes, simplify van Kampen

Browse source
This commit is contained in:
Floris van Doorn 2016-05-19 11:27:52 -04:00 committed by Leonardo de Moura
parent e96e4a677d
commit 735230ad07
8 changed files with 452 additions and 473 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
hott/algebra/algebra.md
View file

@ -23,6 +23,7 @@ Files which are not ported from the standard library:
* [trunc_group](trunc_group.hlean) : truncate an infinity-group to a group
* [homotopy_group](homotopy_group.hlean) : homotopy groups of a pointed type
* [e_closure](e_closure.hlean) : the type of words formed by a relation
* [graph](graph.hlean) : definition and operations on paths in a graph.
Subfolders (not ported):

3
hott/algebra/category/constructions/constructions.md
View file

@ -10,7 +10,8 @@ Common categories and constructions on categories. The following files are in th
* [product](product.hlean) : Product category
* [comma](comma.hlean) : Comma category
* [cone](cone.hlean) : Cone category
* [pushout](pushout.hlean) : Pushout of categories, pushout of groupoids. Also more generally the category formed by a (quotient of) paths in a graph
* [pushout](pushout.hlean) : Categorical structure of paths in a graph and quotients of them.
Pushout of categories, pushout of groupoids.
* [fundamental_groupoid](fundamental_groupoid.hlean) : The fundamental groupoid of a type
Discrete, indiscrete or finite categories:

526
hott/algebra/category/constructions/pushout.hlean
View file

@ -7,342 +7,44 @@ Authors: Floris van Doorn
The pushout of categories
The morphisms in the pushout of two categories is defined as a quotient on lists of composable
morphisms. We first define a general notion of indexed lists, such that each element in the list has two endpoints, and the endpoints between adjacent members of the list have to be the same.
morphisms. For this we use the notion of paths in a graph.
-/
import ..category ..nat_trans hit.set_quotient algebra.relation ..groupoid
import ..category ..nat_trans hit.set_quotient algebra.relation ..groupoid algebra.graph
open eq is_trunc functor trunc sum set_quotient relation iso category sigma nat
inductive indexed_list {A : Type} (R : A → A → Type) : A → A → Type :=
| nil {} : Π{a : A}, indexed_list R a a
| cons : Π{a₁ a₂ a₃ : A} (r : R a₂ a₃), indexed_list R a₁ a₂ → indexed_list R a₁ a₃
namespace indexed_list
notation h :: t := cons h t
notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l
variables {A : Type} {R : A → A → Type} {a a' a₁ a₂ a₃ a₄ : A}
definition concat (r : R a₁ a₂) (l : indexed_list R a₂ a₃) : indexed_list R a₁ a₃ :=
begin
induction l with a a₂ a₃ a₄ r' l IH,
{ exact [r]},
{ exact r' :: IH r}
end
theorem concat_nil (r : R a₁ a₂) : concat r (@nil A R a₂) = [r] := idp
theorem concat_cons (r : R a₁ a₂) (r' : R a₃ a₄) (l : indexed_list R a₂ a₃)
: concat r (r'::l) = r'::(concat r l) := idp
definition append (l₂ : indexed_list R a₂ a₃) (l₁ : indexed_list R a₁ a₂) :
indexed_list R a₁ a₃ :=
begin
induction l₂,
{ exact l₁},
{ exact cons r (v_0 l₁)}
end
infix ` ++ ` := append
definition nil_append (l : indexed_list R a₁ a₂) : nil ++ l = l := idp
definition cons_append (r : R a₃ a₄) (l₂ : indexed_list R a₂ a₃) (l₁ : indexed_list R a₁ a₂) :
(r :: l₂) ++ l₁ = r :: (l₂ ++ l₁) := idp
definition singleton_append (r : R a₂ a₃) (l : indexed_list R a₁ a₂) : [r] ++ l = r :: l := idp
definition append_singleton (l : indexed_list R a₂ a₃) (r : R a₁ a₂) : l ++ [r] = concat r l :=
begin
induction l,
{ reflexivity},
{ exact ap (cons r) !v_0}
end
definition append_nil (l : indexed_list R a₁ a₂) : l ++ nil = l :=
begin
induction l,
{ reflexivity},
{ exact ap (cons r) v_0}
end
definition append_assoc (l₃ : indexed_list R a₃ a₄) (l₂ : indexed_list R a₂ a₃)
(l₁ : indexed_list R a₁ a₂) : (l₃ ++ l₂) ++ l₁ = l₃ ++ (l₂ ++ l₁) :=
begin
induction l₃,
{ reflexivity},
{ refine ap (cons r) !v_0}
end
theorem append_concat (l₂ : indexed_list R a₃ a₄) (l₁ : indexed_list R a₂ a₃) (r : R a₁ a₂) :
l₂ ++ concat r l₁ = concat r (l₂ ++ l₁) :=
begin
induction l₂,
{ reflexivity},
{ exact ap (cons r_1) !v_0}
end
theorem concat_append (l₂ : indexed_list R a₃ a₄) (r : R a₂ a₃) (l₁ : indexed_list R a₁ a₂) :
concat r l₂ ++ l₁ = l₂ ++ r :: l₁ :=
begin
induction l₂,
{ reflexivity},
{ exact ap (cons r) !v_0}
end
definition indexed_list.rec_tail {C : Π⦃a a' : A⦄, indexed_list R a a' → Type}
(H0 : Π {a : A}, @C a a nil)
(H1 : Π {a₁ a₂ a₃ : A} (r : R a₁ a₂) (l : indexed_list R a₂ a₃), C l → C (concat r l)) :
Π{a a' : A} (l : indexed_list R a a'), C l :=
begin
have Π{a₁ a₂ a₃ : A} (l₂ : indexed_list R a₂ a₃) (l₁ : indexed_list R a₁ a₂) (c : C l₂),
C (l₂ ++ l₁),
begin
intros, revert a₃ l₂ c, induction l₁: intros a₃ l₂ c,
{ rewrite append_nil, exact c},
{ rewrite [-concat_append], apply v_0, apply H1, exact c}
end,
intros, rewrite [-nil_append], apply this, apply H0
end
definition cons_eq_concat (r : R a₂ a₃) (l : indexed_list R a₁ a₂) :
Σa (r' : R a₁ a) (l' : indexed_list R a a₃), r :: l = concat r' l' :=
begin
revert a₃ r, induction l: intros a₃' r',
{ exact ⟨a₃', r', nil, idp⟩},
{ cases (v_0 a₃ r) with a₄ w, cases w with r₂ w, cases w with l p, clear v_0,
exact ⟨a₄, r₂, r' :: l, ap (cons r') p⟩}
end
definition length (l : indexed_list R a₁ a₂) : ℕ :=
begin
induction l,
{ exact 0},
{ exact succ v_0}
end
definition reverse (rev : Π⦃a a'⦄, R a a' → R a' a) (l : indexed_list R a₁ a₂) :
indexed_list R a₂ a₁ :=
begin
induction l,
{ exact nil},
{ exact concat (rev r) v_0}
end
theorem reverse_nil (rev : Π⦃a a'⦄, R a a' → R a' a) : reverse rev (@nil A R a₁) = [] := idp
theorem reverse_cons (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₂ a₃) (l : indexed_list R a₁ a₂) :
reverse rev (r::l) = concat (rev r) (reverse rev l) := idp
theorem reverse_singleton (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) :
reverse rev [r] = [rev r] := idp
theorem reverse_pair (rev : Π⦃a a'⦄, R a a' → R a' a) (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
reverse rev [r₂, r₁] = [rev r₁, rev r₂] := idp
theorem reverse_concat (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) (l : indexed_list R a₂ a₃) :
reverse rev (concat r l) = rev r :: (reverse rev l) :=
begin
induction l,
{ reflexivity},
{ rewrite [concat_cons, reverse_cons, v_0]}
end
theorem reverse_append (rev : Π⦃a a'⦄, R a a' → R a' a) (l₂ : indexed_list R a₂ a₃)
(l₁ : indexed_list R a₁ a₂) : reverse rev (l₂ ++ l₁) = reverse rev l₁ ++ reverse rev l₂ :=
begin
induction l₂,
{ exact !append_nil⁻¹},
{ rewrite [cons_append, +reverse_cons, append_concat, v_0]}
end
definition realize (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
⦃a a' : A⦄ (l : indexed_list R a a') : P a a' :=
begin
induction l,
{ exact ρ a},
{ exact c v_0 (f r)}
end
definition realize_nil (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃) (a : A) :
realize P f ρ c nil = ρ a :=
idp
definition realize_cons (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
⦃a₁ a₂ a₃ : A⦄ (r : R a₂ a₃) (l : indexed_list R a₁ a₂) :
realize P f ρ c (r :: l) = c (realize P f ρ c l) (f r) :=
idp
theorem realize_singleton {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
⦃a₁ a₂ : A⦄ (r : R a₁ a₂) :
realize P f ρ c [r] = f r :=
id_left (f r)
theorem realize_pair {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
⦃a₁ a₂ a₃ : A⦄ (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
realize P f ρ c [r₂, r₁] = c (f r₁) (f r₂) :=
ap (λx, c x (f r₂)) (realize_singleton id_left r₁)
theorem realize_append {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
(id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
⦃a₁ a₂ a₃ : A⦄ (l₂ : indexed_list R a₂ a₃) (l₁ : indexed_list R a₁ a₂) :
realize P f ρ c (l₂ ++ l₁) = c (realize P f ρ c l₁) (realize P f ρ c l₂) :=
begin
induction l₂,
{ exact !id_right⁻¹},
{ rewrite [cons_append, +realize_cons, v_0, assoc]}
end
inductive indexed_list_rel {A : Type} {R : A → A → Type}
(Q : Π⦃a a' : A⦄, indexed_list R a a' → indexed_list R a a' → Type)
: Π⦃a a' : A⦄, indexed_list R a a' → indexed_list R a a' → Type :=
| rrefl : Π{a a' : A} (l : indexed_list R a a'), indexed_list_rel Q l l
| rel : Π{a₁ a₂ a₃ : A} {l₂ l₃ : indexed_list R a₂ a₃} (l : indexed_list R a₁ a₂) (q : Q l₂ l₃),
indexed_list_rel Q (l₂ ++ l) (l₃ ++ l)
| rcons : Π{a₁ a₂ a₃ : A} {l₁ l₂ : indexed_list R a₁ a₂} (r : R a₂ a₃),
indexed_list_rel Q l₁ l₂ → indexed_list_rel Q (cons r l₁) (cons r l₂)
| rtrans : Π{a₁ a₂ : A} {l₁ l₂ l₃ : indexed_list R a₁ a₂},
indexed_list_rel Q l₁ l₂ → indexed_list_rel Q l₂ l₃ → indexed_list_rel Q l₁ l₃
open indexed_list_rel
attribute rrefl [refl]
attribute rtrans [trans]
variables {Q : Π⦃a a' : A⦄, indexed_list R a a' → indexed_list R a a' → Type}
definition indexed_list_rel_of_Q {l₁ l₂ : indexed_list R a₁ a₂} (q : Q l₁ l₂) :
indexed_list_rel Q l₁ l₂ :=
begin
rewrite [-append_nil l₁, -append_nil l₂], exact rel nil q,
end
theorem rel_respect_append_left (l : indexed_list R a₂ a₃) {l₃ l₄ : indexed_list R a₁ a₂}
(H : indexed_list_rel Q l₃ l₄) : indexed_list_rel Q (l ++ l₃) (l ++ l₄) :=
begin
induction l,
{ exact H},
{ exact rcons r (v_0 _ _ H)}
end
theorem rel_respect_append_right {l₁ l₂ : indexed_list R a₂ a₃} (l : indexed_list R a₁ a₂)
(H₁ : indexed_list_rel Q l₁ l₂) : indexed_list_rel Q (l₁ ++ l) (l₂ ++ l) :=
begin
induction H₁ with a₁ a₂ l₁
a₂ a₃ a₄ l₂ l₂' l₁ q
a₂ a₃ a₄ l₁ l₂ r H₁ IH
a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
{ reflexivity},
{ rewrite [+ append_assoc], exact rel _ q},
{ exact rcons r (IH l) },
{ exact rtrans (IH l) (IH' l)}
end
theorem rel_respect_append {l₁ l₂ : indexed_list R a₂ a₃} {l₃ l₄ : indexed_list R a₁ a₂}
(H₁ : indexed_list_rel Q l₁ l₂) (H₂ : indexed_list_rel Q l₃ l₄) :
indexed_list_rel Q (l₁ ++ l₃) (l₂ ++ l₄) :=
begin
induction H₁ with a₁ a₂ l
a₂ a₃ a₄ l₂ l₂' l q
a₂ a₃ a₄ l₁ l₂ r H₁ IH
a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
{ exact rel_respect_append_left _ H₂},
{ rewrite [+ append_assoc], transitivity _, exact rel _ q,
apply rel_respect_append_left, apply rel_respect_append_left, exact H₂},
{ exact rcons r (IH _ _ H₂) },
{ refine rtrans (IH _ _ H₂) _, apply rel_respect_append_right, exact H₁'}
end
theorem rel_respect_reverse (rev : Π⦃a a'⦄, R a a' → R a' a) {l₁ l₂ : indexed_list R a₁ a₂}
(H : indexed_list_rel Q l₁ l₂)
(rev_rel : Π⦃a a' : A⦄ {l l' : indexed_list R a a'},
Q l l' → indexed_list_rel Q (reverse rev l) (reverse rev l')) :
indexed_list_rel Q (reverse rev l₁) (reverse rev l₂) :=
begin
induction H,
{ reflexivity},
{ rewrite [+ reverse_append], apply rel_respect_append_left, apply rev_rel q},
{ rewrite [+reverse_cons,-+append_singleton], apply rel_respect_append_right, exact v_0},
{ exact rtrans v_0 v_1}
end
theorem rel_left_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : indexed_list R a₁ a₂)
(li : Π⦃a a' : A⦄ (r : R a a'), indexed_list_rel Q [rev r, r] nil) :
indexed_list_rel Q (reverse rev l ++ l) nil :=
begin
induction l,
{ reflexivity},
{ rewrite [reverse_cons, concat_append],
refine rtrans _ v_0, apply rel_respect_append_left,
exact rel_respect_append_right _ (li r)}
end
theorem rel_right_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : indexed_list R a₁ a₂)
(ri : Π⦃a a' : A⦄ (r : R a a'), indexed_list_rel Q [r, rev r] nil) :
indexed_list_rel Q (l ++ reverse rev l) nil :=
begin
induction l using indexed_list.rec_tail,
{ reflexivity},
{ rewrite [reverse_concat, concat_append],
refine rtrans _ a, apply rel_respect_append_left,
exact rel_respect_append_right _ (ri r)}
end
definition realize_eq {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
(id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
(resp_rel : Π⦃a₁ a₂⦄ {l₁ l₂ : indexed_list R a₁ a₂}, Q l₁ l₂ →
realize P f ρ c l₁ = realize P f ρ c l₂)
⦃a a' : A⦄ {l l' : indexed_list R a a'} (H : indexed_list_rel Q l l') :
realize P f ρ c l = realize P f ρ c l' :=
begin
induction H,
{ reflexivity},
{ rewrite [+realize_append assoc id_right], apply ap (c _), exact resp_rel q},
{ exact ap (λx, c x (f r)) v_0},
{ exact v_0 ⬝ v_1}
end
end indexed_list
namespace indexed_list
/- we first define the categorical structure on paths in a graph -/
namespace paths
section
parameters {A : Type} {R : A → A → Type}
(Q : Π⦃a a' : A⦄, indexed_list R a a' → indexed_list R a a' → Type)
(Q : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type)
variables ⦃a a' a₁ a₂ a₃ a₄ : A⦄
definition indexed_list_trel [constructor] (l l' : indexed_list R a a') : Prop :=
∥indexed_list_rel Q l l'∥
definition paths_trel [constructor] (l l' : paths R a a') : Prop :=
∥paths_rel Q l l'∥
local notation `S` := @indexed_list_trel
definition indexed_list_quotient (a a' : A) : Type := set_quotient (@S a a')
local notation `mor` := indexed_list_quotient
local attribute indexed_list_quotient [reducible]
local notation `S` := @paths_trel
definition paths_quotient (a a' : A) : Type := set_quotient (@S a a')
local notation `mor` := paths_quotient
local attribute paths_quotient [reducible]
definition is_reflexive_R : is_reflexive (@S a a') :=
begin constructor, intro s, apply tr, constructor end
local attribute is_reflexive_R [instance]
definition indexed_list_compose [unfold 7 8] (g : mor a₂ a₃) (f : mor a₁ a₂) : mor a₁ a₃ :=
definition paths_compose [unfold 7 8] (g : mor a₂ a₃) (f : mor a₁ a₂) : mor a₁ a₃ :=
begin
refine quotient_binary_map _ _ g f, exact append,
intros, refine trunc_functor2 _ r s, exact rel_respect_append
end
definition indexed_list_id [constructor] (a : A) : mor a a :=
definition paths_id [constructor] (a : A) : mor a a :=
class_of nil
local infix ` ∘∘ `:60 := indexed_list_compose
local notation `p1` := indexed_list_id _
local infix ` ∘∘ `:60 := paths_compose
local notation `p1` := paths_id _
theorem indexed_list_assoc (h : mor a₃ a₄) (g : mor a₂ a₃) (f : mor a₁ a₂) :
theorem paths_assoc (h : mor a₃ a₄) (g : mor a₂ a₃) (f : mor a₁ a₂) :
h ∘∘ (g ∘∘ f) = (h ∘∘ g) ∘∘ f :=
begin
induction h using set_quotient.rec_prop with h,
@ -351,163 +53,109 @@ namespace indexed_list
rewrite [▸*, append_assoc]
end
theorem indexed_list_id_left (f : mor a a') : p1 ∘∘ f = f :=
theorem paths_id_left (f : mor a a') : p1 ∘∘ f = f :=
begin
induction f using set_quotient.rec_prop with f,
reflexivity
end
theorem indexed_list_id_right (f : mor a a') : f ∘∘ p1 = f :=
theorem paths_id_right (f : mor a a') : f ∘∘ p1 = f :=
begin
induction f using set_quotient.rec_prop with f,
rewrite [▸*, append_nil]
end
definition Precategory_indexed_list [constructor] : Precategory :=
definition Precategory_paths [constructor] : Precategory :=
precategory.MK A
mor
_
indexed_list_compose
indexed_list_id
indexed_list_assoc
indexed_list_id_left
indexed_list_id_right
paths_compose
paths_id
paths_assoc
paths_id_left
paths_id_right
/- given a way to reverse edges and some additional properties we can extend this to a
groupoid structure -/
parameters (inv : Π⦃a a' : A⦄, R a a' → R a' a)
(rel_inv : Π⦃a a' : A⦄ {l l' : indexed_list R a a'},
Q l l' → indexed_list_rel Q (reverse inv l) (reverse inv l'))
(li : Π⦃a a' : A⦄ (r : R a a'), indexed_list_rel Q [inv r, r] nil)
(ri : Π⦃a a' : A⦄ (r : R a a'), indexed_list_rel Q [r, inv r] nil)
(rel_inv : Π⦃a a' : A⦄ {l l' : paths R a a'},
Q l l' → paths_rel Q (reverse inv l) (reverse inv l'))
(li : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [inv r, r] nil)
(ri : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [r, inv r] nil)
include rel_inv li ri
definition indexed_list_inv [unfold 8] (f : mor a a') : mor a' a :=
definition paths_inv [unfold 8] (f : mor a a') : mor a' a :=
begin
refine quotient_unary_map (reverse inv) _ f,
intros, refine trunc_functor _ _ r, esimp,
intro s, apply rel_respect_reverse inv s rel_inv
end
local postfix `^`:max := indexed_list_inv
local postfix `^`:max := paths_inv
theorem indexed_list_left_inv (f : mor a₁ a₂) : f^ ∘∘ f = p1 :=
theorem paths_left_inv (f : mor a₁ a₂) : f^ ∘∘ f = p1 :=
begin
induction f using set_quotient.rec_prop with f,
esimp, apply eq_of_rel, apply tr,
apply rel_left_inv, apply li
end
theorem indexed_list_right_inv (f : mor a₁ a₂) : f ∘∘ f^ = p1 :=
theorem paths_right_inv (f : mor a₁ a₂) : f ∘∘ f^ = p1 :=
begin
induction f using set_quotient.rec_prop with f,
esimp, apply eq_of_rel, apply tr,
apply rel_right_inv, apply ri
end
definition Groupoid_indexed_list [constructor] : Groupoid :=
groupoid.MK Precategory_indexed_list
(λa b f, is_iso.mk (indexed_list_inv f) (indexed_list_left_inv f) (indexed_list_right_inv f))
definition Groupoid_paths [constructor] : Groupoid :=
groupoid.MK Precategory_paths
(λa b f, is_iso.mk (paths_inv f) (paths_left_inv f) (paths_right_inv f))
end
end indexed_list
open indexed_list
end paths
open paths
namespace category
inductive pushout_prehom_index {C D E : Precategory} (F : C ⇒ D) (G : C ⇒ E) :
/- We use this for the pushout of categories -/
inductive pushout_prehom_index {C : Type} (D E : Precategory) (F : C → D) (G : C → E) :
D + E → D + E → Type :=
| iD : Π{d d' : D} (f : d ⟶ d'), pushout_prehom_index F G (inl d) (inl d')
| iE : Π{e e' : E} (g : e ⟶ e'), pushout_prehom_index F G (inr e) (inr e')
| DE : Π(c : C), pushout_prehom_index F G (inl (F c)) (inr (G c))
| ED : Π(c : C), pushout_prehom_index F G (inr (G c)) (inl (F c))
| iD : Π{d d' : D} (f : d ⟶ d'), pushout_prehom_index D E F G (inl d) (inl d')
| iE : Π{e e' : E} (g : e ⟶ e'), pushout_prehom_index D E F G (inr e) (inr e')
| DE : Π(c : C), pushout_prehom_index D E F G (inl (F c)) (inr (G c))
| ED : Π(c : C), pushout_prehom_index D E F G (inr (G c)) (inl (F c))
open pushout_prehom_index
definition pushout_prehom {C D E : Precategory} (F : C ⇒ D) (G : C ⇒ E) : D + E → D + E → Type :=
indexed_list (pushout_prehom_index F G)
definition pushout_prehom {C : Type} (D E : Precategory) (F : C → D) (G : C → E) :
D + E → D + E → Type :=
paths (pushout_prehom_index D E F G)
inductive pushout_hom_rel_index {C D E : Precategory} (F : C ⇒ D) (G : C ⇒ E) :
Π⦃x x' : D + E⦄, pushout_prehom F G x x' → pushout_prehom F G x x' → Type :=
inductive pushout_hom_rel_index {C : Type} (D E : Precategory) (F : C → D) (G : C → E) :
Π⦃x x' : D + E⦄, pushout_prehom D E F G x x' → pushout_prehom D E F G x x' → Type :=
| DD : Π{d₁ d₂ d₃ : D} (g : d₂ ⟶ d₃) (f : d₁ ⟶ d₂),
pushout_hom_rel_index F G [iD F G g, iD F G f] [iD F G (g ∘ f)]
pushout_hom_rel_index D E F G [iD F G g, iD F G f] [iD F G (g ∘ f)]
| EE : Π{e₁ e₂ e₃ : E} (g : e₂ ⟶ e₃) (f : e₁ ⟶ e₂),
pushout_hom_rel_index F G [iE F G g, iE F G f] [iE F G (g ∘ f)]
| DED : Π(c : C), pushout_hom_rel_index F G [ED F G c, DE F G c] nil
| EDE : Π(c : C), pushout_hom_rel_index F G [DE F G c, ED F G c] nil
| idD : Π(d : D), pushout_hom_rel_index F G [iD F G (ID d)] nil
| idE : Π(e : E), pushout_hom_rel_index F G [iE F G (ID e)] nil
pushout_hom_rel_index D E F G [iE F G g, iE F G f] [iE F G (g ∘ f)]
| DED : Π(c : C), pushout_hom_rel_index D E F G [ED F G c, DE F G c] nil
| EDE : Π(c : C), pushout_hom_rel_index D E F G [DE F G c, ED F G c] nil
| idD : Π(d : D), pushout_hom_rel_index D E F G [iD F G (ID d)] nil
| idE : Π(e : E), pushout_hom_rel_index D E F G [iE F G (ID e)] nil
open pushout_hom_rel_index
-- section
-- parameters {C D E : Precategory} (F : C ⇒ D) (G : C ⇒ E)
-- local notation `ob` := D + E
-- variables ⦃x x' x₁ x₂ x₃ x₄ : ob⦄
-- definition pushout_hom_rel [constructor] (l l' : pushout_prehom F G x x') : Prop :=
-- ∥indexed_list_rel (pushout_hom_rel_index F G) l l'∥
definition Precategory_pushout [constructor] {C : Type} (D E : Precategory)
(F : C → D) (G : C → E) : Precategory :=
Precategory_paths (pushout_hom_rel_index D E F G)
-- local notation `R` := @pushout_hom_rel
-- definition pushout_hom (x x' : ob) : Type := set_quotient (@R x x')
-- local notation `mor` := @pushout_hom
-- local attribute pushout_hom [reducible]
/- We can also take the pushout of groupoids -/
-- definition is_reflexive_R : is_reflexive (@R x x') :=
-- begin constructor, intro s, apply tr, constructor end
-- local attribute is_reflexive_R [instance]
variables {C : Type} (D E : Groupoid) (F : C → D) (G : C → E)
variables ⦃x x' x₁ x₂ x₃ x₄ : Precategory_pushout D E F G⦄
-- definition pushout_compose [unfold 9 10] (g : mor x₂ x₃) (f : mor x₁ x₂) : mor x₁ x₃ :=
-- begin
-- refine quotient_binary_map _ _ g f, exact append,
-- intros, refine trunc_functor2 _ r s, exact rel_respect_append
-- end
-- definition pushout_id [constructor] (x : ob) : mor x x :=
-- class_of nil
-- local infix ` ∘∘ `:60 := pushout_compose
-- local notation `p1` := pushout_id _
-- theorem pushout_assoc (h : mor x₃ x₄) (g : mor x₂ x₃) (f : mor x₁ x₂) :
-- h ∘∘ (g ∘∘ f) = (h ∘∘ g) ∘∘ f :=
-- begin
-- induction h using set_quotient.rec_prop with h,
-- induction g using set_quotient.rec_prop with g,
-- induction f using set_quotient.rec_prop with f,
-- rewrite [▸*, append_assoc]
-- end
-- theorem pushout_id_left (f : mor x x') : p1 ∘∘ f = f :=
-- begin
-- induction f using set_quotient.rec_prop with f,
-- reflexivity
-- end
-- theorem pushout_id_right (f : mor x x') : f ∘∘ p1 = f :=
-- begin
-- induction f using set_quotient.rec_prop with f,
-- rewrite [▸*, append_nil]
-- end
definition Precategory_pushout [constructor] {C D E : Precategory} (F : C ⇒ D) (G : C ⇒ E) :
Precategory :=
Precategory_indexed_list (pushout_hom_rel_index F G)
-- precategory.MK ob
-- mor
-- _
-- pushout_compose
-- pushout_id
-- pushout_assoc
-- pushout_id_left
-- pushout_id_right
-- end
variables {C D E : Groupoid} (F : C ⇒ D) (G : C ⇒ E)
variables ⦃x x' x₁ x₂ x₃ x₄ : Precategory_pushout F G⦄
definition pushout_index_inv [unfold 8] (i : pushout_prehom_index F G x x') :
pushout_prehom_index F G x' x :=
definition pushout_index_inv [unfold 8] (i : pushout_prehom_index D E F G x x') :
pushout_prehom_index D E F G x' x :=
begin
induction i,
{ exact iD F G f⁻¹},
@ -516,43 +164,43 @@ namespace category
{ exact DE F G c},
end
open indexed_list.indexed_list_rel
theorem pushout_index_reverse {l l' : pushout_prehom F G x x'}
(q : pushout_hom_rel_index F G l l') : indexed_list_rel (pushout_hom_rel_index F G)
(reverse (pushout_index_inv F G) l) (reverse (pushout_index_inv F G) l') :=
open paths.paths_rel
theorem pushout_index_reverse {l l' : pushout_prehom D E F G x x'}
(q : pushout_hom_rel_index D E F G l l') : paths_rel (pushout_hom_rel_index D E F G)
(reverse (pushout_index_inv D E F G) l) (reverse (pushout_index_inv D E F G) l') :=
begin
induction q: apply indexed_list_rel_of_Q;
induction q: apply paths_rel_of_Q;
try rewrite reverse_singleton; try rewrite reverse_pair; try rewrite reverse_nil; esimp;
try rewrite [comp_inverse]; try rewrite [id_inverse]; constructor,
end
theorem pushout_index_li (i : pushout_prehom_index F G x x') :
indexed_list_rel (pushout_hom_rel_index F G) [pushout_index_inv F G i, i] nil :=
theorem pushout_index_li (i : pushout_prehom_index D E F G x x') :
paths_rel (pushout_hom_rel_index D E F G) [pushout_index_inv D E F G i, i] nil :=
begin
induction i: esimp,
{ refine rtrans (indexed_list_rel_of_Q !DD) _,
rewrite [comp.left_inverse], exact indexed_list_rel_of_Q !idD},
{ refine rtrans (indexed_list_rel_of_Q !EE) _,
rewrite [comp.left_inverse], exact indexed_list_rel_of_Q !idE},
{ exact indexed_list_rel_of_Q !DED},
{ exact indexed_list_rel_of_Q !EDE}
{ refine rtrans (paths_rel_of_Q !DD) _,
rewrite [comp.left_inverse], exact paths_rel_of_Q !idD},
{ refine rtrans (paths_rel_of_Q !EE) _,
rewrite [comp.left_inverse], exact paths_rel_of_Q !idE},
{ exact paths_rel_of_Q !DED},
{ exact paths_rel_of_Q !EDE}
end
theorem pushout_index_ri (i : pushout_prehom_index F G x x') :
indexed_list_rel (pushout_hom_rel_index F G) [i, pushout_index_inv F G i] nil :=
theorem pushout_index_ri (i : pushout_prehom_index D E F G x x') :
paths_rel (pushout_hom_rel_index D E F G) [i, pushout_index_inv D E F G i] nil :=
begin
induction i: esimp,
{ refine rtrans (indexed_list_rel_of_Q !DD) _,
rewrite [comp.right_inverse], exact indexed_list_rel_of_Q !idD},
{ refine rtrans (indexed_list_rel_of_Q !EE) _,
rewrite [comp.right_inverse], exact indexed_list_rel_of_Q !idE},
{ exact indexed_list_rel_of_Q !EDE},
{ exact indexed_list_rel_of_Q !DED}
{ refine rtrans (paths_rel_of_Q !DD) _,
rewrite [comp.right_inverse], exact paths_rel_of_Q !idD},
{ refine rtrans (paths_rel_of_Q !EE) _,
rewrite [comp.right_inverse], exact paths_rel_of_Q !idE},
{ exact paths_rel_of_Q !EDE},
{ exact paths_rel_of_Q !DED}
end
definition Groupoid_pushout [constructor] : Groupoid :=
Groupoid_indexed_list (pushout_hom_rel_index F G) (pushout_index_inv F G)
(pushout_index_reverse F G) (pushout_index_li F G) (pushout_index_ri F G)
Groupoid_paths (pushout_hom_rel_index D E F G) (pushout_index_inv D E F G)
(pushout_index_reverse D E F G) (pushout_index_li D E F G) (pushout_index_ri D E F G)
end category

7
hott/algebra/default.hlean Normal file
View file

@ -0,0 +1,7 @@
/-
Copyright (c) 2016 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import .homotopy_group .ordered_field

330
hott/algebra/graph.hlean Normal file
View file

@ -0,0 +1,330 @@
/-
Copyright (c) 2016 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
Graphs and operations on graphs
Currently we only define the notion of a path in a graph, and prove properties and operations on
paths.
-/
open eq sigma nat
/-
A path is a list of vertexes which are adjacent. We maybe use a weird ordering of cons, because
the major example where we use this is a category where this ordering makes more sense.
For the operations on paths we use the names from the corresponding operations on lists. Opening
both the list and the paths namespace will lead to many name clashes, so that is not advised.
-/
inductive paths {A : Type} (R : A → A → Type) : A → A → Type :=
| nil {} : Π{a : A}, paths R a a
| cons : Π{a₁ a₂ a₃ : A} (r : R a₂ a₃), paths R a₁ a₂ → paths R a₁ a₃
namespace paths
notation h :: t := cons h t
notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l
variables {A : Type} {R : A → A → Type} {a a' a₁ a₂ a₃ a₄ : A}
definition concat (r : R a₁ a₂) (l : paths R a₂ a₃) : paths R a₁ a₃ :=
begin
induction l with a a₂ a₃ a₄ r' l IH,
{ exact [r]},
{ exact r' :: IH r}
end
theorem concat_nil (r : R a₁ a₂) : concat r (@nil A R a₂) = [r] := idp
theorem concat_cons (r : R a₁ a₂) (r' : R a₃ a₄) (l : paths R a₂ a₃)
: concat r (r'::l) = r'::(concat r l) := idp
definition append (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
paths R a₁ a₃ :=
begin
induction l₂,
{ exact l₁},
{ exact cons r (v_0 l₁)}
end
infix ` ++ ` := append
definition nil_append (l : paths R a₁ a₂) : nil ++ l = l := idp
definition cons_append (r : R a₃ a₄) (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
(r :: l₂) ++ l₁ = r :: (l₂ ++ l₁) := idp
definition singleton_append (r : R a₂ a₃) (l : paths R a₁ a₂) : [r] ++ l = r :: l := idp
definition append_singleton (l : paths R a₂ a₃) (r : R a₁ a₂) : l ++ [r] = concat r l :=
begin
induction l,
{ reflexivity},
{ exact ap (cons r) !v_0}
end
definition append_nil (l : paths R a₁ a₂) : l ++ nil = l :=
begin
induction l,
{ reflexivity},
{ exact ap (cons r) v_0}
end
definition append_assoc (l₃ : paths R a₃ a₄) (l₂ : paths R a₂ a₃)
(l₁ : paths R a₁ a₂) : (l₃ ++ l₂) ++ l₁ = l₃ ++ (l₂ ++ l₁) :=
begin
induction l₃,
{ reflexivity},
{ refine ap (cons r) !v_0}
end
theorem append_concat (l₂ : paths R a₃ a₄) (l₁ : paths R a₂ a₃) (r : R a₁ a₂) :
l₂ ++ concat r l₁ = concat r (l₂ ++ l₁) :=
begin
induction l₂,
{ reflexivity},
{ exact ap (cons r_1) !v_0}
end
theorem concat_append (l₂ : paths R a₃ a₄) (r : R a₂ a₃) (l₁ : paths R a₁ a₂) :
concat r l₂ ++ l₁ = l₂ ++ r :: l₁ :=
begin
induction l₂,
{ reflexivity},
{ exact ap (cons r) !v_0}
end
definition paths.rec_tail {C : Π⦃a a' : A⦄, paths R a a' → Type}
(H0 : Π {a : A}, @C a a nil)
(H1 : Π {a₁ a₂ a₃ : A} (r : R a₁ a₂) (l : paths R a₂ a₃), C l → C (concat r l)) :
Π{a a' : A} (l : paths R a a'), C l :=
begin
have Π{a₁ a₂ a₃ : A} (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) (c : C l₂),
C (l₂ ++ l₁),
begin
intros, revert a₃ l₂ c, induction l₁: intros a₃ l₂ c,
{ rewrite append_nil, exact c},
{ rewrite [-concat_append], apply v_0, apply H1, exact c}
end,
intros, rewrite [-nil_append], apply this, apply H0
end
definition cons_eq_concat (r : R a₂ a₃) (l : paths R a₁ a₂) :
Σa (r' : R a₁ a) (l' : paths R a a₃), r :: l = concat r' l' :=
begin
revert a₃ r, induction l: intros a₃' r',
{ exact ⟨a₃', r', nil, idp⟩},
{ cases (v_0 a₃ r) with a₄ w, cases w with r₂ w, cases w with l p, clear v_0,
exact ⟨a₄, r₂, r' :: l, ap (cons r') p⟩}
end
definition length (l : paths R a₁ a₂) : ℕ :=
begin
induction l,
{ exact 0},
{ exact succ v_0}
end
/- If we can reverse edges in the graph we can reverse paths -/
definition reverse (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂) :
paths R a₂ a₁ :=
begin
induction l,
{ exact nil},
{ exact concat (rev r) v_0}
end
theorem reverse_nil (rev : Π⦃a a'⦄, R a a' → R a' a) : reverse rev (@nil A R a₁) = [] := idp
theorem reverse_cons (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₂ a₃) (l : paths R a₁ a₂) :
reverse rev (r::l) = concat (rev r) (reverse rev l) := idp
theorem reverse_singleton (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) :
reverse rev [r] = [rev r] := idp
theorem reverse_pair (rev : Π⦃a a'⦄, R a a' → R a' a) (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
reverse rev [r₂, r₁] = [rev r₁, rev r₂] := idp
theorem reverse_concat (rev : Π⦃a a'⦄, R a a' → R a' a) (r : R a₁ a₂) (l : paths R a₂ a₃) :
reverse rev (concat r l) = rev r :: (reverse rev l) :=
begin
induction l,
{ reflexivity},
{ rewrite [concat_cons, reverse_cons, v_0]}
end
theorem reverse_append (rev : Π⦃a a'⦄, R a a' → R a' a) (l₂ : paths R a₂ a₃)
(l₁ : paths R a₁ a₂) : reverse rev (l₂ ++ l₁) = reverse rev l₁ ++ reverse rev l₂ :=
begin
induction l₂,
{ exact !append_nil⁻¹},
{ rewrite [cons_append, +reverse_cons, append_concat, v_0]}
end
definition realize (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
⦃a a' : A⦄ (l : paths R a a') : P a a' :=
begin
induction l,
{ exact ρ a},
{ exact c v_0 (f r)}
end
definition realize_nil (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃) (a : A) :
realize P f ρ c nil = ρ a :=
idp
definition realize_cons (P : A → A → Type) (f : Π⦃a a'⦄, R a a' → P a a') (ρ : Πa, P a a)
(c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃)
⦃a₁ a₂ a₃ : A⦄ (r : R a₂ a₃) (l : paths R a₁ a₂) :
realize P f ρ c (r :: l) = c (realize P f ρ c l) (f r) :=
idp
theorem realize_singleton {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
⦃a₁ a₂ : A⦄ (r : R a₁ a₂) :
realize P f ρ c [r] = f r :=
id_left (f r)
theorem realize_pair {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(id_left : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c (ρ a₁) p = p)
⦃a₁ a₂ a₃ : A⦄ (r₂ : R a₂ a₃) (r₁ : R a₁ a₂) :
realize P f ρ c [r₂, r₁] = c (f r₁) (f r₂) :=
ap (λx, c x (f r₂)) (realize_singleton id_left r₁)
theorem realize_append {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
(id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
⦃a₁ a₂ a₃ : A⦄ (l₂ : paths R a₂ a₃) (l₁ : paths R a₁ a₂) :
realize P f ρ c (l₂ ++ l₁) = c (realize P f ρ c l₁) (realize P f ρ c l₂) :=
begin
induction l₂,
{ exact !id_right⁻¹},
{ rewrite [cons_append, +realize_cons, v_0, assoc]}
end
/-
We sometimes want to take quotients of paths (this library was developed to define the pushout of
categories). The definition paths_rel will - given some basic reduction rules codified by Q -
extend the reduction to a reflexive transitive relation respecting concatenation of paths.
-/
inductive paths_rel {A : Type} {R : A → A → Type}
(Q : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type)
: Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type :=
| rrefl : Π{a a' : A} (l : paths R a a'), paths_rel Q l l
| rel : Π{a₁ a₂ a₃ : A} {l₂ l₃ : paths R a₂ a₃} (l : paths R a₁ a₂) (q : Q l₂ l₃),
paths_rel Q (l₂ ++ l) (l₃ ++ l)
| rcons : Π{a₁ a₂ a₃ : A} {l₁ l₂ : paths R a₁ a₂} (r : R a₂ a₃),
paths_rel Q l₁ l₂ → paths_rel Q (cons r l₁) (cons r l₂)
| rtrans : Π{a₁ a₂ : A} {l₁ l₂ l₃ : paths R a₁ a₂},
paths_rel Q l₁ l₂ → paths_rel Q l₂ l₃ → paths_rel Q l₁ l₃
open paths_rel
attribute rrefl [refl]
attribute rtrans [trans]
variables {Q : Π⦃a a' : A⦄, paths R a a' → paths R a a' → Type}
definition paths_rel_of_Q {l₁ l₂ : paths R a₁ a₂} (q : Q l₁ l₂) :
paths_rel Q l₁ l₂ :=
begin
rewrite [-append_nil l₁, -append_nil l₂], exact rel nil q,
end
theorem rel_respect_append_left (l : paths R a₂ a₃) {l₃ l₄ : paths R a₁ a₂}
(H : paths_rel Q l₃ l₄) : paths_rel Q (l ++ l₃) (l ++ l₄) :=
begin
induction l,
{ exact H},
{ exact rcons r (v_0 _ _ H)}
end
theorem rel_respect_append_right {l₁ l₂ : paths R a₂ a₃} (l : paths R a₁ a₂)
(H₁ : paths_rel Q l₁ l₂) : paths_rel Q (l₁ ++ l) (l₂ ++ l) :=
begin
induction H₁ with a₁ a₂ l₁
a₂ a₃ a₄ l₂ l₂' l₁ q
a₂ a₃ a₄ l₁ l₂ r H₁ IH
a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
{ reflexivity},
{ rewrite [+ append_assoc], exact rel _ q},
{ exact rcons r (IH l) },
{ exact rtrans (IH l) (IH' l)}
end
theorem rel_respect_append {l₁ l₂ : paths R a₂ a₃} {l₃ l₄ : paths R a₁ a₂}
(H₁ : paths_rel Q l₁ l₂) (H₂ : paths_rel Q l₃ l₄) :
paths_rel Q (l₁ ++ l₃) (l₂ ++ l₄) :=
begin
induction H₁ with a₁ a₂ l
a₂ a₃ a₄ l₂ l₂' l q
a₂ a₃ a₄ l₁ l₂ r H₁ IH
a₂ a₃ l₁ l₂ l₂' H₁ H₁' IH IH',
{ exact rel_respect_append_left _ H₂},
{ rewrite [+ append_assoc], transitivity _, exact rel _ q,
apply rel_respect_append_left, apply rel_respect_append_left, exact H₂},
{ exact rcons r (IH _ _ H₂) },
{ refine rtrans (IH _ _ H₂) _, apply rel_respect_append_right, exact H₁'}
end
/- assuming some extra properties the relation respects reversing -/
theorem rel_respect_reverse (rev : Π⦃a a'⦄, R a a' → R a' a) {l₁ l₂ : paths R a₁ a₂}
(H : paths_rel Q l₁ l₂)
(rev_rel : Π⦃a a' : A⦄ {l l' : paths R a a'},
Q l l' → paths_rel Q (reverse rev l) (reverse rev l')) :
paths_rel Q (reverse rev l₁) (reverse rev l₂) :=
begin
induction H,
{ reflexivity},
{ rewrite [+ reverse_append], apply rel_respect_append_left, apply rev_rel q},
{ rewrite [+reverse_cons,-+append_singleton], apply rel_respect_append_right, exact v_0},
{ exact rtrans v_0 v_1}
end
theorem rel_left_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂)
(li : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [rev r, r] nil) :
paths_rel Q (reverse rev l ++ l) nil :=
begin
induction l,
{ reflexivity},
{ rewrite [reverse_cons, concat_append],
refine rtrans _ v_0, apply rel_respect_append_left,
exact rel_respect_append_right _ (li r)}
end
theorem rel_right_inv (rev : Π⦃a a'⦄, R a a' → R a' a) (l : paths R a₁ a₂)
(ri : Π⦃a a' : A⦄ (r : R a a'), paths_rel Q [r, rev r] nil) :
paths_rel Q (l ++ reverse rev l) nil :=
begin
induction l using paths.rec_tail,
{ reflexivity},
{ rewrite [reverse_concat, concat_append],
refine rtrans _ a, apply rel_respect_append_left,
exact rel_respect_append_right _ (ri r)}
end
definition realize_eq {P : A → A → Type} {f : Π⦃a a'⦄, R a a' → P a a'} {ρ : Πa, P a a}
{c : Π⦃a₁ a₂ a₃⦄, P a₁ a₂ → P a₂ a₃ → P a₁ a₃}
(assoc : Π⦃a₁ a₂ a₃ a₄⦄ (p : P a₁ a₂) (q : P a₂ a₃) (r : P a₃ a₄), c (c p q) r = c p (c q r))
(id_right : Π⦃a₁ a₂⦄ (p : P a₁ a₂), c p (ρ a₂) = p)
(resp_rel : Π⦃a₁ a₂⦄ {l₁ l₂ : paths R a₁ a₂}, Q l₁ l₂ →
realize P f ρ c l₁ = realize P f ρ c l₂)
⦃a a' : A⦄ {l l' : paths R a a'} (H : paths_rel Q l l') :
realize P f ρ c l = realize P f ρ c l' :=
begin
induction H,
{ reflexivity},
{ rewrite [+realize_append assoc id_right], apply ap (c _), exact resp_rel q},
{ exact ap (λx, c x (f r)) v_0},
{ exact v_0 ⬝ v_1}
end
end paths

4
hott/book.md
View file

@ -22,7 +22,7 @@ The rows indicate the chapters, the columns the sections.
| Ch 5 | - | . | ½ | - | - | . | . | ½ | | | | | | | |
| Ch 6 | . | + | + | + | + | + | + | + | ¾ | ¼ | ¾ | + | . | | |
| Ch 7 | + | + | + | - | ¾ | - | - | | | | | | | | |
| Ch 8 | + | + | + | + | + | ¾ | - | + | + | ¼ | | | | | |
| Ch 8 | + | + | + | + | + | ¾ | ½ | + | + | ¼ | | | | | |
| Ch 9 | ¾ | + | + | ½ | ¾ | ½ | - | - | - | | | | | | |
| Ch 10 | ¼ | - | - | - | - | | | | | | | | | | |
| Ch 11 | - | - | - | - | - | - | | | | | | | | | |
@ -151,7 +151,7 @@ Every file is in the folder [homotopy](homotopy/homotopy.md)
- 8.4 (Fiber sequences and the long exact sequence): Mostly in [homotopy.chain_complex](homotopy/chain_complex.hlean), [homotopy.LES_of_homotopy_groups](homotopy/LES_of_homotopy_groups.hlean). Definitions 8.4.1 and 8.4.2 in [types.pointed](types/pointed.hlean), Corollary 8.4.8 in [homotopy.homotopy_group](homotopy/homotopy_group.hlean).
- 8.5 (The Hopf fibration): [hit.pushout](hit/pushout.hlean) (Lemma 8.5.3), [hopf](homotopy/hopf.hlean) (The Hopf construction, Lemmas 8.5.5 and 8.5.7), [susp](homotopy/susp.hlean) (Definition 8.5.6), [circle](homotopy/circle.hlean) (multiplication on the circle, Lemma 8.5.8), [join](homotopy/join.hlean) (join is associative, Lemma 8.5.9), [complex_hopf](homotopy/complex_hopf.hlean) (the H-space structure on the circle and the complex Hopf fibration, i.e. Theorem 8.5.1), [sphere2](homotopy/sphere2.hlean) (Corollary 8.5.2)
- 8.6 (The Freudenthal suspension theorem): [connectedness](homotopy/connectedness.hlean) (Lemma 8.6.1), [wedge](homotopy/wedge.hlean) (Wedge connectivity, Lemma 8.6.2). Corollary 8.6.14 is proven directly in [freudenthal](homotopy/freudenthal.hlean), however, we don't prove Theorem 8.6.4. Stability of iterated suspensions is also in [freudenthal](homotopy/freudenthal.hlean). The homotopy groups of spheres in this section are computed in [sphere2](homotopy/sphere2.hlean).
- 8.7 (The van Kampen theorem): not formalized
- 8.7 (The van Kampen theorem): Naive van Kampen is proven in [vankampen](homotopy/vankampen.hlean) (the pushout of Groupoids is formalized in [algebra.category.constructions.pushout](algebra/category/constructions/pushout.hlean)
- 8.8 (Whitehead’s theorem and Whitehead’s principle): 8.8.1 and 8.8.2 at the bottom of [types.trunc](types/trunc.hlean), 8.8.3 in [homotopy_group](homotopy/homotopy_group.hlean). [Rest to be moved]
- 8.9 (A general statement of the encode-decode method): [types.eq](types/eq.hlean).
- 8.10 (Additional Results): Theorem 8.10.3 is formalized in [homotopy.EM](homotopy/EM.hlean).

27
hott/homotopy/vankampen.hlean
View file

@ -7,7 +7,7 @@ Authors: Floris van Doorn
import hit.pushout algebra.category.constructions.pushout algebra.category.constructions.type
algebra.category.functor.equivalence
open eq pushout category functor sum iso indexed_list set_quotient is_trunc trunc pi quotient
open eq pushout category functor sum iso paths set_quotient is_trunc trunc pi quotient
is_equiv
namespace pushout
@ -18,14 +18,9 @@ namespace pushout
definition pushout_of_sum [unfold 6] (x : BL + TR) : pushout f g :=
quotient.class_of _ x
local notation `C` := Groupoid_pushout (fundamental_groupoid_functor f)
(fundamental_groupoid_functor g)
local notation `R` := pushout_prehom_index (fundamental_groupoid_functor f)
(fundamental_groupoid_functor g)
local notation `Q` := pushout_hom_rel_index (fundamental_groupoid_functor f)
(fundamental_groupoid_functor g)
local notation `C` := Groupoid_pushout (fundamental_groupoid BL) (fundamental_groupoid TR) f g
local notation `R` := pushout_prehom_index (fundamental_groupoid BL) (fundamental_groupoid TR) f g
local notation `Q` := pushout_hom_rel_index (fundamental_groupoid BL) (fundamental_groupoid TR) f g
protected definition code [unfold 7] (x : BL + TR) (y : pushout f g) : Type.{max u v w} :=
begin
@ -61,7 +56,7 @@ namespace pushout
{ exact tr (glue c)⁻¹},
end
definition decode_list ⦃x x' : BL + TR⦄ (l : indexed_list R x x') :
definition decode_list ⦃x x' : BL + TR⦄ (l : paths R x x') :
trunc 0 (pushout_of_sum x = pushout_of_sum x') :=
realize (λa a', trunc 0 (pushout_of_sum a = pushout_of_sum a'))
decode_reduction_rule
@ -71,7 +66,7 @@ namespace pushout
definition decode_list_nil (x : BL + TR) : decode_list (@nil _ _ x) = tidp :=
idp
definition decode_list_cons ⦃x₁ x₂ x₃ : BL + TR⦄ (r : R x₂ x₃) (l : indexed_list R x₁ x₂) :
definition decode_list_cons ⦃x₁ x₂ x₃ : BL + TR⦄ (r : R x₂ x₃) (l : paths R x₁ x₂) :
decode_list (r :: l) = tconcat (decode_list l) (decode_reduction_rule r) :=
idp
@ -83,12 +78,12 @@ namespace pushout
decode_list [r₂, r₁] = tconcat (decode_reduction_rule r₁) (decode_reduction_rule r₂) :=
realize_pair (λa b p, tidp_tcon p) r₂ r₁
definition decode_list_append ⦃x₁ x₂ x₃ : BL + TR⦄ (l₂ : indexed_list R x₂ x₃)
(l₁ : indexed_list R x₁ x₂) :
definition decode_list_append ⦃x₁ x₂ x₃ : BL + TR⦄ (l₂ : paths R x₂ x₃)
(l₁ : paths R x₁ x₂) :
decode_list (l₂ ++ l₁) = tconcat (decode_list l₁) (decode_list l₂) :=
realize_append (λa b c d, tassoc) (λa b, tcon_tidp) l₂ l₁
theorem decode_list_rel ⦃x x' : BL + TR⦄ {l l' : indexed_list R x x'} (H : Q l l') :
theorem decode_list_rel ⦃x x' : BL + TR⦄ {l l' : paths R x x'} (H : Q l l') :
decode_list l = decode_list l' :=
begin
induction H,
@ -199,9 +194,9 @@ namespace pushout
have is_prop (encode (decode_reduction_rule r) = class_of [r]), from !is_trunc_eq,
induction r,
{ induction f_1 with p, induction p, symmetry, apply eq_of_rel,
apply tr, apply indexed_list_rel_of_Q, apply idD},
apply tr, apply paths_rel_of_Q, apply idD},
{ induction g_1 with p, induction p, symmetry, apply eq_of_rel,
apply tr, apply indexed_list_rel_of_Q, apply idE},
apply tr, apply paths_rel_of_Q, apply idE},
{ refine !elim_type_eq_of_rel ⬝ _, apply eq_of_rel, apply tr, rewrite [append_nil]},
{ refine !elim_type_eq_of_rel_inv' ⬝ _, apply eq_of_rel, apply tr, rewrite [append_nil]}
end

27
hott/init/funext.hlean
View file

@ -125,31 +125,28 @@ section
from (@right_inv _ _ (@equiv_of_eq A B) (univalence A B) w'),
have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹,
from inv_eq eq' w' eqretr,
have eqfin1 : Π(p : A = B), (to_fun (equiv_of_eq p)) ∘ ((to_fun (equiv_of_eq p))⁻¹ ∘ x) = x,
by intro p; induction p; reflexivity,
have eqfin : (to_fun eq') ∘ ((to_fun eq')⁻¹ ∘ x) = x,
from (λ p,
(@eq.rec_on Type.{l} A
(λ B' p', Π (x' : C → B'), (to_fun (equiv_of_eq p'))
∘ ((to_fun (equiv_of_eq p'))⁻¹ ∘ x') = x')
B p (λ x', idp))
) eqinv x,
from eqfin1 eqinv,
have eqfin' : (to_fun w') ∘ ((to_fun eq')⁻¹ ∘ x) = x,
from eqretr ▸ eqfin,
have eqfin'' : (to_fun w') ∘ ((to_fun w')⁻¹ ∘ x) = x,
from invs_eq ▸ eqfin',
eqfin''
from ap (λu, u ∘ _) eqretr⁻¹ ⬝ eqfin,
show (to_fun w') ∘ ((to_fun w')⁻¹ ∘ x) = x,
from ap (λu, _ ∘ (u ∘ _)) invs_eq⁻¹ ⬝ eqfin'
)
(λ (x : C → A),
have eqretr : eq' = w',
from (@right_inv _ _ (@equiv_of_eq A B) (univalence A B) w'),
have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹,
from inv_eq eq' w' eqretr,
have eqfin1 : Π(p : A = B), (to_fun (equiv_of_eq p))⁻¹ ∘ ((to_fun (equiv_of_eq p)) ∘ x) = x,
by intro p; induction p; reflexivity,
have eqfin : (to_fun eq')⁻¹ ∘ ((to_fun eq') ∘ x) = x,
from (λ p, eq.rec_on p idp) eqinv,
from eqfin1 eqinv,
have eqfin' : (to_fun eq')⁻¹ ∘ ((to_fun w') ∘ x) = x,
from eqretr ▸ eqfin,
have eqfin'' : (to_fun w')⁻¹ ∘ ((to_fun w') ∘ x) = x,
from invs_eq ▸ eqfin',
eqfin''
from ap (λu, _ ∘ (u ∘ _)) eqretr⁻¹ ⬝ eqfin,
show (to_fun w')⁻¹ ∘ ((to_fun w') ∘ x) = x,
from ap (λu, u ∘ _) invs_eq⁻¹ ⬝ eqfin'
)
-- We are ready to prove functional extensionality,