Compare commits
4 commits
mzhang/fix
...
imp_hott
| Author | SHA1 | Date | |
|---|---|---|---|
|
5333dcfa02 | ||
|
d68cdae2f3 | ||
|
|
7411011340 | ||
|
|
18313bfab0 |
166 changed files with 86 additions and 37469 deletions
|
|
@ -1,29 +0,0 @@
|
|||
algebra
|
||||
=======
|
||||
|
||||
The following files are [ported](../port.md) from the standard library. If anything needs to be changed, it is probably a good idea to change it in the standard library and then port the file again (see also [script/port.pl](../../script/port.pl)).
|
||||
|
||||
* [priority](priority.hlean) : priority for algebraic operations
|
||||
* [relation](relation.hlean)
|
||||
* [binary](binary.hlean) : binary operations
|
||||
* [order](order.hlean)
|
||||
* [lattice](lattice.hlean)
|
||||
* [group](group.hlean)
|
||||
* [ring](ring.hlean)
|
||||
* [ordered_group](ordered_group.hlean)
|
||||
* [ordered_ring](ordered_ring.hlean)
|
||||
* [field](field.hlean)
|
||||
* [ordered_field](ordered_field.hlean)
|
||||
* [bundled](bundled.hlean) : bundled versions of the algebraic structures
|
||||
|
||||
Files which are not ported from the standard library:
|
||||
|
||||
* [group_theory](group_theory.hlean) : Basic theorems about group homomorphisms and isomorphisms
|
||||
* [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):
|
||||
|
||||
* [category](category/category.md) : Category Theory
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Leonardo de Moura, Jeremy Avigad
|
||||
|
||||
General properties of binary operations.
|
||||
-/
|
||||
open eq.ops function
|
||||
|
||||
namespace binary
|
||||
section
|
||||
variable {A : Type}
|
||||
variables (op₁ : A → A → A) (inv : A → A) (one : A)
|
||||
|
||||
local notation a * b := op₁ a b
|
||||
local notation a ⁻¹ := inv a
|
||||
|
||||
definition commutative := Πa b, a * b = b * a
|
||||
definition associative := Πa b c, (a * b) * c = a * (b * c)
|
||||
definition left_identity := Πa, one * a = a
|
||||
definition right_identity := Πa, a * one = a
|
||||
definition left_inverse := Πa, a⁻¹ * a = one
|
||||
definition right_inverse := Πa, a * a⁻¹ = one
|
||||
definition left_cancelative := Πa b c, a * b = a * c → b = c
|
||||
definition right_cancelative := Πa b c, a * b = c * b → a = c
|
||||
|
||||
definition inv_op_cancel_left := Πa b, a⁻¹ * (a * b) = b
|
||||
definition op_inv_cancel_left := Πa b, a * (a⁻¹ * b) = b
|
||||
definition inv_op_cancel_right := Πa b, a * b⁻¹ * b = a
|
||||
definition op_inv_cancel_right := Πa b, a * b * b⁻¹ = a
|
||||
|
||||
variable (op₂ : A → A → A)
|
||||
|
||||
local notation a + b := op₂ a b
|
||||
|
||||
definition left_distributive := Πa b c, a * (b + c) = a * b + a * c
|
||||
definition right_distributive := Πa b c, (a + b) * c = a * c + b * c
|
||||
|
||||
definition right_commutative {B : Type} (f : B → A → B) := Π b a₁ a₂, f (f b a₁) a₂ = f (f b a₂) a₁
|
||||
definition left_commutative {B : Type} (f : A → B → B) := Π a₁ a₂ b, f a₁ (f a₂ b) = f a₂ (f a₁ b)
|
||||
end
|
||||
|
||||
section
|
||||
variable {A : Type}
|
||||
variable {f : A → A → A}
|
||||
variable H_comm : commutative f
|
||||
variable H_assoc : associative f
|
||||
local infixl `*` := f
|
||||
theorem left_comm : left_commutative f :=
|
||||
take a b c, calc
|
||||
a*(b*c) = (a*b)*c : H_assoc
|
||||
... = (b*a)*c : H_comm
|
||||
... = b*(a*c) : H_assoc
|
||||
|
||||
theorem right_comm : right_commutative f :=
|
||||
take a b c, calc
|
||||
(a*b)*c = a*(b*c) : H_assoc
|
||||
... = a*(c*b) : H_comm
|
||||
... = (a*c)*b : H_assoc
|
||||
|
||||
theorem comm4 (a b c d : A) : a*b*(c*d) = a*c*(b*d) :=
|
||||
calc
|
||||
a*b*(c*d) = a*b*c*d : H_assoc
|
||||
... = a*c*b*d : right_comm H_comm H_assoc
|
||||
... = a*c*(b*d) : H_assoc
|
||||
end
|
||||
|
||||
section
|
||||
variable {A : Type}
|
||||
variable {f : A → A → A}
|
||||
variable H_assoc : associative f
|
||||
local infixl `*` := f
|
||||
theorem assoc4helper (a b c d) : (a*b)*(c*d) = a*((b*c)*d) :=
|
||||
calc
|
||||
(a*b)*(c*d) = a*(b*(c*d)) : H_assoc
|
||||
... = a*((b*c)*d) : H_assoc
|
||||
end
|
||||
|
||||
definition right_commutative_compose_right
|
||||
{A B : Type} (f : A → A → A) (g : B → A) (rcomm : right_commutative f) : right_commutative (compose_right f g) :=
|
||||
λ a b₁ b₂, !rcomm
|
||||
|
||||
definition left_commutative_compose_left
|
||||
{A B : Type} (f : A → A → A) (g : B → A) (lcomm : left_commutative f) : left_commutative (compose_left f g) :=
|
||||
λ a b₁ b₂, !lcomm
|
||||
end binary
|
||||
|
||||
open eq
|
||||
namespace is_equiv
|
||||
definition inv_preserve_binary {A B : Type} (f : A → B) [H : is_equiv f]
|
||||
(mA : A → A → A) (mB : B → B → B) (H : Π(a a' : A), f (mA a a') = mB (f a) (f a'))
|
||||
(b b' : B) : f⁻¹ (mB b b') = mA (f⁻¹ b) (f⁻¹ b') :=
|
||||
begin
|
||||
have H2 : f⁻¹ (mB (f (f⁻¹ b)) (f (f⁻¹ b'))) = f⁻¹ (f (mA (f⁻¹ b) (f⁻¹ b'))), from ap f⁻¹ !H⁻¹,
|
||||
rewrite [+right_inv f at H2,left_inv f at H2,▸* at H2,H2]
|
||||
end
|
||||
|
||||
definition preserve_binary_of_inv_preserve {A B : Type} (f : A → B) [H : is_equiv f]
|
||||
(mA : A → A → A) (mB : B → B → B) (H : Π(b b' : B), f⁻¹ (mB b b') = mA (f⁻¹ b) (f⁻¹ b'))
|
||||
(a a' : A) : f (mA a a') = mB (f a) (f a') :=
|
||||
begin
|
||||
have H2 : f (mA (f⁻¹ (f a)) (f⁻¹ (f a'))) = f (f⁻¹ (mB (f a) (f a'))), from ap f !H⁻¹,
|
||||
rewrite [right_inv f at H2,+left_inv f at H2,▸* at H2,H2]
|
||||
end
|
||||
end is_equiv
|
||||
namespace equiv
|
||||
open is_equiv
|
||||
definition inv_preserve_binary {A B : Type} (f : A ≃ B)
|
||||
(mA : A → A → A) (mB : B → B → B) (H : Π(a a' : A), f (mA a a') = mB (f a) (f a'))
|
||||
(b b' : B) : f⁻¹ (mB b b') = mA (f⁻¹ b) (f⁻¹ b') :=
|
||||
inv_preserve_binary f mA mB H b b'
|
||||
|
||||
definition preserve_binary_of_inv_preserve {A B : Type} (f : A ≃ B)
|
||||
(mA : A → A → A) (mB : B → B → B) (H : Π(b b' : B), f⁻¹ (mB b b') = mA (f⁻¹ b) (f⁻¹ b'))
|
||||
(a a' : A) : f (mA a a') = mB (f a) (f a') :=
|
||||
preserve_binary_of_inv_preserve f mA mB H a a'
|
||||
end equiv
|
||||
|
|
@ -1,193 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad
|
||||
|
||||
Bundled structures
|
||||
-/
|
||||
import algebra.group homotopy.interval
|
||||
open algebra pointed is_trunc
|
||||
|
||||
namespace algebra
|
||||
structure Semigroup :=
|
||||
(carrier : Type) (struct : semigroup carrier)
|
||||
|
||||
attribute Semigroup.carrier [coercion]
|
||||
attribute Semigroup.struct [instance]
|
||||
|
||||
structure CommSemigroup :=
|
||||
(carrier : Type) (struct : comm_semigroup carrier)
|
||||
|
||||
attribute CommSemigroup.carrier [coercion]
|
||||
attribute CommSemigroup.struct [instance]
|
||||
|
||||
structure Monoid :=
|
||||
(carrier : Type) (struct : monoid carrier)
|
||||
|
||||
attribute Monoid.carrier [coercion]
|
||||
attribute Monoid.struct [instance]
|
||||
|
||||
structure CommMonoid :=
|
||||
(carrier : Type) (struct : comm_monoid carrier)
|
||||
|
||||
attribute CommMonoid.carrier [coercion]
|
||||
attribute CommMonoid.struct [instance]
|
||||
|
||||
structure Group :=
|
||||
(carrier : Type) (struct : group carrier)
|
||||
|
||||
attribute Group.carrier [coercion]
|
||||
attribute Group.struct [instance]
|
||||
|
||||
section
|
||||
local attribute Group.struct [instance]
|
||||
definition pSet_of_Group [constructor] [reducible] [coercion] (G : Group) : Set* :=
|
||||
ptrunctype.mk G !semigroup.is_set_carrier 1
|
||||
end
|
||||
|
||||
attribute algebra._trans_of_pSet_of_Group [unfold 1]
|
||||
attribute algebra._trans_of_pSet_of_Group_1 algebra._trans_of_pSet_of_Group_2 [constructor]
|
||||
|
||||
definition pType_of_Group [reducible] [constructor] : Group → Type* :=
|
||||
algebra._trans_of_pSet_of_Group_1
|
||||
definition Set_of_Group [reducible] [constructor] : Group → Set :=
|
||||
algebra._trans_of_pSet_of_Group_2
|
||||
|
||||
definition AddGroup : Type := Group
|
||||
|
||||
definition AddGroup.mk [constructor] [reducible] (G : Type) (H : add_group G) : AddGroup :=
|
||||
Group.mk G H
|
||||
|
||||
definition AddGroup.struct [reducible] (G : AddGroup) : add_group G :=
|
||||
Group.struct G
|
||||
|
||||
attribute AddGroup.struct Group.struct [instance] [priority 2000]
|
||||
|
||||
structure AbGroup :=
|
||||
(carrier : Type) (struct : ab_group carrier)
|
||||
|
||||
attribute AbGroup.carrier [coercion]
|
||||
|
||||
definition AddAbGroup : Type := AbGroup
|
||||
|
||||
definition AddAbGroup.mk [constructor] [reducible] (G : Type) (H : add_ab_group G) :
|
||||
AddAbGroup :=
|
||||
AbGroup.mk G H
|
||||
|
||||
definition AddAbGroup.struct [reducible] (G : AddAbGroup) : add_ab_group G :=
|
||||
AbGroup.struct G
|
||||
|
||||
attribute AddAbGroup.struct AbGroup.struct [instance] [priority 2000]
|
||||
|
||||
definition Group_of_AbGroup [coercion] [constructor] (G : AbGroup) : Group :=
|
||||
Group.mk G _
|
||||
|
||||
attribute algebra._trans_of_Group_of_AbGroup_1
|
||||
algebra._trans_of_Group_of_AbGroup
|
||||
algebra._trans_of_Group_of_AbGroup_3 [constructor]
|
||||
attribute algebra._trans_of_Group_of_AbGroup_2 [unfold 1]
|
||||
|
||||
definition ab_group_AbGroup [instance] (G : AbGroup) : ab_group G :=
|
||||
AbGroup.struct G
|
||||
|
||||
definition add_ab_group_AddAbGroup [instance] (G : AddAbGroup) : add_ab_group G :=
|
||||
AbGroup.struct G
|
||||
|
||||
-- structure AddSemigroup :=
|
||||
-- (carrier : Type) (struct : add_semigroup carrier)
|
||||
|
||||
-- attribute AddSemigroup.carrier [coercion]
|
||||
-- attribute AddSemigroup.struct [instance]
|
||||
|
||||
-- structure AddCommSemigroup :=
|
||||
-- (carrier : Type) (struct : add_comm_semigroup carrier)
|
||||
|
||||
-- attribute AddCommSemigroup.carrier [coercion]
|
||||
-- attribute AddCommSemigroup.struct [instance]
|
||||
|
||||
-- structure AddMonoid :=
|
||||
-- (carrier : Type) (struct : add_monoid carrier)
|
||||
|
||||
-- attribute AddMonoid.carrier [coercion]
|
||||
-- attribute AddMonoid.struct [instance]
|
||||
|
||||
-- structure AddCommMonoid :=
|
||||
-- (carrier : Type) (struct : add_comm_monoid carrier)
|
||||
|
||||
-- attribute AddCommMonoid.carrier [coercion]
|
||||
-- attribute AddCommMonoid.struct [instance]
|
||||
|
||||
-- structure AddGroup :=
|
||||
-- (carrier : Type) (struct : add_group carrier)
|
||||
|
||||
-- attribute AddGroup.carrier [coercion]
|
||||
-- attribute AddGroup.struct [instance]
|
||||
|
||||
-- structure AddAbGroup :=
|
||||
-- (carrier : Type) (struct : add_ab_group carrier)
|
||||
|
||||
-- attribute AddAbGroup.carrier [coercion]
|
||||
-- attribute AddAbGroup.struct [instance]
|
||||
|
||||
|
||||
-- some bundled infinity-structures
|
||||
structure InfGroup :=
|
||||
(carrier : Type) (struct : inf_group carrier)
|
||||
|
||||
attribute InfGroup.carrier [coercion]
|
||||
attribute InfGroup.struct [instance]
|
||||
|
||||
section
|
||||
local attribute InfGroup.struct [instance]
|
||||
definition pType_of_InfGroup [constructor] [reducible] [coercion] (G : InfGroup) : Type* :=
|
||||
pType.mk G 1
|
||||
end
|
||||
|
||||
attribute algebra._trans_of_pType_of_InfGroup [unfold 1]
|
||||
|
||||
definition AddInfGroup : Type := InfGroup
|
||||
|
||||
definition AddInfGroup.mk [constructor] [reducible] (G : Type) (H : add_inf_group G) :
|
||||
AddInfGroup :=
|
||||
InfGroup.mk G H
|
||||
|
||||
definition AddInfGroup.struct [reducible] (G : AddInfGroup) : add_inf_group G :=
|
||||
InfGroup.struct G
|
||||
|
||||
attribute AddInfGroup.struct InfGroup.struct [instance] [priority 2000]
|
||||
|
||||
structure AbInfGroup :=
|
||||
(carrier : Type) (struct : ab_inf_group carrier)
|
||||
|
||||
attribute AbInfGroup.carrier [coercion]
|
||||
|
||||
definition AddAbInfGroup : Type := AbInfGroup
|
||||
|
||||
definition AddAbInfGroup.mk [constructor] [reducible] (G : Type) (H : add_ab_inf_group G) :
|
||||
AddAbInfGroup :=
|
||||
AbInfGroup.mk G H
|
||||
|
||||
definition AddAbInfGroup.struct [reducible] (G : AddAbInfGroup) : add_ab_inf_group G :=
|
||||
AbInfGroup.struct G
|
||||
|
||||
attribute AddAbInfGroup.struct AbInfGroup.struct [instance] [priority 2000]
|
||||
|
||||
definition InfGroup_of_AbInfGroup [coercion] [constructor] (G : AbInfGroup) : InfGroup :=
|
||||
InfGroup.mk G _
|
||||
|
||||
attribute algebra._trans_of_InfGroup_of_AbInfGroup_1 [constructor]
|
||||
attribute algebra._trans_of_InfGroup_of_AbInfGroup [unfold 1]
|
||||
|
||||
definition InfGroup_of_Group [constructor] (G : Group) : InfGroup :=
|
||||
InfGroup.mk G _
|
||||
|
||||
definition AddInfGroup_of_AddGroup [constructor] (G : AddGroup) : AddInfGroup :=
|
||||
AddInfGroup.mk G _
|
||||
|
||||
definition AbInfGroup_of_AbGroup [constructor] (G : AbGroup) : AbInfGroup :=
|
||||
AbInfGroup.mk G _
|
||||
|
||||
definition AddAbInfGroup_of_AddAbGroup [constructor] (G : AddAbGroup) : AddAbInfGroup :=
|
||||
AddAbInfGroup.mk G _
|
||||
|
||||
end algebra
|
||||
|
|
@ -1,143 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jakob von Raumer
|
||||
-/
|
||||
|
||||
import .iso
|
||||
|
||||
open iso is_equiv equiv eq is_trunc sigma
|
||||
|
||||
/-
|
||||
A category is a precategory extended by a witness
|
||||
that the function from paths to isomorphisms is an equivalence.
|
||||
-/
|
||||
namespace category
|
||||
/-
|
||||
TODO: restructure this. Should is_univalent be a class with as argument
|
||||
(C : Precategory). Or is that problematic if we want to apply this to cases where e.g.
|
||||
a b are functors, and we need to synthesize ? : precategory (functor C D).
|
||||
-/
|
||||
definition is_univalent [class] {ob : Type} (C : precategory ob) :=
|
||||
Π(a b : ob), is_equiv (iso_of_eq : a = b → a ≅ b)
|
||||
|
||||
definition is_equiv_of_is_univalent [instance] {ob : Type} [C : precategory ob]
|
||||
[H : is_univalent C] (a b : ob) : is_equiv (iso_of_eq : a = b → a ≅ b) :=
|
||||
H a b
|
||||
|
||||
structure category [class] (ob : Type) extends parent : precategory ob :=
|
||||
mk' :: (iso_of_path_equiv : is_univalent parent)
|
||||
|
||||
-- Remark: category and precategory are classes. So, the structure command
|
||||
-- does not create a coercion between them automatically.
|
||||
-- This coercion is needed for definitions such as category_eq_of_equiv
|
||||
-- without it, we would have to explicitly use category.to_precategory
|
||||
attribute category.to_precategory [coercion]
|
||||
|
||||
abbreviation iso_of_path_equiv := @category.iso_of_path_equiv
|
||||
attribute category.iso_of_path_equiv [instance]
|
||||
|
||||
definition category.mk [reducible] [unfold 2] {ob : Type} (C : precategory ob)
|
||||
(H : is_univalent C) : category ob :=
|
||||
precategory.rec_on C category.mk' H
|
||||
|
||||
section basic
|
||||
variables {ob : Type} [C : category ob]
|
||||
include C
|
||||
|
||||
-- Make iso_of_path_equiv a class instance
|
||||
attribute iso_of_path_equiv [instance]
|
||||
|
||||
definition eq_equiv_iso [constructor] (a b : ob) : (a = b) ≃ (a ≅ b) :=
|
||||
equiv.mk iso_of_eq _
|
||||
|
||||
definition eq_of_iso [reducible] {a b : ob} : a ≅ b → a = b :=
|
||||
iso_of_eq⁻¹ᶠ
|
||||
|
||||
definition iso_of_eq_eq_of_iso {a b : ob} (p : a ≅ b) : iso_of_eq (eq_of_iso p) = p :=
|
||||
right_inv iso_of_eq p
|
||||
|
||||
definition hom_of_eq_eq_of_iso {a b : ob} (p : a ≅ b) : hom_of_eq (eq_of_iso p) = to_hom p :=
|
||||
ap to_hom !iso_of_eq_eq_of_iso
|
||||
|
||||
definition inv_of_eq_eq_of_iso {a b : ob} (p : a ≅ b) : inv_of_eq (eq_of_iso p) = to_inv p :=
|
||||
ap to_inv !iso_of_eq_eq_of_iso
|
||||
|
||||
theorem eq_of_iso_refl {a : ob} : eq_of_iso (iso.refl a) = idp :=
|
||||
inv_eq_of_eq idp
|
||||
|
||||
theorem eq_of_iso_trans {a b c : ob} (p : a ≅ b) (q : b ≅ c) :
|
||||
eq_of_iso (p ⬝i q) = eq_of_iso p ⬝ eq_of_iso q :=
|
||||
begin
|
||||
apply inv_eq_of_eq,
|
||||
apply eq.inverse, apply concat, apply iso_of_eq_con,
|
||||
apply concat, apply ap (λ x, x ⬝i _), apply iso_of_eq_eq_of_iso,
|
||||
apply ap (λ x, _ ⬝i x), apply iso_of_eq_eq_of_iso
|
||||
end
|
||||
|
||||
definition is_trunc_1_ob : is_trunc 1 ob :=
|
||||
begin
|
||||
apply is_trunc_succ_intro, intro a b,
|
||||
fapply is_trunc_is_equiv_closed,
|
||||
exact (@eq_of_iso _ _ a b),
|
||||
apply is_equiv_inv,
|
||||
end
|
||||
end basic
|
||||
|
||||
-- Bundled version of categories
|
||||
-- we don't use Category.carrier explicitly, but rather use Precategory.carrier (to_Precategory C)
|
||||
structure Category : Type :=
|
||||
(carrier : Type)
|
||||
(struct : category carrier)
|
||||
|
||||
attribute Category.struct [instance] [coercion]
|
||||
|
||||
definition Category.to_Precategory [constructor] [coercion] [reducible] (C : Category)
|
||||
: Precategory :=
|
||||
Precategory.mk (Category.carrier C) _
|
||||
|
||||
definition category.Mk [constructor] [reducible] := Category.mk
|
||||
definition category.MK [constructor] [reducible] (C : Precategory)
|
||||
(H : is_univalent C) : Category := Category.mk C (category.mk C H)
|
||||
|
||||
definition Category.eta (C : Category) : Category.mk C C = C :=
|
||||
Category.rec (λob c, idp) C
|
||||
|
||||
protected definition category.sigma_char.{u v} [constructor] (ob : Type)
|
||||
: category.{u v} ob ≃ Σ(C : precategory.{u v} ob), is_univalent C :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro x, induction x, constructor, assumption},
|
||||
{ intro y, induction y with y1 y2, induction y1, constructor, assumption},
|
||||
{ intro y, induction y with y1 y2, induction y1, reflexivity},
|
||||
{ intro x, induction x, reflexivity}
|
||||
end
|
||||
|
||||
|
||||
definition category_eq {ob : Type}
|
||||
{C D : category ob}
|
||||
(p : Π{a b}, @hom ob C a b = @hom ob D a b)
|
||||
(q : Πa b c g f, cast p (@comp ob C a b c g f) = @comp ob D a b c (cast p g) (cast p f))
|
||||
: C = D :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn !category.sigma_char,
|
||||
fapply sigma_eq,
|
||||
{ induction C, induction D, esimp, exact precategory_eq @p q},
|
||||
{ unfold is_univalent, apply is_prop.elimo},
|
||||
end
|
||||
|
||||
definition category_eq_of_equiv {ob : Type}
|
||||
{C D : category ob}
|
||||
(p : Π⦃a b⦄, @hom ob C a b ≃ @hom ob D a b)
|
||||
(q : Π{a b c} g f, p (@comp ob C a b c g f) = @comp ob D a b c (p g) (p f))
|
||||
: C = D :=
|
||||
begin
|
||||
fapply category_eq,
|
||||
{ intro a b, exact ua !@p},
|
||||
{ intros, refine !cast_ua ⬝ !q ⬝ _, unfold [category.to_precategory],
|
||||
apply ap011 !@category.comp !cast_ua⁻¹ᵖ !cast_ua⁻¹ᵖ},
|
||||
end
|
||||
|
||||
-- TODO: Category_eq[']
|
||||
|
||||
end category
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
algebra.category
|
||||
================
|
||||
|
||||
Development of Category Theory. The following files are in this folder (sorted such that files only import previous files).
|
||||
|
||||
* [precategory](precategory.hlean)
|
||||
* [iso](iso.hlean) : iso, mono, epi, split mono, split epi
|
||||
* [category](category.hlean) : Categories (i.e. univalent or Rezk-complete precategories)
|
||||
* [groupoid](groupoid.hlean)
|
||||
* [functor](functor/functor.md) (subfolder) : definition and properties of functors
|
||||
* [strict](strict.hlean) : Strict categories
|
||||
* [nat_trans](nat_trans.hlean) : Natural transformations
|
||||
* [constructions](constructions/constructions.md) (subfolder) : basic constructions on categories and examples of categories
|
||||
* [limits](limits/limits.md) (subfolder) : Limits and colimits in precategories
|
||||
|
|
@ -1,174 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Comma category
|
||||
-/
|
||||
|
||||
import ..functor.basic ..strict ..category
|
||||
|
||||
open eq functor equiv sigma sigma.ops is_trunc iso is_equiv
|
||||
|
||||
namespace category
|
||||
|
||||
structure comma_object {A B C : Precategory} (S : A ⇒ C) (T : B ⇒ C) :=
|
||||
(a : A)
|
||||
(b : B)
|
||||
(f : S a ⟶ T b)
|
||||
abbreviation ob1 [unfold 6] := @comma_object.a
|
||||
abbreviation ob2 [unfold 6] := @comma_object.b
|
||||
abbreviation mor [unfold 6] := @comma_object.f
|
||||
|
||||
variables {A B C : Precategory} (S : A ⇒ C) (T : B ⇒ C)
|
||||
|
||||
definition comma_object_sigma_char : (Σ(a : A) (b : B), S a ⟶ T b) ≃ comma_object S T :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro u, exact comma_object.mk u.1 u.2.1 u.2.2},
|
||||
{ intro x, cases x with a b f, exact ⟨a, b, f⟩},
|
||||
{ intro x, cases x, reflexivity},
|
||||
{ intro u, cases u with u1 u2, cases u2, reflexivity},
|
||||
end
|
||||
|
||||
theorem is_trunc_comma_object (n : trunc_index) [HA : is_trunc n A]
|
||||
[HB : is_trunc n B] [H : Π(s d : C), is_trunc n (hom s d)] : is_trunc n (comma_object S T) :=
|
||||
by apply is_trunc_equiv_closed;apply comma_object_sigma_char
|
||||
|
||||
variables {S T}
|
||||
definition comma_object_eq' {x y : comma_object S T} (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
|
||||
(r : mor x =[ap011 (@hom C C) (ap (to_fun_ob S) p) (ap (to_fun_ob T) q)] mor y) : x = y :=
|
||||
begin
|
||||
cases x with a b f, cases y with a' b' f', cases p, cases q,
|
||||
esimp [ap011,congr,ap,subst] at r,
|
||||
eapply (idp_rec_on r), reflexivity
|
||||
end
|
||||
|
||||
--TODO: remove. This is a different version where Hq is not in square brackets
|
||||
-- definition eq_comp_inverse_of_comp_eq' {ob : Type} {C : precategory ob} {d c b : ob} {r : hom c d}
|
||||
-- {q : hom b c} {x : hom b d} {Hq : is_iso q} (p : r ∘ q = x) : r = x ∘ q⁻¹ʰ :=
|
||||
-- sorry
|
||||
-- := sorry --eq_inverse_comp_of_comp_eq p
|
||||
|
||||
definition comma_object_eq {x y : comma_object S T} (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
|
||||
(r : T (hom_of_eq q) ∘ mor x ∘ S (inv_of_eq p) = mor y) : x = y :=
|
||||
begin
|
||||
cases x with a b f, cases y with a' b' f', cases p, cases q,
|
||||
apply ap (comma_object.mk a' b'),
|
||||
rewrite [▸* at r, -r, +respect_id, id_leftright]
|
||||
end
|
||||
|
||||
definition ap_ob1_comma_object_eq' (x y : comma_object S T) (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
|
||||
(r : mor x =[ap011 (@hom C C) (ap (to_fun_ob S) p) (ap (to_fun_ob T) q)] mor y)
|
||||
: ap ob1 (comma_object_eq' p q r) = p :=
|
||||
begin
|
||||
cases x with a b f, cases y with a' b' f', cases p, cases q,
|
||||
eapply (idp_rec_on r), reflexivity
|
||||
end
|
||||
|
||||
definition ap_ob2_comma_object_eq' (x y : comma_object S T) (p : ob1 x = ob1 y) (q : ob2 x = ob2 y)
|
||||
(r : mor x =[ap011 (@hom C C) (ap (to_fun_ob S) p) (ap (to_fun_ob T) q)] mor y)
|
||||
: ap ob2 (comma_object_eq' p q r) = q :=
|
||||
begin
|
||||
cases x with a b f, cases y with a' b' f', cases p, cases q,
|
||||
eapply (idp_rec_on r), reflexivity
|
||||
end
|
||||
|
||||
structure comma_morphism (x y : comma_object S T) :=
|
||||
mk' ::
|
||||
(g : ob1 x ⟶ ob1 y)
|
||||
(h : ob2 x ⟶ ob2 y)
|
||||
(p : T h ∘ mor x = mor y ∘ S g)
|
||||
(p' : mor y ∘ S g = T h ∘ mor x)
|
||||
abbreviation mor1 := @comma_morphism.g
|
||||
abbreviation mor2 := @comma_morphism.h
|
||||
abbreviation coh := @comma_morphism.p
|
||||
abbreviation coh' := @comma_morphism.p'
|
||||
|
||||
protected definition comma_morphism.mk [constructor] [reducible]
|
||||
{x y : comma_object S T} (g h p) : comma_morphism x y :=
|
||||
comma_morphism.mk' g h p p⁻¹
|
||||
|
||||
variables (x y z w : comma_object S T)
|
||||
definition comma_morphism_sigma_char :
|
||||
(Σ(g : ob1 x ⟶ ob1 y) (h : ob2 x ⟶ ob2 y), T h ∘ mor x = mor y ∘ S g) ≃ comma_morphism x y :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro u, exact (comma_morphism.mk u.1 u.2.1 u.2.2)},
|
||||
{ intro f, cases f with g h p p', exact ⟨g, h, p⟩},
|
||||
{ intro f, cases f with g h p p', esimp,
|
||||
apply ap (comma_morphism.mk' g h p), apply is_prop.elim},
|
||||
{ intro u, cases u with u1 u2, cases u2 with u2 u3, reflexivity},
|
||||
end
|
||||
|
||||
theorem is_trunc_comma_morphism (n : trunc_index) [H1 : is_trunc n (ob1 x ⟶ ob1 y)]
|
||||
[H2 : is_trunc n (ob2 x ⟶ ob2 y)] [Hp : Πm1 m2, is_trunc n (T m2 ∘ mor x = mor y ∘ S m1)]
|
||||
: is_trunc n (comma_morphism x y) :=
|
||||
by apply is_trunc_equiv_closed; apply comma_morphism_sigma_char
|
||||
|
||||
variables {x y z w}
|
||||
definition comma_morphism_eq {f f' : comma_morphism x y}
|
||||
(p : mor1 f = mor1 f') (q : mor2 f = mor2 f') : f = f' :=
|
||||
begin
|
||||
cases f with g h p₁ p₁', cases f' with g' h' p₂ p₂', cases p, cases q,
|
||||
apply ap011 (comma_morphism.mk' g' h'),
|
||||
apply is_prop.elim,
|
||||
apply is_prop.elim
|
||||
end
|
||||
|
||||
definition comma_compose (g : comma_morphism y z) (f : comma_morphism x y) : comma_morphism x z :=
|
||||
comma_morphism.mk
|
||||
(mor1 g ∘ mor1 f)
|
||||
(mor2 g ∘ mor2 f)
|
||||
(by rewrite [+respect_comp,-assoc,coh,assoc,coh,-assoc])
|
||||
|
||||
local infix ` ∘∘ `:60 := comma_compose
|
||||
|
||||
definition comma_id : comma_morphism x x :=
|
||||
comma_morphism.mk id id (by rewrite [+respect_id,id_left,id_right])
|
||||
|
||||
theorem comma_assoc (h : comma_morphism z w) (g : comma_morphism y z) (f : comma_morphism x y) :
|
||||
h ∘∘ (g ∘∘ f) = (h ∘∘ g) ∘∘ f :=
|
||||
comma_morphism_eq !assoc !assoc
|
||||
|
||||
theorem comma_id_left (f : comma_morphism x y) : comma_id ∘∘ f = f :=
|
||||
comma_morphism_eq !id_left !id_left
|
||||
|
||||
theorem comma_id_right (f : comma_morphism x y) : f ∘∘ comma_id = f :=
|
||||
comma_morphism_eq !id_right !id_right
|
||||
|
||||
variables (S T)
|
||||
definition comma_category [constructor] : Precategory :=
|
||||
precategory.MK (comma_object S T)
|
||||
comma_morphism
|
||||
(λa b, !is_trunc_comma_morphism)
|
||||
(@comma_compose _ _ _ _ _)
|
||||
(@comma_id _ _ _ _ _)
|
||||
(@comma_assoc _ _ _ _ _)
|
||||
(@comma_id_left _ _ _ _ _)
|
||||
(@comma_id_right _ _ _ _ _)
|
||||
|
||||
--TODO: this definition doesn't use category structure of A and B
|
||||
definition strict_precategory_comma [HA : strict_precategory A] [HB : strict_precategory B] :
|
||||
strict_precategory (comma_object S T) :=
|
||||
strict_precategory.mk (comma_category S T) !is_trunc_comma_object
|
||||
|
||||
/-
|
||||
--set_option pp.notation false
|
||||
definition is_univalent_comma (HA : is_univalent A) (HB : is_univalent B)
|
||||
: is_univalent (comma_category S T) :=
|
||||
begin
|
||||
intros c d,
|
||||
fapply adjointify,
|
||||
{ intro i, cases i with f s, cases s with g l r, cases f with fA fB fp, cases g with gA gB gp,
|
||||
esimp at *, fapply comma_object_eq,
|
||||
{apply iso_of_eq⁻¹ᶠ, exact (iso.MK fA gA (ap mor1 l) (ap mor1 r))},
|
||||
{apply iso_of_eq⁻¹ᶠ, exact (iso.MK fB gB (ap mor2 l) (ap mor2 r))},
|
||||
{ apply sorry /-rewrite hom_of_eq_eq_of_iso,-/ }},
|
||||
{ apply sorry},
|
||||
{ apply sorry},
|
||||
end
|
||||
-/
|
||||
|
||||
end category
|
||||
|
|
@ -1,181 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Cones of a diagram in a category
|
||||
-/
|
||||
|
||||
import ..nat_trans ..category
|
||||
|
||||
open functor nat_trans eq equiv is_trunc is_equiv iso sigma sigma.ops pi
|
||||
|
||||
namespace category
|
||||
|
||||
structure cone_obj {I C : Precategory} (F : I ⇒ C) :=
|
||||
(c : C)
|
||||
(η : constant_functor I c ⟹ F)
|
||||
|
||||
variables {I C D : Precategory} {F : I ⇒ C} {x y z : cone_obj F} {i : I}
|
||||
|
||||
definition cone_to_obj [unfold 4] := @cone_obj.c
|
||||
definition cone_to_nat [unfold 4] (c : cone_obj F) : constant_functor I (cone_to_obj c) ⟹ F :=
|
||||
cone_obj.η c
|
||||
|
||||
local attribute cone_to_obj [coercion]
|
||||
|
||||
structure cone_hom (x y : cone_obj F) :=
|
||||
(f : x ⟶ y)
|
||||
(p : Πi, cone_to_nat y i ∘ f = cone_to_nat x i)
|
||||
|
||||
definition cone_to_hom [unfold 6] := @cone_hom.f
|
||||
definition cone_to_eq [unfold 6] (f : cone_hom x y) (i : I)
|
||||
: cone_to_nat y i ∘ (cone_to_hom f) = cone_to_nat x i :=
|
||||
cone_hom.p f i
|
||||
|
||||
local attribute cone_to_hom [coercion]
|
||||
|
||||
definition cone_id [constructor] (x : cone_obj F) : cone_hom x x :=
|
||||
cone_hom.mk id
|
||||
(λi, !id_right)
|
||||
|
||||
definition cone_comp [constructor] (g : cone_hom y z) (f : cone_hom x y) : cone_hom x z :=
|
||||
cone_hom.mk (cone_to_hom g ∘ cone_to_hom f)
|
||||
abstract λi, by rewrite [assoc, +cone_to_eq] end
|
||||
|
||||
definition cone_obj_eq (p : cone_to_obj x = cone_to_obj y)
|
||||
(q : Πi, cone_to_nat x i = cone_to_nat y i ∘ hom_of_eq p) : x = y :=
|
||||
begin
|
||||
induction x, induction y, esimp at *, induction p, apply ap (cone_obj.mk c),
|
||||
apply nat_trans_eq, intro i, exact q i ⬝ !id_right
|
||||
end
|
||||
|
||||
theorem c_cone_obj_eq (p : cone_to_obj x = cone_to_obj y)
|
||||
(q : Πi, cone_to_nat x i = cone_to_nat y i ∘ hom_of_eq p) : ap cone_to_obj (cone_obj_eq p q) = p :=
|
||||
begin
|
||||
induction x, induction y, esimp at *, induction p,
|
||||
esimp [cone_obj_eq], rewrite [-ap_compose,↑function.compose,ap_constant]
|
||||
end
|
||||
|
||||
theorem cone_hom_eq {f f' : cone_hom x y} (q : cone_to_hom f = cone_to_hom f') : f = f' :=
|
||||
begin
|
||||
induction f, induction f', esimp at *, induction q, apply ap (cone_hom.mk f),
|
||||
apply @is_prop.elim, apply pi.is_trunc_pi, intro x, apply is_trunc_eq, -- type class fails
|
||||
end
|
||||
|
||||
variable (F)
|
||||
|
||||
definition precategory_cone [instance] [constructor] : precategory (cone_obj F) :=
|
||||
@precategory.mk _ cone_hom
|
||||
abstract begin
|
||||
intro x y,
|
||||
have H : cone_hom x y ≃ Σ(f : x ⟶ y), Πi, cone_to_nat y i ∘ f = cone_to_nat x i,
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, induction f, constructor, assumption},
|
||||
{ intro v, induction v, constructor, assumption},
|
||||
{ intro v, induction v, reflexivity},
|
||||
{ intro f, induction f, reflexivity}
|
||||
end,
|
||||
apply is_trunc.is_trunc_equiv_closed_rev, exact H,
|
||||
fapply sigma.is_trunc_sigma, intros,
|
||||
apply is_trunc_succ, apply pi.is_trunc_pi, intros, esimp,
|
||||
/-exact _,-/ -- type class inference fails here
|
||||
apply is_trunc_eq,
|
||||
end end
|
||||
(λx y z, cone_comp)
|
||||
cone_id
|
||||
abstract begin intros, apply cone_hom_eq, esimp, apply assoc end end
|
||||
abstract begin intros, apply cone_hom_eq, esimp, apply id_left end end
|
||||
abstract begin intros, apply cone_hom_eq, esimp, apply id_right end end
|
||||
|
||||
definition cone [constructor] : Precategory :=
|
||||
precategory.Mk (precategory_cone F)
|
||||
|
||||
variable {F}
|
||||
definition cone_iso_pr1 [constructor] (h : x ≅ y) : cone_to_obj x ≅ cone_to_obj y :=
|
||||
iso.MK
|
||||
(cone_to_hom (to_hom h))
|
||||
(cone_to_hom (to_inv h))
|
||||
(ap cone_to_hom (to_left_inverse h))
|
||||
(ap cone_to_hom (to_right_inverse h))
|
||||
|
||||
|
||||
definition cone_iso.mk [constructor] (f : cone_to_obj x ≅ cone_to_obj y)
|
||||
(p : Πi, cone_to_nat y i ∘ to_hom f = cone_to_nat x i) : x ≅ y :=
|
||||
begin
|
||||
fapply iso.MK,
|
||||
{ exact !cone_hom.mk p},
|
||||
{ fapply cone_hom.mk,
|
||||
{ exact to_inv f},
|
||||
{ intro i, apply comp_inverse_eq_of_eq_comp, exact (p i)⁻¹}},
|
||||
{ apply cone_hom_eq, esimp, apply left_inverse},
|
||||
{ apply cone_hom_eq, esimp, apply right_inverse},
|
||||
end
|
||||
|
||||
variables (x y)
|
||||
definition cone_iso_equiv [constructor] : (x ≅ y) ≃ Σ(f : cone_to_obj x ≅ cone_to_obj y),
|
||||
Πi, cone_to_nat y i ∘ to_hom f = cone_to_nat x i :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro h, exact ⟨cone_iso_pr1 h, cone_to_eq (to_hom h)⟩},
|
||||
{ intro v, exact cone_iso.mk v.1 v.2},
|
||||
{ intro v, induction v with f p, fapply sigma_eq: esimp,
|
||||
{ apply iso_eq, reflexivity},
|
||||
{ apply is_prop.elimo, apply is_trunc_pi, intro i, apply is_prop_hom_eq}},
|
||||
{ intro h, esimp, apply iso_eq, apply cone_hom_eq, reflexivity},
|
||||
end
|
||||
|
||||
definition cone_eq_equiv : (x = y) ≃ Σ(f : cone_to_obj x = cone_to_obj y),
|
||||
Πi, cone_to_nat y i ∘ hom_of_eq f = cone_to_nat x i :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro r, fapply sigma.mk, exact ap cone_to_obj r, induction r, intro i, apply id_right},
|
||||
{ intro v, induction v with p q, induction x with c η, induction y with c' η', esimp at *,
|
||||
apply cone_obj_eq p, esimp, intro i, exact (q i)⁻¹},
|
||||
{ intro v, induction v with p q, induction x with c η, induction y with c' η', esimp at *,
|
||||
induction p, esimp, fapply sigma_eq: esimp,
|
||||
{ apply c_cone_obj_eq},
|
||||
{ apply is_prop.elimo, apply is_trunc_pi, intro i, apply is_prop_hom_eq}},
|
||||
{ intro r, induction r, esimp, induction x, esimp, apply ap02, apply is_prop.elim},
|
||||
end
|
||||
|
||||
section is_univalent
|
||||
|
||||
definition is_univalent_cone {I : Precategory} {C : Category} (F : I ⇒ C)
|
||||
: is_univalent (cone F) :=
|
||||
begin
|
||||
intro x y,
|
||||
fapply is_equiv_of_equiv_of_homotopy,
|
||||
{ exact calc
|
||||
(x = y) ≃ (Σ(f : cone_to_obj x = cone_to_obj y), Πi, cone_to_nat y i ∘ hom_of_eq f = cone_to_nat x i)
|
||||
: cone_eq_equiv
|
||||
... ≃ (Σ(f : cone_to_obj x ≅ cone_to_obj y), Πi, cone_to_nat y i ∘ to_hom f = cone_to_nat x i)
|
||||
: sigma_equiv_sigma !eq_equiv_iso (λa, !equiv.refl)
|
||||
... ≃ (x ≅ y) : cone_iso_equiv },
|
||||
{ intro p, induction p, esimp [equiv.trans,equiv.symm], esimp [sigma_functor],
|
||||
apply iso_eq, reflexivity}
|
||||
end
|
||||
|
||||
definition category_cone [instance] [constructor] {I : Precategory} {C : Category} (F : I ⇒ C)
|
||||
: category (cone_obj F) :=
|
||||
category.mk _ (is_univalent_cone F)
|
||||
|
||||
definition Category_cone [constructor] {I : Precategory} {C : Category} (F : I ⇒ C)
|
||||
: Category :=
|
||||
Category.mk _ (category_cone F)
|
||||
|
||||
end is_univalent
|
||||
|
||||
definition cone_obj_compose [constructor] (G : C ⇒ D) (x : cone_obj F) : cone_obj (G ∘f F) :=
|
||||
begin
|
||||
fapply cone_obj.mk,
|
||||
{ exact G x},
|
||||
{ fapply change_natural_map,
|
||||
{ refine ((G ∘fn cone_to_nat x) ∘n _), apply nat_trans_of_eq, fapply functor_eq: esimp,
|
||||
intro i j k, esimp, rewrite [id_leftright,respect_id]},
|
||||
{ intro i, esimp, exact G (cone_to_nat x i)},
|
||||
{ intro i, esimp, rewrite [ap010_functor_eq, ▸*, id_right]}}
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
algebra.category.constructions
|
||||
==============================
|
||||
|
||||
Common categories and constructions on categories. The following files are in this folder.
|
||||
|
||||
* [functor](functor.hlean) : Functor category
|
||||
* [opposite](opposite.hlean) : Opposite category
|
||||
* [set](set.hlean) : Category of sets
|
||||
* [sum](sum.hlean) : Sum category
|
||||
* [product](product.hlean) : Product category
|
||||
* [comma](comma.hlean) : Comma category
|
||||
* [cone](cone.hlean) : Cone category
|
||||
* [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
|
||||
* [rezk](rezk.hlean) : Rezk completion
|
||||
|
||||
Discrete, indiscrete or finite categories:
|
||||
|
||||
* [finite_cats](finite_cats.hlean) : Some finite categories, which are diagrams of common limits (the diagram for the pullback or the equalizer). Also contains a general construction of categories where you give some generators for the morphisms, with the condition that you cannot compose two of thosex
|
||||
* [discrete](discrete.hlean) : Discrete category. Also the groupoid formed by a 1-type
|
||||
* [indiscrete](indiscrete.hlean)
|
||||
* [terminal](terminal.hlean)
|
||||
* [initial](initial.hlean)
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import .functor .set .opposite .product .comma .sum .discrete .indiscrete .terminal .initial .order
|
||||
.pushout .fundamental_groupoid
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Discrete category
|
||||
-/
|
||||
|
||||
import ..groupoid types.bool ..nat_trans
|
||||
|
||||
open eq is_trunc iso bool functor nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
definition precategory_of_1_type [constructor] (A : Type) [H : is_trunc 1 A] : precategory A :=
|
||||
@precategory.mk _ _ (@is_trunc_eq _ _ H)
|
||||
(λ (a b c : A) (p : b = c) (q : a = b), q ⬝ p)
|
||||
(λ (a : A), refl a)
|
||||
(λ (a b c d : A) (p : c = d) (q : b = c) (r : a = b), con.assoc r q p)
|
||||
(λ (a b : A) (p : a = b), con_idp p)
|
||||
(λ (a b : A) (p : a = b), idp_con p)
|
||||
|
||||
definition groupoid_of_1_type [constructor] (A : Type) [H : is_trunc 1 A] : groupoid A :=
|
||||
groupoid.mk !precategory_of_1_type
|
||||
(λ (a b : A) (p : a = b), is_iso.mk _ !con.right_inv !con.left_inv)
|
||||
|
||||
definition Precategory_of_1_type [constructor] (A : Type) [H : is_trunc 1 A] : Precategory :=
|
||||
precategory.Mk (precategory_of_1_type A)
|
||||
|
||||
definition Groupoid_of_1_type [constructor] (A : Type) [H : is_trunc 1 A] : Groupoid :=
|
||||
groupoid.Mk _ (groupoid_of_1_type A)
|
||||
|
||||
definition discrete_precategory [constructor] (A : Type) [H : is_set A] : precategory A :=
|
||||
precategory_of_1_type A
|
||||
|
||||
definition discrete_groupoid [constructor] (A : Type) [H : is_set A] : groupoid A :=
|
||||
groupoid_of_1_type A
|
||||
|
||||
definition Discrete_precategory [constructor] (A : Type) [H : is_set A] : Precategory :=
|
||||
precategory.Mk (discrete_precategory A)
|
||||
|
||||
definition Discrete_groupoid [constructor] (A : Type) [H : is_set A] : Groupoid :=
|
||||
groupoid.Mk _ (discrete_groupoid A)
|
||||
|
||||
definition c2 [constructor] : Precategory := Discrete_precategory bool
|
||||
|
||||
definition c2_functor [constructor] (C : Precategory) (x y : C) : c2 ⇒ C :=
|
||||
functor.mk (bool.rec x y)
|
||||
(bool.rec (bool.rec (λf, id) (by contradiction))
|
||||
(bool.rec (by contradiction) (λf, id)))
|
||||
abstract (bool.rec idp idp) end
|
||||
abstract begin intro b₁ b₂ b₃ g f, induction b₁: induction b₂: induction b₃:
|
||||
esimp at *: try contradiction: exact !id_id⁻¹ end end
|
||||
|
||||
definition c2_functor_eta {C : Precategory} (F : c2 ⇒ C) :
|
||||
c2_functor C (to_fun_ob F ff) (to_fun_ob F tt) = F :=
|
||||
begin
|
||||
fapply functor_eq: esimp,
|
||||
{ intro b, induction b: reflexivity},
|
||||
{ intro b₁ b₂ p, induction p, induction b₁: esimp; rewrite [id_leftright]; exact !respect_id⁻¹}
|
||||
end
|
||||
|
||||
definition c2_nat_trans [constructor] {C : Precategory} {x y u v : C} (f : x ⟶ u) (g : y ⟶ v) :
|
||||
c2_functor C x y ⟹ c2_functor C u v :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro b, induction b, exact f, exact g},
|
||||
{ intro b₁ b₂ p, induction p, induction b₁: esimp: apply id_comp_eq_comp_id},
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,142 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Some finite categories which are neither discrete nor indiscrete
|
||||
-/
|
||||
|
||||
import ..functor.basic types.sum
|
||||
|
||||
open bool unit is_trunc sum eq functor equiv
|
||||
|
||||
namespace category
|
||||
|
||||
variables {A : Type} (R : A → A → Type) (H : Π⦃a b c⦄, R a b → R b c → empty)
|
||||
[HR : Πa b, is_set (R a b)] [HA : is_trunc 1 A]
|
||||
|
||||
include H HR HA
|
||||
|
||||
-- we call a category sparse if you cannot compose two morphism, except the ones which come from equality
|
||||
definition sparse_category' [constructor] : precategory A :=
|
||||
precategory.mk
|
||||
(λa b, R a b ⊎ a = b)
|
||||
begin
|
||||
intros a b c g f, induction g with rg pg: induction f with rf pf,
|
||||
{ exfalso, exact H rf rg},
|
||||
{ exact inl (pf⁻¹ ▸ rg)},
|
||||
{ exact inl (pg ▸ rf)},
|
||||
{ exact inr (pf ⬝ pg)},
|
||||
end
|
||||
(λa, inr idp)
|
||||
abstract begin
|
||||
intros a b c d h g f, induction h with rh ph: induction g with rg pg: induction f with rf pf:
|
||||
esimp: try induction pf; try induction pg; try induction ph: esimp;
|
||||
try (exfalso; apply H;assumption;assumption)
|
||||
end end
|
||||
abstract by intros a b f; induction f with rf pf: reflexivity end
|
||||
abstract by intros a b f; (induction f with rf pf: esimp); rewrite idp_con end
|
||||
|
||||
definition sparse_category [constructor] : Precategory :=
|
||||
precategory.Mk (sparse_category' R @H)
|
||||
|
||||
definition sparse_category_functor [constructor] (C : Precategory) (f : A → C)
|
||||
(g : Π{a b} (r : R a b), f a ⟶ f b) : sparse_category R H ⇒ C :=
|
||||
functor.mk f
|
||||
(λa b, sum.rec g (eq.rec id))
|
||||
(λa, idp)
|
||||
abstract begin
|
||||
intro a b c g f, induction g with rg pg: induction f with rf pf: esimp:
|
||||
try induction pg: try induction pf: esimp,
|
||||
exfalso, exact H rf rg,
|
||||
exact !id_right⁻¹,
|
||||
exact !id_left⁻¹,
|
||||
exact !id_id⁻¹
|
||||
end end
|
||||
|
||||
omit H HR HA
|
||||
|
||||
section equalizer
|
||||
inductive equalizer_category_hom : bool → bool → Type :=
|
||||
| f1 : equalizer_category_hom ff tt
|
||||
| f2 : equalizer_category_hom ff tt
|
||||
|
||||
open equalizer_category_hom
|
||||
theorem is_set_equalizer_category_hom (b₁ b₂ : bool) : is_set (equalizer_category_hom b₁ b₂) :=
|
||||
begin
|
||||
have H : Πb b', equalizer_category_hom b b' ≃ bool.rec (bool.rec empty bool) (λb, empty) b b',
|
||||
begin
|
||||
intro b b', fapply equiv.MK,
|
||||
{ intro x, induction x, exact ff, exact tt},
|
||||
{ intro v, induction b: induction b': induction v, exact f1, exact f2},
|
||||
{ intro v, induction b: induction b': induction v: reflexivity},
|
||||
{ intro x, induction x: reflexivity}
|
||||
end,
|
||||
apply is_trunc_equiv_closed_rev, apply H,
|
||||
induction b₁: induction b₂: exact _
|
||||
end
|
||||
|
||||
local attribute is_set_equalizer_category_hom [instance]
|
||||
definition equalizer_category [constructor] : Precategory :=
|
||||
sparse_category
|
||||
equalizer_category_hom
|
||||
begin intro a b c g f; cases g: cases f end
|
||||
|
||||
definition equalizer_category_functor [constructor] (C : Precategory) {x y : C} (f g : x ⟶ y)
|
||||
: equalizer_category ⇒ C :=
|
||||
sparse_category_functor _ _ C
|
||||
(bool.rec x y)
|
||||
begin intro a b h; induction h, exact f, exact g end
|
||||
end equalizer
|
||||
|
||||
section pullback
|
||||
inductive pullback_category_ob : Type :=
|
||||
| TR : pullback_category_ob
|
||||
| BL : pullback_category_ob
|
||||
| BR : pullback_category_ob
|
||||
|
||||
theorem pullback_category_ob_decidable_equality : decidable_eq pullback_category_ob :=
|
||||
begin
|
||||
intro x y; induction x: induction y:
|
||||
try exact decidable.inl idp:
|
||||
apply decidable.inr; contradiction
|
||||
end
|
||||
|
||||
open pullback_category_ob
|
||||
inductive pullback_category_hom : pullback_category_ob → pullback_category_ob → Type :=
|
||||
| f1 : pullback_category_hom TR BR
|
||||
| f2 : pullback_category_hom BL BR
|
||||
|
||||
open pullback_category_hom
|
||||
theorem is_set_pullback_category_hom (b₁ b₂ : pullback_category_ob)
|
||||
: is_set (pullback_category_hom b₁ b₂) :=
|
||||
begin
|
||||
have H : Πb b', pullback_category_hom b b' ≃
|
||||
pullback_category_ob.rec (λb, empty) (λb, empty)
|
||||
(pullback_category_ob.rec unit unit empty) b' b,
|
||||
begin
|
||||
intro b b', fapply equiv.MK,
|
||||
{ intro x, induction x: exact star},
|
||||
{ intro v, induction b: induction b': induction v, exact f1, exact f2},
|
||||
{ intro v, induction b: induction b': induction v: reflexivity},
|
||||
{ intro x, induction x: reflexivity}
|
||||
end,
|
||||
apply is_trunc_equiv_closed_rev, apply H,
|
||||
induction b₁: induction b₂: exact _
|
||||
end
|
||||
|
||||
local attribute is_set_pullback_category_hom pullback_category_ob_decidable_equality [instance]
|
||||
definition pullback_category [constructor] : Precategory :=
|
||||
sparse_category
|
||||
pullback_category_hom
|
||||
begin intro a b c g f; cases g: cases f end
|
||||
|
||||
definition pullback_category_functor [constructor] (C : Precategory) {x y z : C}
|
||||
(f : x ⟶ z) (g : y ⟶ z) : pullback_category ⇒ C :=
|
||||
sparse_category_functor _ _ C
|
||||
(pullback_category_ob.rec x y z)
|
||||
begin intro a b h; induction h, exact f, exact g end
|
||||
end pullback
|
||||
|
||||
end category
|
||||
|
|
@ -1,812 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Functor precategory and category
|
||||
-/
|
||||
|
||||
import .opposite ..functor.attributes
|
||||
|
||||
open eq category is_trunc nat_trans iso is_equiv category.hom trunc
|
||||
|
||||
namespace functor
|
||||
|
||||
definition precategory_functor [instance] [constructor] (D C : Precategory)
|
||||
: precategory (functor C D) :=
|
||||
precategory.mk (λa b, nat_trans a b)
|
||||
(λ a b c g f, nat_trans.compose g f)
|
||||
(λ a, nat_trans.id)
|
||||
(λ a b c d h g f, !nat_trans.assoc)
|
||||
(λ a b f, !nat_trans.id_left)
|
||||
(λ a b f, !nat_trans.id_right)
|
||||
|
||||
definition Precategory_functor [reducible] [constructor] (D C : Precategory) : Precategory :=
|
||||
precategory.Mk (precategory_functor D C)
|
||||
|
||||
infixr ` ^c `:80 := Precategory_functor
|
||||
|
||||
section
|
||||
/- we prove that if a natural transformation is pointwise an iso, then it is an iso -/
|
||||
variables {C D : Precategory} {F G : C ⇒ D} (η : F ⟹ G) [iso : Π(a : C), is_iso (η a)]
|
||||
include iso
|
||||
|
||||
definition nat_trans_inverse [constructor] : G ⟹ F :=
|
||||
nat_trans.mk
|
||||
(λc, (η c)⁻¹)
|
||||
(λc d f,
|
||||
abstract begin
|
||||
apply comp_inverse_eq_of_eq_comp,
|
||||
transitivity (natural_map η d)⁻¹ ∘ to_fun_hom G f ∘ natural_map η c,
|
||||
{apply eq_inverse_comp_of_comp_eq, symmetry, apply naturality},
|
||||
{apply assoc}
|
||||
end end)
|
||||
|
||||
definition nat_trans_left_inverse : nat_trans_inverse η ∘n η = 1 :=
|
||||
begin
|
||||
fapply (apdt011 nat_trans.mk),
|
||||
apply eq_of_homotopy, intro c, apply left_inverse,
|
||||
apply eq_of_homotopy3, intros, apply is_set.elim
|
||||
end
|
||||
|
||||
definition nat_trans_right_inverse : η ∘n nat_trans_inverse η = 1 :=
|
||||
begin
|
||||
fapply (apdt011 nat_trans.mk),
|
||||
apply eq_of_homotopy, intro c, apply right_inverse,
|
||||
apply eq_of_homotopy3, intros, apply is_set.elim
|
||||
end
|
||||
|
||||
definition is_natural_iso [constructor] : is_iso η :=
|
||||
is_iso.mk _ (nat_trans_left_inverse η) (nat_trans_right_inverse η)
|
||||
|
||||
variable (iso)
|
||||
definition natural_iso.mk [constructor] : F ≅ G :=
|
||||
iso.mk _ (is_natural_iso η)
|
||||
|
||||
omit iso
|
||||
|
||||
variables (F G)
|
||||
definition is_natural_inverse (η : Πc, F c ≅ G c)
|
||||
(nat : Π⦃a b : C⦄ (f : hom a b), G f ∘ to_hom (η a) = to_hom (η b) ∘ F f)
|
||||
{a b : C} (f : hom a b) : F f ∘ to_inv (η a) = to_inv (η b) ∘ G f :=
|
||||
let η' : F ⟹ G := nat_trans.mk (λc, to_hom (η c)) @nat in
|
||||
naturality (nat_trans_inverse η') f
|
||||
|
||||
definition is_natural_inverse' (η₁ : Πc, F c ≅ G c) (η₂ : F ⟹ G) (p : η₁ ~ η₂)
|
||||
{a b : C} (f : hom a b) : F f ∘ to_inv (η₁ a) = to_inv (η₁ b) ∘ G f :=
|
||||
is_natural_inverse F G η₁ abstract λa b g, (p a)⁻¹ ▸ (p b)⁻¹ ▸ naturality η₂ g end f
|
||||
|
||||
variables {F G}
|
||||
definition natural_iso.MK [constructor]
|
||||
(η : Πc, F c ⟶ G c) (p : Π(c c' : C) (f : c ⟶ c'), G f ∘ η c = η c' ∘ F f)
|
||||
(θ : Πc, G c ⟶ F c) (r : Πc, θ c ∘ η c = id) (q : Πc, η c ∘ θ c = id) : F ≅ G :=
|
||||
iso.mk (nat_trans.mk η p) (@(is_natural_iso _) (λc, is_iso.mk (θ c) (r c) (q c)))
|
||||
|
||||
definition natural_iso.mk' [constructor]
|
||||
(η : Πc, F c ≅ G c) (p : Π(c c' : C) (f : c ⟶ c'), G f ∘ to_hom (η c) = to_hom (η c') ∘ F f) :
|
||||
F ≅ G :=
|
||||
natural_iso.MK (λc, to_hom (η c)) p (λc, to_inv (η c))
|
||||
(λc, to_left_inverse (η c)) (λc, to_right_inverse (η c))
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
/- and conversely, if a natural transformation is an iso, it is componentwise an iso -/
|
||||
variables {A B C D : Precategory} {F G : C ⇒ D} (η : hom F G) [isoη : is_iso η] (c : C)
|
||||
include isoη
|
||||
definition componentwise_is_iso [constructor] : is_iso (η c) :=
|
||||
@is_iso.mk _ _ _ _ _ (natural_map η⁻¹ c) (ap010 natural_map ( left_inverse η) c)
|
||||
(ap010 natural_map (right_inverse η) c)
|
||||
|
||||
local attribute componentwise_is_iso [instance]
|
||||
|
||||
variable {isoη}
|
||||
definition natural_map_inverse : natural_map η⁻¹ c = (η c)⁻¹ := idp
|
||||
variable [isoη]
|
||||
|
||||
definition naturality_iso {c c' : C} (f : c ⟶ c') : G f = η c' ∘ F f ∘ (η c)⁻¹ :=
|
||||
calc
|
||||
G f = (G f ∘ η c) ∘ (η c)⁻¹ : by rewrite comp_inverse_cancel_right
|
||||
... = (η c' ∘ F f) ∘ (η c)⁻¹ : by rewrite naturality
|
||||
... = η c' ∘ F f ∘ (η c)⁻¹ : by rewrite assoc
|
||||
|
||||
definition naturality_iso' {c c' : C} (f : c ⟶ c') : (η c')⁻¹ ∘ G f ∘ η c = F f :=
|
||||
calc
|
||||
(η c')⁻¹ ∘ G f ∘ η c = (η c')⁻¹ ∘ η c' ∘ F f : by rewrite naturality
|
||||
... = F f : by rewrite inverse_comp_cancel_left
|
||||
|
||||
omit isoη
|
||||
|
||||
definition componentwise_iso [constructor] (η : F ≅ G) (c : C) : F c ≅ G c :=
|
||||
iso.mk (natural_map (to_hom η) c)
|
||||
(@componentwise_is_iso _ _ _ _ (to_hom η) (struct η) c)
|
||||
|
||||
definition componentwise_iso_id (c : C) : componentwise_iso (iso.refl F) c = iso.refl (F c) :=
|
||||
iso_eq (idpath (ID (F c)))
|
||||
|
||||
definition componentwise_iso_iso_of_eq (p : F = G) (c : C)
|
||||
: componentwise_iso (iso_of_eq p) c = iso_of_eq (ap010 to_fun_ob p c) :=
|
||||
eq.rec_on p !componentwise_iso_id
|
||||
|
||||
theorem naturality_iso_id {F : C ⇒ C} (η : F ≅ 1) (c : C)
|
||||
: componentwise_iso η (F c) = F (componentwise_iso η c) :=
|
||||
comp.cancel_left (to_hom (componentwise_iso η c))
|
||||
((naturality (to_hom η)) (to_hom (componentwise_iso η c)))
|
||||
|
||||
definition natural_map_hom_of_eq (p : F = G) (c : C)
|
||||
: natural_map (hom_of_eq p) c = hom_of_eq (ap010 to_fun_ob p c) :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition natural_map_inv_of_eq (p : F = G) (c : C)
|
||||
: natural_map (inv_of_eq p) c = hom_of_eq (ap010 to_fun_ob p c)⁻¹ :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition hom_of_eq_compose_right {H : B ⇒ C} (p : F = G)
|
||||
: hom_of_eq (ap (λx, x ∘f H) p) = hom_of_eq p ∘nf H :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition inv_of_eq_compose_right {H : B ⇒ C} (p : F = G)
|
||||
: inv_of_eq (ap (λx, x ∘f H) p) = inv_of_eq p ∘nf H :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition hom_of_eq_compose_left {H : D ⇒ C} (p : F = G)
|
||||
: hom_of_eq (ap (λx, H ∘f x) p) = H ∘fn hom_of_eq p :=
|
||||
by induction p; exact !fn_id⁻¹
|
||||
|
||||
definition inv_of_eq_compose_left {H : D ⇒ C} (p : F = G)
|
||||
: inv_of_eq (ap (λx, H ∘f x) p) = H ∘fn inv_of_eq p :=
|
||||
by induction p; exact !fn_id⁻¹
|
||||
|
||||
definition assoc_natural [constructor] (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B)
|
||||
: H ∘f (G ∘f F) ⟹ (H ∘f G) ∘f F :=
|
||||
change_natural_map (hom_of_eq !functor.assoc)
|
||||
(λa, id)
|
||||
(λa, !natural_map_hom_of_eq ⬝ ap hom_of_eq !ap010_assoc)
|
||||
|
||||
definition assoc_natural_rev [constructor] (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B)
|
||||
: (H ∘f G) ∘f F ⟹ H ∘f (G ∘f F) :=
|
||||
change_natural_map (inv_of_eq !functor.assoc)
|
||||
(λa, id)
|
||||
(λa, !natural_map_inv_of_eq ⬝ ap (λx, hom_of_eq x⁻¹) !ap010_assoc)
|
||||
|
||||
definition assoc_iso [constructor] (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B)
|
||||
: H ∘f (G ∘f F) ≅ (H ∘f G) ∘f F :=
|
||||
iso.MK (assoc_natural H G F) (assoc_natural_rev H G F)
|
||||
(nat_trans_eq (λa, proof !id_id qed)) (nat_trans_eq (λa, proof !id_id qed))
|
||||
|
||||
definition id_left_natural [constructor] (F : C ⇒ D) : functor.id ∘f F ⟹ F :=
|
||||
change_natural_map
|
||||
(hom_of_eq !functor.id_left)
|
||||
(λc, id)
|
||||
(λc, by induction F; exact !natural_map_hom_of_eq ⬝ ap hom_of_eq !ap010_functor_mk_eq_constant)
|
||||
|
||||
|
||||
definition id_left_natural_rev [constructor] (F : C ⇒ D) : F ⟹ functor.id ∘f F :=
|
||||
change_natural_map
|
||||
(inv_of_eq !functor.id_left)
|
||||
(λc, id)
|
||||
(λc, by induction F; exact !natural_map_inv_of_eq ⬝
|
||||
ap (λx, hom_of_eq x⁻¹) !ap010_functor_mk_eq_constant)
|
||||
|
||||
definition id_right_natural [constructor] (F : C ⇒ D) : F ∘f functor.id ⟹ F :=
|
||||
change_natural_map
|
||||
(hom_of_eq !functor.id_right)
|
||||
(λc, id)
|
||||
(λc, by induction F; exact !natural_map_hom_of_eq ⬝ ap hom_of_eq !ap010_functor_mk_eq_constant)
|
||||
|
||||
definition id_right_natural_rev [constructor] (F : C ⇒ D) : F ⟹ F ∘f functor.id :=
|
||||
change_natural_map
|
||||
(inv_of_eq !functor.id_right)
|
||||
(λc, id)
|
||||
(λc, by induction F; exact !natural_map_inv_of_eq ⬝
|
||||
ap (λx, hom_of_eq x⁻¹) !ap010_functor_mk_eq_constant)
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
variables {C D E : Precategory} {G G' : D ⇒ E} {F F' : C ⇒ D} {J : D ⇒ D}
|
||||
|
||||
definition is_iso_nf_compose [constructor] (G : D ⇒ E) (η : F ⟹ F') [H : is_iso η]
|
||||
: is_iso (G ∘fn η) :=
|
||||
is_iso.mk
|
||||
(G ∘fn @inverse (C ⇒ D) _ _ _ η _)
|
||||
abstract !fn_n_distrib⁻¹ ⬝ ap (λx, G ∘fn x) (@left_inverse (C ⇒ D) _ _ _ η _) ⬝ !fn_id end
|
||||
abstract !fn_n_distrib⁻¹ ⬝ ap (λx, G ∘fn x) (@right_inverse (C ⇒ D) _ _ _ η _) ⬝ !fn_id end
|
||||
|
||||
definition is_iso_fn_compose [constructor] (η : G ⟹ G') (F : C ⇒ D) [H : is_iso η]
|
||||
: is_iso (η ∘nf F) :=
|
||||
is_iso.mk
|
||||
(@inverse (D ⇒ E) _ _ _ η _ ∘nf F)
|
||||
abstract !n_nf_distrib⁻¹ ⬝ ap (λx, x ∘nf F) (@left_inverse (D ⇒ E) _ _ _ η _) ⬝ !id_nf end
|
||||
abstract !n_nf_distrib⁻¹ ⬝ ap (λx, x ∘nf F) (@right_inverse (D ⇒ E) _ _ _ η _) ⬝ !id_nf end
|
||||
|
||||
definition functor_iso_compose [constructor] (G : D ⇒ E) (η : F ≅ F') : G ∘f F ≅ G ∘f F' :=
|
||||
iso.mk _ (is_iso_nf_compose G (to_hom η))
|
||||
|
||||
definition iso_functor_compose [constructor] (η : G ≅ G') (F : C ⇒ D) : G ∘f F ≅ G' ∘f F :=
|
||||
iso.mk _ (is_iso_fn_compose (to_hom η) F)
|
||||
|
||||
infixr ` ∘fi ` :62 := functor_iso_compose
|
||||
infixr ` ∘if ` :62 := iso_functor_compose
|
||||
|
||||
|
||||
/- TODO: also needs n_nf_distrib and id_nf for these compositions
|
||||
definition nidf_compose [constructor] (η : J ⟹ 1) (F : C ⇒ D) [H : is_iso η]
|
||||
: is_iso (η ∘n1f F) :=
|
||||
is_iso.mk
|
||||
(@inverse (D ⇒ D) _ _ _ η _ ∘1nf F)
|
||||
abstract _ end
|
||||
_
|
||||
|
||||
definition idnf_compose [constructor] (η : 1 ⟹ J) (F : C ⇒ D) [H : is_iso η]
|
||||
: is_iso (η ∘1nf F) :=
|
||||
is_iso.mk _
|
||||
_
|
||||
_
|
||||
|
||||
definition fnid_compose [constructor] (F : D ⇒ E) (η : J ⟹ 1) [H : is_iso η]
|
||||
: is_iso (F ∘fn1 η) :=
|
||||
is_iso.mk _
|
||||
_
|
||||
_
|
||||
|
||||
definition fidn_compose [constructor] (F : D ⇒ E) (η : 1 ⟹ J) [H : is_iso η]
|
||||
: is_iso (F ∘f1n η) :=
|
||||
is_iso.mk _
|
||||
_
|
||||
_
|
||||
-/
|
||||
|
||||
end
|
||||
|
||||
namespace functor
|
||||
|
||||
variables {C : Precategory} {D : Category} {F G : D ^c C}
|
||||
definition eq_of_iso_ob (η : F ≅ G) (c : C) : F c = G c :=
|
||||
by apply eq_of_iso; apply componentwise_iso; exact η
|
||||
|
||||
local attribute functor.to_fun_hom [reducible]
|
||||
definition eq_of_iso (η : F ≅ G) : F = G :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{exact (eq_of_iso_ob η)},
|
||||
{intro c c' f,
|
||||
esimp [eq_of_iso_ob, inv_of_eq, hom_of_eq, eq_of_iso],
|
||||
rewrite [*right_inv iso_of_eq],
|
||||
symmetry, apply @naturality_iso _ _ _ _ _ (iso.struct _)
|
||||
}
|
||||
end
|
||||
|
||||
definition iso_of_eq_eq_of_iso (η : F ≅ G) : iso_of_eq (eq_of_iso η) = η :=
|
||||
begin
|
||||
apply iso_eq,
|
||||
apply nat_trans_eq,
|
||||
intro c,
|
||||
rewrite natural_map_hom_of_eq, esimp [eq_of_iso],
|
||||
rewrite ap010_functor_eq, esimp [hom_of_eq,eq_of_iso_ob],
|
||||
rewrite (right_inv iso_of_eq),
|
||||
end
|
||||
|
||||
definition eq_of_iso_iso_of_eq (p : F = G) : eq_of_iso (iso_of_eq p) = p :=
|
||||
begin
|
||||
apply functor_eq2,
|
||||
intro c,
|
||||
esimp [eq_of_iso],
|
||||
rewrite ap010_functor_eq,
|
||||
esimp [eq_of_iso_ob],
|
||||
rewrite componentwise_iso_iso_of_eq,
|
||||
rewrite (left_inv iso_of_eq)
|
||||
end
|
||||
|
||||
definition is_univalent (D : Category) (C : Precategory) : is_univalent (D ^c C) :=
|
||||
λF G, adjointify _ eq_of_iso
|
||||
iso_of_eq_eq_of_iso
|
||||
eq_of_iso_iso_of_eq
|
||||
|
||||
end functor
|
||||
|
||||
definition category_functor [instance] [constructor] (D : Category) (C : Precategory)
|
||||
: category (D ^c C) :=
|
||||
category.mk (D ^c C) (functor.is_univalent D C)
|
||||
|
||||
definition Category_functor [constructor] (D : Category) (C : Precategory) : Category :=
|
||||
category.Mk (D ^c C) !category_functor
|
||||
|
||||
--this definition is only useful if the exponent is a category,
|
||||
-- and the elaborator has trouble with inserting the coercion
|
||||
definition Category_functor' [constructor] (D C : Category) : Category :=
|
||||
Category_functor D C
|
||||
|
||||
namespace ops
|
||||
infixr ` ^c2 `:35 := Category_functor
|
||||
end ops
|
||||
|
||||
namespace functor
|
||||
variables {C : Precategory} {D : Category} {F G : D ^c C}
|
||||
|
||||
definition eq_of_pointwise_iso (η : F ⟹ G) (iso : Π(a : C), is_iso (η a)) : F = G :=
|
||||
eq_of_iso (natural_iso.mk η iso)
|
||||
|
||||
definition iso_of_eq_eq_of_pointwise_iso (η : F ⟹ G) (iso : Π(c : C), is_iso (η c))
|
||||
: iso_of_eq (eq_of_pointwise_iso η iso) = natural_iso.mk η iso :=
|
||||
!iso_of_eq_eq_of_iso
|
||||
|
||||
definition hom_of_eq_eq_of_pointwise_iso (η : F ⟹ G) (iso : Π(c : C), is_iso (η c))
|
||||
: hom_of_eq (eq_of_pointwise_iso η iso) = η :=
|
||||
!hom_of_eq_eq_of_iso
|
||||
|
||||
definition inv_of_eq_eq_of_pointwise_iso (η : F ⟹ G) (iso : Π(c : C), is_iso (η c))
|
||||
: inv_of_eq (eq_of_pointwise_iso η iso) = nat_trans_inverse η :=
|
||||
!inv_of_eq_eq_of_iso
|
||||
|
||||
end functor
|
||||
|
||||
/-
|
||||
functors involving only the functor category
|
||||
(see ..functor.curry for some other functors involving also products)
|
||||
-/
|
||||
|
||||
variables {C D I : Precategory}
|
||||
definition constant2_functor [constructor] (F : I ⇒ D ^c C) (c : C) : I ⇒ D :=
|
||||
functor.mk (λi, to_fun_ob (F i) c)
|
||||
(λi j f, natural_map (F f) c)
|
||||
abstract (λi, ap010 natural_map !respect_id c ⬝ proof idp qed) end
|
||||
abstract (λi j k g f, ap010 natural_map !respect_comp c) end
|
||||
|
||||
definition constant2_functor_natural [constructor] (F : I ⇒ D ^c C) {c d : C} (f : c ⟶ d)
|
||||
: constant2_functor F c ⟹ constant2_functor F d :=
|
||||
nat_trans.mk (λi, to_fun_hom (F i) f)
|
||||
(λi j k, (naturality (F k) f)⁻¹)
|
||||
|
||||
definition functor_flip [constructor] (F : I ⇒ D ^c C) : C ⇒ D ^c I :=
|
||||
functor.mk (constant2_functor F)
|
||||
@(constant2_functor_natural F)
|
||||
abstract begin intros, apply nat_trans_eq, intro i, esimp, apply respect_id end end
|
||||
abstract begin intros, apply nat_trans_eq, intro i, esimp, apply respect_comp end end
|
||||
|
||||
definition eval_functor [constructor] (C D : Precategory) (d : D) : C ^c D ⇒ C :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro F, exact F d},
|
||||
{ intro G F η, exact η d},
|
||||
{ intro F, reflexivity},
|
||||
{ intro H G F η θ, reflexivity},
|
||||
end
|
||||
|
||||
definition precomposition_functor [constructor] {C D} (E) (F : C ⇒ D)
|
||||
: E ^c D ⇒ E ^c C :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro G, exact G ∘f F},
|
||||
{ intro G H η, exact η ∘nf F},
|
||||
{ intro G, reflexivity},
|
||||
{ intro G H I η θ, reflexivity},
|
||||
end
|
||||
|
||||
definition faithful_precomposition_functor [instance]
|
||||
{C D E} {H : C ⇒ D} [Hs : essentially_surjective H] : faithful (precomposition_functor E H) :=
|
||||
begin
|
||||
intro F G γ δ Hγδ, apply nat_trans_eq, intro b,
|
||||
induction Hs b with Hb, induction Hb with a f,
|
||||
refine naturality_iso_right γ f ⬝ _ ⬝ (naturality_iso_right δ f)⁻¹,
|
||||
apply ap (λ x, _ ∘ natural_map x a ∘ _) Hγδ,
|
||||
end
|
||||
|
||||
open sigma sigma.ops
|
||||
section fully_faithful_precomposition
|
||||
variables {E : Precategory} {H : C ⇒ D} [Hs : essentially_surjective H] [Hf : full H]
|
||||
{F G : D ⇒ E} (γ : F ∘f H ⟹ G ∘f H)
|
||||
include Hs Hf
|
||||
|
||||
private definition fully_faithful_precomposition_functor_prop [instance] (b) :
|
||||
is_prop (Σ g, Π a (f : H a ≅ b), γ a = G f⁻¹ⁱ ∘ g ∘ F f) :=
|
||||
begin
|
||||
fapply is_prop.mk, intros g h, cases g with g Hg, cases h with h Hh,
|
||||
fapply sigma.dpair_eq_dpair,
|
||||
{ induction Hs b with Hb, induction Hb with a0 f,
|
||||
apply comp.cancel_right (F f), apply comp.cancel_left (G f⁻¹ⁱ),
|
||||
apply (Hg a0 f)⁻¹ ⬝ (Hh a0 f) },
|
||||
apply is_prop.elimo
|
||||
end
|
||||
|
||||
private definition fully_faithful_precomposition_functor_pair [reducible] (b) :
|
||||
Σ g, Π a (f : H a ≅ b), γ a = G f⁻¹ⁱ ∘ g ∘ F f :=
|
||||
begin
|
||||
induction Hs b with Hb, induction Hb with a0 h, fconstructor,
|
||||
exact G h ∘ γ a0 ∘ F h⁻¹ⁱ, intro a f,
|
||||
induction Hf (to_hom (f ⬝i h⁻¹ⁱ)) with k Ek,
|
||||
have is_iso (H k), by rewrite Ek; apply _,
|
||||
refine _ ⬝ !assoc⁻¹, refine _ ⬝ ap (λ x, x ∘ F f) !assoc⁻¹, refine _ ⬝ !assoc,
|
||||
refine _ ⬝ ap (λ x, (G f⁻¹ⁱ ∘ G h) ∘ x) !assoc,
|
||||
do 2 krewrite [-respect_comp], esimp,
|
||||
apply eq_comp_of_inverse_comp_eq,
|
||||
exact ap (λ x, G x ∘ γ a) Ek⁻¹ ⬝ naturality γ k ⬝ ap (λ x, γ a0 ∘ F x) Ek
|
||||
end
|
||||
|
||||
--TODO speed this up
|
||||
private definition fully_faithful_precomposition_naturality {b b' : carrier D}
|
||||
(f : hom b b') : to_fun_hom G f ∘ (fully_faithful_precomposition_functor_pair γ b).1
|
||||
= (fully_faithful_precomposition_functor_pair γ b').1 ∘ to_fun_hom F f :=
|
||||
begin
|
||||
esimp[fully_faithful_precomposition_functor_pair],
|
||||
induction Hs b with Hb, induction Hb with a h,
|
||||
induction Hs b' with Hb', induction Hb' with a' h',
|
||||
induction Hf (to_hom h'⁻¹ⁱ ∘ f ∘ to_hom h) with k Ek,
|
||||
apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _),
|
||||
apply concat, apply !respect_comp⁻¹,
|
||||
apply concat, apply ap (λ x, to_fun_hom G x), apply inverse,
|
||||
apply comp_eq_of_eq_inverse_comp, apply Ek, apply respect_comp,
|
||||
apply concat, apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply naturality γ, apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ _ ∘ x), apply concat, esimp, apply !respect_comp⁻¹,
|
||||
apply concat, apply ap (λ x, to_fun_hom F x),
|
||||
apply comp_inverse_eq_of_eq_comp, apply Ek ⬝ !assoc, apply respect_comp,
|
||||
apply concat, apply assoc, apply concat, apply assoc,
|
||||
apply ap (λ x, x ∘ _) !assoc⁻¹
|
||||
end
|
||||
|
||||
definition fully_faithful_precomposition_functor [instance] :
|
||||
fully_faithful (precomposition_functor E H) :=
|
||||
begin
|
||||
apply fully_faithful_of_full_of_faithful,
|
||||
{ apply faithful_precomposition_functor },
|
||||
{ intro F G γ, esimp at *, fapply image.mk,
|
||||
fconstructor,
|
||||
{ intro b, apply (fully_faithful_precomposition_functor_pair γ b).1 },
|
||||
{ intro b b' f, apply fully_faithful_precomposition_naturality },
|
||||
{ fapply nat_trans_eq, intro a, esimp,
|
||||
apply inverse,
|
||||
induction (fully_faithful_precomposition_functor_pair γ (to_fun_ob H a)) with g Hg,
|
||||
esimp, apply concat, apply Hg a (iso.refl (H a)), esimp,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply respect_id, apply concat, apply id_left,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply respect_id, apply id_right } }
|
||||
end
|
||||
|
||||
end fully_faithful_precomposition
|
||||
|
||||
end functor
|
||||
|
||||
namespace functor
|
||||
|
||||
section essentially_surjective_precomposition
|
||||
|
||||
parameters {A B : Precategory} {C : Category}
|
||||
{H : A ⇒ B} [He : is_weak_equivalence H] (F : A ⇒ C)
|
||||
variables {b b' : carrier B} (f : hom b b')
|
||||
include A B C H He F
|
||||
|
||||
structure essentially_surj_precomp_X (b : carrier B) : Type :=
|
||||
(c : carrier C)
|
||||
(k : Π (a : carrier A) (h : H a ≅ b), F a ≅ c)
|
||||
(k_coh : Π {a a'} h h' (f : hom a a'), to_hom h' ∘ (to_fun_hom H f) = to_hom h
|
||||
→ to_hom (k a' h') ∘ to_fun_hom F f = to_hom (k a h))
|
||||
local abbreviation X := essentially_surj_precomp_X
|
||||
local abbreviation X.mk [constructor] := @essentially_surj_precomp_X.mk
|
||||
local abbreviation X.c [unfold 7] := @essentially_surj_precomp_X.c
|
||||
local abbreviation X.k [unfold 7] := @essentially_surj_precomp_X.k
|
||||
local abbreviation X.k_coh [unfold 7] := @essentially_surj_precomp_X.k_coh
|
||||
|
||||
section
|
||||
variables {c c' : carrier C} (p : c = c')
|
||||
{k : Π (a : carrier A) (h : H a ≅ b), F a ≅ c}
|
||||
{k' : Π (a : carrier A) (h : H a ≅ b), F a ≅ c'}
|
||||
(q : Π (a : carrier A) (h : H a ≅ b), to_hom (k a h ⬝i iso_of_eq p) = to_hom (k' a h))
|
||||
{k_coh : Π {a a'} h h' (f : hom a a'), to_hom h' ∘ (to_fun_hom H f) = to_hom h
|
||||
→ to_hom (k a' h') ∘ to_fun_hom F f = to_hom (k a h)}
|
||||
{k'_coh : Π {a a'} h h' (f : hom a a'), to_hom h' ∘ (to_fun_hom H f) = to_hom h
|
||||
→ to_hom (k' a' h') ∘ to_fun_hom F f = to_hom (k' a h)}
|
||||
include c c' p k k' q
|
||||
|
||||
private theorem X_eq : X.mk c k @k_coh = X.mk c' k' @k'_coh :=
|
||||
begin
|
||||
cases p,
|
||||
assert q' : k = k',
|
||||
{ apply eq_of_homotopy, intro a, apply eq_of_homotopy, intro h,
|
||||
apply iso_eq, apply !id_left⁻¹ ⬝ q a h },
|
||||
cases q',
|
||||
apply ap (essentially_surj_precomp_X.mk c' k'),
|
||||
apply is_prop.elim
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
open prod.ops sigma.ops
|
||||
private theorem X_prop [instance] : is_prop (X b) :=
|
||||
begin
|
||||
induction He.2 b with Hb, cases Hb with a0 Ha0,
|
||||
fapply is_prop.mk, intros f g, cases f with cf kf kf_coh, cases g with cg kg kg_coh,
|
||||
fapply X_eq,
|
||||
{ apply eq_of_iso, apply iso.trans, apply iso.symm, apply kf a0 Ha0,
|
||||
apply kg a0 Ha0 },
|
||||
{ intro a h,
|
||||
assert fHf : Σ f : hom a a0, to_hom Ha0 ∘ (to_fun_hom H f) = to_hom h,
|
||||
{ fconstructor, apply hom_inv, apply He.1, exact to_hom Ha0⁻¹ⁱ ∘ to_hom h,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply right_inv (to_fun_hom H),
|
||||
apply comp_inverse_cancel_left },
|
||||
apply concat, apply ap (λ x, to_hom x ∘ _), apply iso_of_eq_eq_of_iso,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply (kf_coh h Ha0 fHf.1 fHf.2)⁻¹,
|
||||
apply concat, rotate 1, apply kg_coh h Ha0 fHf.1 fHf.2,
|
||||
apply concat, apply assoc, apply ap (λ x, x ∘ _),
|
||||
apply concat, apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply comp.left_inverse,
|
||||
apply id_right },
|
||||
end
|
||||
|
||||
private definition X_inh (b) : X b :=
|
||||
begin
|
||||
induction He.2 b with Hb, cases Hb with a0 Ha0,
|
||||
fconstructor, exact F a0,
|
||||
{ intro a h, apply to_fun_iso F, apply reflect_iso H,
|
||||
exact h ⬝i Ha0⁻¹ⁱ },
|
||||
{ intros a a' h h' f HH,
|
||||
apply concat, apply !respect_comp⁻¹, apply ap (to_fun_hom F),
|
||||
esimp, rewrite [-HH],
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply inverse, apply left_inv (to_fun_hom H),
|
||||
apply concat, apply !hom_inv_respect_comp⁻¹, apply ap (hom_inv H),
|
||||
apply !assoc⁻¹ }
|
||||
end
|
||||
local abbreviation G0 [reducible] := λ (b), X.c (X_inh b)
|
||||
private definition k := λ b, X.k (X_inh b)
|
||||
private definition k_coh := λ b, @X.k_coh b (X_inh b)
|
||||
|
||||
private definition X_c_eq_of_eq {b} (t t' : X b) (p : t = t') : X.c t = X.c t' :=
|
||||
by cases p; reflexivity
|
||||
|
||||
private definition X_k_eq_of_eq {b} (t t' : X b) (p : t = t') (a : carrier A) (h : H a ≅ b) :
|
||||
X_c_eq_of_eq t t' p ▸ X.k t a h = X.k t' a h:=
|
||||
by cases p; reflexivity
|
||||
|
||||
private definition X_phi {b} (t : X b) : X.c t = X.c (X_inh b) :=
|
||||
X_c_eq_of_eq _ _ !is_prop.elim
|
||||
|
||||
private definition X_phi_transp {b} (t : X b) (a : carrier A) (h : H a ≅ b) :
|
||||
(X_phi t) ▸ (X.k t a h) = k b a h :=
|
||||
by apply X_k_eq_of_eq t _ !is_prop.elim
|
||||
|
||||
private definition X_phi_hom_of_eq' {b} (t t' : X b) (p : t = t') (a : carrier A) (h : H a ≅ b) :
|
||||
X.k t' a h ⬝i (iso_of_eq (X_c_eq_of_eq t t' p)⁻¹) = X.k t a h :=
|
||||
begin
|
||||
cases p, apply iso_eq, apply id_left
|
||||
end
|
||||
|
||||
private definition X_phi_hom_of_eq {b} (t : X b) (a : carrier A) (h : H a ≅ b) :
|
||||
to_hom (k b a h ⬝i (iso_of_eq (X_phi t)⁻¹)) = to_hom (X.k t a h) :=
|
||||
begin
|
||||
apply ap to_hom, apply X_phi_hom_of_eq'
|
||||
end
|
||||
|
||||
structure essentially_surj_precomp_Y {b b' : carrier B} (f : hom b b') : Type :=
|
||||
(g : hom (G0 b) (G0 b'))
|
||||
(Hg : Π {a a' : carrier A} h h' (l : hom a a'), to_hom h' ∘ to_fun_hom H l = f ∘ to_hom h →
|
||||
to_hom (k b' a' h') ∘ to_fun_hom F l = g ∘ to_hom (k b a h))
|
||||
local abbreviation Y := @essentially_surj_precomp_Y
|
||||
local abbreviation Y.mk := @essentially_surj_precomp_Y.mk
|
||||
local abbreviation Y.g := @essentially_surj_precomp_Y.g
|
||||
|
||||
section
|
||||
variables {g : hom (G0 b) (G0 b')} {g' : hom (G0 b) (G0 b')} (p : g = g')
|
||||
(Hg : Π {a a' : carrier A} h h' (l : hom a a'), to_hom h' ∘ to_fun_hom H l = f ∘ to_hom h →
|
||||
to_hom (k b' a' h') ∘ to_fun_hom F l = g ∘ to_hom (k b a h))
|
||||
(Hg' : Π {a a' : carrier A} h h' (l : hom a a'), to_hom h' ∘ to_fun_hom H l = f ∘ to_hom h →
|
||||
to_hom (k b' a' h') ∘ to_fun_hom F l = g' ∘ to_hom (k b a h))
|
||||
include p
|
||||
|
||||
private theorem Y_eq : Y.mk g @Hg = Y.mk g' @Hg' :=
|
||||
begin
|
||||
cases p, apply ap (Y.mk g'),
|
||||
apply is_prop.elim,
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
private theorem Y_prop [instance] : is_prop (Y f) :=
|
||||
begin
|
||||
induction He.2 b with Hb, cases Hb with a0 h0,
|
||||
induction He.2 b' with Hb', cases Hb' with a0' h0',
|
||||
fapply is_prop.mk, intros,
|
||||
cases x with g0 Hg0, cases y with g1 Hg1,
|
||||
apply Y_eq,
|
||||
assert l0Hl0 : Σ l0 : hom a0 a0', to_hom h0' ∘ to_fun_hom H l0 = f ∘ to_hom h0,
|
||||
{ fconstructor, apply hom_inv, apply He.1, exact to_hom h0'⁻¹ⁱ ∘ f ∘ to_hom h0,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply right_inv (to_fun_hom H),
|
||||
apply comp_inverse_cancel_left },
|
||||
apply comp.cancel_right (to_hom (k b a0 h0)),
|
||||
apply concat, apply inverse, apply Hg0 h0 h0' l0Hl0.1 l0Hl0.2,
|
||||
apply Hg1 h0 h0' l0Hl0.1 l0Hl0.2
|
||||
end
|
||||
|
||||
private definition Y_inh : Y f :=
|
||||
begin
|
||||
induction He.2 b with Hb, cases Hb with a0 h0,
|
||||
induction He.2 b' with Hb', cases Hb' with a0' h0',
|
||||
assert l0Hl0 : Σ l0 : hom a0 a0', to_hom h0' ∘ to_fun_hom H l0 = f ∘ to_hom h0,
|
||||
{ fconstructor, apply hom_inv, apply He.1, exact to_hom h0'⁻¹ⁱ ∘ f ∘ to_hom h0,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply right_inv (to_fun_hom H),
|
||||
apply comp_inverse_cancel_left },
|
||||
fapply Y.mk,
|
||||
{ refine to_hom (k b' a0' h0') ∘ _ ∘ to_hom (k b a0 h0)⁻¹ⁱ,
|
||||
apply to_fun_hom F, apply l0Hl0.1 },
|
||||
{ intros a a' h h' l Hl, esimp, apply inverse,
|
||||
assert mHm : Σ m, to_hom h0 ∘ to_fun_hom H m = to_hom h,
|
||||
{ fconstructor, apply hom_inv, apply He.1, exact to_hom h0⁻¹ⁱ ∘ to_hom h,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply right_inv (to_fun_hom H),
|
||||
apply comp_inverse_cancel_left },
|
||||
assert m'Hm' : Σ m', to_hom h0' ∘ to_fun_hom H m' = to_hom h',
|
||||
{ fconstructor, apply hom_inv, apply He.1, exact to_hom h0'⁻¹ⁱ ∘ to_hom h',
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply right_inv (to_fun_hom H),
|
||||
apply comp_inverse_cancel_left },
|
||||
assert m'l0lm : l0Hl0.1 ∘ mHm.1 = m'Hm'.1 ∘ l,
|
||||
{ apply faithful_of_fully_faithful, apply He.1,
|
||||
apply concat, apply respect_comp, apply comp.cancel_left (to_hom h0'), apply inverse,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply respect_comp,
|
||||
apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply m'Hm'.2,
|
||||
apply concat, apply Hl,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply mHm.2⁻¹,
|
||||
apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply l0Hl0.2⁻¹, apply !assoc⁻¹ },
|
||||
apply concat, apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ _ ∘ x), apply inverse_comp_eq_of_eq_comp,
|
||||
apply inverse, apply k_coh b h h0, apply mHm.2,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply concat, apply !respect_comp⁻¹,
|
||||
apply concat, apply ap (to_fun_hom F), apply m'l0lm, apply respect_comp,
|
||||
apply concat, apply assoc, apply ap (λ x, x ∘ _),
|
||||
apply k_coh, apply m'Hm'.2 }
|
||||
end
|
||||
|
||||
private definition G_hom [constructor] := λ {b b'} (f : hom b b'), Y.g (Y_inh f)
|
||||
private definition G_hom_coh := λ {b b'} (f : hom b b'),
|
||||
@essentially_surj_precomp_Y.Hg b b' f (Y_inh f)
|
||||
|
||||
private theorem G_hom_id (b : carrier B) : G_hom (ID b) = ID (G0 b) :=
|
||||
begin
|
||||
cases He with He1 He2, esimp[G_hom, Y_inh],
|
||||
induction He2 b with Hb, cases Hb with a h, --why do i need to destruct He?
|
||||
apply concat, apply ap (λ x, _ ∘ x ∘ _),
|
||||
apply concat, apply ap (to_fun_hom F),
|
||||
apply concat, apply ap (hom_inv H), apply inverse_comp_id_comp,
|
||||
apply hom_inv_respect_id,
|
||||
apply respect_id,
|
||||
apply comp_id_comp_inverse
|
||||
end
|
||||
|
||||
private theorem G_hom_comp {b0 b1 b2 : carrier B} (g : hom b1 b2) (f : hom b0 b1) :
|
||||
G_hom (g ∘ f) = G_hom g ∘ G_hom f :=
|
||||
begin
|
||||
cases He with He1 He2, esimp[G_hom, Y_inh],
|
||||
induction He2 b0 with Hb0, cases Hb0 with a0 h0,
|
||||
induction He2 b1 with Hb1, cases Hb1 with a1 h1,
|
||||
induction He2 b2 with Hb2, cases Hb2 with b2 h2,
|
||||
apply concat, apply assoc,
|
||||
apply concat, rotate 1, apply !assoc⁻¹,
|
||||
apply concat, rotate 1, apply !assoc⁻¹,
|
||||
apply ap (λ x, x ∘ _),
|
||||
apply inverse, apply concat, apply ap (λ x, x ∘ _),
|
||||
apply concat, apply !assoc⁻¹, apply ap (λ x, _ ∘ x),
|
||||
apply concat, apply !assoc⁻¹, apply ap (λ x, _ ∘ x), apply comp.left_inverse,
|
||||
apply concat, apply !assoc⁻¹, apply ap (λ x, _ ∘ x),
|
||||
apply concat, apply ap (λ x, x ∘ _), apply id_right,
|
||||
apply concat, apply !respect_comp⁻¹, apply ap (to_fun_hom F),
|
||||
apply concat, apply !hom_inv_respect_comp⁻¹, apply ap (hom_inv H),
|
||||
apply concat, apply ap (λ x, x ∘ _), apply assoc,
|
||||
apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply comp_inverse_cancel_right,
|
||||
apply concat, apply !assoc⁻¹, apply ap (λ x, _ ∘ x),
|
||||
apply assoc,
|
||||
end
|
||||
|
||||
private definition G_functor : B ⇒ C :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ exact G0 },
|
||||
{ intro b b' f, exact G_hom f },
|
||||
{ intro b, apply G_hom_id },
|
||||
{ intro a b c g f, apply G_hom_comp }
|
||||
end
|
||||
|
||||
private definition XF (a0 : carrier A) : X (H a0) :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ exact F a0 },
|
||||
{ intro a h, apply to_fun_iso F, apply reflect_iso, apply He.1, exact h },
|
||||
{ intro a a' h h' f l, esimp,
|
||||
apply concat, apply !respect_comp⁻¹, apply ap (to_fun_hom F), apply inverse,
|
||||
apply concat, apply ap (hom_inv H) l⁻¹,
|
||||
apply concat, apply hom_inv_respect_comp, apply ap (λ x, _ ∘ x), apply left_inv }
|
||||
end
|
||||
|
||||
private definition G0_H_eq_F (a0 : carrier A) : G0 (H a0) = F a0 :=
|
||||
begin
|
||||
apply inverse, apply X_phi (XF a0)
|
||||
end
|
||||
|
||||
private theorem G_hom_H_eq_F {a0 a0' : carrier A} (f0 : hom a0 a0') :
|
||||
hom_of_eq (G0_H_eq_F a0') ∘ G_hom (to_fun_hom H f0) ∘ inv_of_eq (G0_H_eq_F a0)
|
||||
= to_fun_hom F f0 :=
|
||||
begin
|
||||
apply comp_eq_of_eq_inverse_comp, apply comp_inverse_eq_of_eq_comp,
|
||||
apply concat, apply ap essentially_surj_precomp_Y.g, apply is_prop.elim,
|
||||
fconstructor,
|
||||
{ exact (inv_of_eq (G0_H_eq_F a0') ∘ to_fun_hom F f0) ∘ hom_of_eq (G0_H_eq_F a0) },
|
||||
{ intros a a' h h' l α, esimp[G0_H_eq_F], apply inverse,
|
||||
apply concat, apply !assoc⁻¹,
|
||||
apply concat, apply ap (λ x, _ ∘ x), apply X_phi_hom_of_eq,
|
||||
apply concat, apply !assoc⁻¹,
|
||||
apply inverse_comp_eq_of_eq_comp, apply inverse,
|
||||
apply concat, apply assoc,
|
||||
apply concat, apply ap (λ x, x ∘ _), apply X_phi_hom_of_eq, esimp[XF],
|
||||
refine !respect_comp⁻¹ ⬝ ap (to_fun_hom F) _ ⬝ !respect_comp,
|
||||
apply eq_of_fn_eq_fn' (to_fun_hom H),
|
||||
refine !respect_comp ⬝ _ ⬝ !respect_comp⁻¹,
|
||||
apply concat, apply ap (λ x, x ∘ _) !(right_inv (to_fun_hom H)),
|
||||
apply concat, rotate 1, apply ap (λ x, _ ∘ x) !(right_inv (to_fun_hom H))⁻¹,
|
||||
exact α },
|
||||
reflexivity
|
||||
end
|
||||
|
||||
end essentially_surjective_precomposition
|
||||
|
||||
definition essentially_surjective_precomposition_functor [instance] {A B : Precategory}
|
||||
(C : Category) (H : A ⇒ B) [He : is_weak_equivalence H] :
|
||||
essentially_surjective (precomposition_functor C H) :=
|
||||
begin
|
||||
intro F, apply tr, fconstructor, apply G_functor F,
|
||||
apply iso_of_eq, fapply functor_eq,
|
||||
{ intro a, esimp[G_functor], exact G0_H_eq_F F a },
|
||||
{ intro a b f, exact G_hom_H_eq_F F f }
|
||||
end
|
||||
|
||||
variables {C D E : Precategory}
|
||||
|
||||
definition postcomposition_functor [constructor] {C D} (E) (F : C ⇒ D)
|
||||
: C ^c E ⇒ D ^c E :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro G, exact F ∘f G},
|
||||
{ intro G H η, exact F ∘fn η},
|
||||
{ intro G, apply fn_id},
|
||||
{ intro G H I η θ, apply fn_n_distrib},
|
||||
end
|
||||
|
||||
definition constant_diagram [constructor] (C D) : C ⇒ C ^c D :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro c, exact constant_functor D c},
|
||||
{ intro c d f, exact constant_nat_trans D f},
|
||||
{ intro c, fapply nat_trans_eq, reflexivity},
|
||||
{ intro c d e g f, fapply nat_trans_eq, reflexivity},
|
||||
end
|
||||
|
||||
definition opposite_functor_opposite_left [constructor] (C D : Precategory)
|
||||
: (C ^c D)ᵒᵖ ⇒ Cᵒᵖ ^c Dᵒᵖ :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ exact opposite_functor},
|
||||
{ intro F G, exact opposite_nat_trans},
|
||||
{ intro F, apply nat_trans_eq, reflexivity},
|
||||
{ intro u v w g f, apply nat_trans_eq, reflexivity}
|
||||
end
|
||||
|
||||
definition opposite_functor_opposite_right [constructor] (C D : Precategory)
|
||||
: Cᵒᵖ ^c Dᵒᵖ ⇒ (C ^c D)ᵒᵖ :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ exact opposite_functor_rev},
|
||||
{ apply @opposite_rev_nat_trans},
|
||||
{ intro F, apply nat_trans_eq, intro d, reflexivity},
|
||||
{ intro F G H η θ, apply nat_trans_eq, intro d, reflexivity}
|
||||
end
|
||||
|
||||
definition constant_diagram_opposite [constructor] (C D)
|
||||
: (constant_diagram C D)ᵒᵖᶠ = opposite_functor_opposite_right C D ∘f constant_diagram Cᵒᵖ Dᵒᵖ :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{ reflexivity },
|
||||
{ intro c c' f, esimp at *, refine !nat_trans.id_right ⬝ !nat_trans.id_left ⬝ _,
|
||||
apply nat_trans_eq, intro d, reflexivity }
|
||||
end
|
||||
|
||||
end functor
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
/-
|
||||
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 ..groupoid ..functor.basic
|
||||
|
||||
open eq is_trunc iso trunc functor
|
||||
|
||||
namespace category
|
||||
|
||||
definition fundamental_precategory [constructor] (A : Type) : Precategory :=
|
||||
precategory.MK A
|
||||
(λa a', trunc 0 (a = a'))
|
||||
_
|
||||
(λa₁ a₂ a₃ q p, tconcat p q)
|
||||
(λa, tidp)
|
||||
(λa₁ a₂ a₃ a₄ r q p, tassoc p q r)
|
||||
(λa₁ a₂, tcon_tidp)
|
||||
(λa₁ a₂, tidp_tcon)
|
||||
|
||||
definition fundamental_groupoid [constructor] (A : Type) : Groupoid :=
|
||||
groupoid.MK (fundamental_precategory A)
|
||||
(λa b p, is_iso.mk (tinverse p) (right_tinv p) (left_tinv p))
|
||||
|
||||
definition fundamental_groupoid_functor [constructor] {A B : Type} (f : A → B) :
|
||||
fundamental_groupoid A ⇒ fundamental_groupoid B :=
|
||||
functor.mk f (λa a', tap f) (λa, tap_tidp f) (λa₁ a₂ a₃ q p, tap_tcon f p q)
|
||||
|
||||
notation `Π₁` := fundamental_groupoid
|
||||
|
||||
notation `Π₁⇒` := fundamental_groupoid_functor
|
||||
|
||||
end category
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Indiscrete category
|
||||
-/
|
||||
|
||||
import .opposite
|
||||
|
||||
open functor is_trunc unit eq
|
||||
|
||||
namespace category
|
||||
|
||||
variable (X : Type)
|
||||
|
||||
definition indiscrete_precategory [constructor] : precategory X :=
|
||||
precategory.mk (λx y, unit)
|
||||
(λx y z f g, star)
|
||||
(λx, star)
|
||||
(λx y z w f g h, idp)
|
||||
(λx y f, by induction f; reflexivity)
|
||||
(λx y f, by induction f; reflexivity)
|
||||
|
||||
definition Indiscrete_precategory [constructor] : Precategory :=
|
||||
precategory.Mk (indiscrete_precategory X)
|
||||
|
||||
definition indiscrete_op : (Indiscrete_precategory X)ᵒᵖ = Indiscrete_precategory X := idp
|
||||
|
||||
end category
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Initial category
|
||||
-/
|
||||
|
||||
import .indiscrete
|
||||
|
||||
open functor is_trunc eq
|
||||
|
||||
namespace category
|
||||
|
||||
definition initial_precategory [constructor] : precategory empty :=
|
||||
indiscrete_precategory empty
|
||||
|
||||
definition Initial_precategory [constructor] : Precategory :=
|
||||
precategory.Mk initial_precategory
|
||||
|
||||
notation 0 := Initial_precategory
|
||||
definition zero_op : 0ᵒᵖ = 0 := idp
|
||||
|
||||
definition initial_functor [constructor] (C : Precategory) : 0 ⇒ C :=
|
||||
functor.mk (λx, empty.elim x)
|
||||
(λx y f, empty.elim x)
|
||||
(λx, empty.elim x)
|
||||
(λx y z g f, empty.elim x)
|
||||
|
||||
definition is_contr_initial_functor [instance] (C : Precategory) : is_contr (0 ⇒ C) :=
|
||||
is_contr.mk (initial_functor C)
|
||||
begin
|
||||
intro F, fapply functor_eq,
|
||||
{ intro x, exact empty.elim x},
|
||||
{ intro x y f, exact empty.elim x}
|
||||
end
|
||||
|
||||
definition initial_functor_op (C : Precategory)
|
||||
: (initial_functor C)ᵒᵖᶠ = initial_functor Cᵒᵖ :=
|
||||
by apply @is_prop.elim (0 ⇒ Cᵒᵖ)
|
||||
|
||||
definition initial_functor_comp {C D : Precategory} (F : C ⇒ D)
|
||||
: F ∘f initial_functor C = initial_functor D :=
|
||||
by apply @is_prop.elim (0 ⇒ D)
|
||||
|
||||
end category
|
||||
|
|
@ -1,158 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Opposite precategory and (TODO) category
|
||||
-/
|
||||
|
||||
import ..nat_trans ..category
|
||||
|
||||
open eq functor iso equiv is_equiv nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
definition opposite [reducible] [constructor] {ob : Type} (C : precategory ob) : precategory ob :=
|
||||
precategory.mk' (λ a b, hom b a)
|
||||
(λ a b c f g, g ∘ f)
|
||||
(λ a, id)
|
||||
(λ a b c d f g h, !assoc')
|
||||
(λ a b c d f g h, !assoc)
|
||||
(λ a b f, !id_right)
|
||||
(λ a b f, !id_left)
|
||||
(λ a, !id_id)
|
||||
(λ a b, !is_set_hom)
|
||||
|
||||
definition Opposite [reducible] [constructor] (C : Precategory) : Precategory :=
|
||||
precategory.Mk (opposite C)
|
||||
|
||||
infixr `∘op`:60 := @comp _ (opposite _) _ _ _
|
||||
postfix `ᵒᵖ`:(max+2) := Opposite
|
||||
|
||||
variables {C D E : Precategory} {a b c : C}
|
||||
|
||||
definition compose_op {f : hom a b} {g : hom b c} : f ∘op g = g ∘ f :=
|
||||
by reflexivity
|
||||
|
||||
definition opposite_opposite' {ob : Type} (C : precategory ob) : opposite (opposite C) = C :=
|
||||
by cases C; apply idp
|
||||
|
||||
definition opposite_opposite : (Cᵒᵖ)ᵒᵖ = C :=
|
||||
(ap (Precategory.mk C) (opposite_opposite' C)) ⬝ !Precategory.eta
|
||||
|
||||
theorem opposite_hom_of_eq {ob : Type} [C : precategory ob] {c c' : ob} (p : c = c')
|
||||
: @hom_of_eq ob (opposite C) c c' p = inv_of_eq p :=
|
||||
by induction p; reflexivity
|
||||
|
||||
theorem opposite_inv_of_eq {ob : Type} [C : precategory ob] {c c' : ob} (p : c = c')
|
||||
: @inv_of_eq ob (opposite C) c c' p = hom_of_eq p :=
|
||||
by induction p; reflexivity
|
||||
|
||||
definition opposite_functor [constructor] (F : C ⇒ D) : Cᵒᵖ ⇒ Dᵒᵖ :=
|
||||
begin
|
||||
apply functor.mk,
|
||||
intros, apply respect_id F,
|
||||
intros, apply @respect_comp C D
|
||||
end
|
||||
|
||||
definition opposite_functor_rev [constructor] (F : Cᵒᵖ ⇒ Dᵒᵖ) : C ⇒ D :=
|
||||
begin
|
||||
apply functor.mk,
|
||||
intros, apply respect_id F,
|
||||
intros, apply @respect_comp Cᵒᵖ Dᵒᵖ
|
||||
end
|
||||
|
||||
postfix `ᵒᵖᶠ`:(max+2) := opposite_functor
|
||||
postfix `ᵒᵖ'`:(max+2) := opposite_functor_rev
|
||||
|
||||
definition functor_id_op (C : Precategory) : (1 : C ⇒ C)ᵒᵖᶠ = 1 :=
|
||||
idp
|
||||
|
||||
definition opposite_rev_opposite_functor (F : Cᵒᵖ ⇒ Dᵒᵖ) : Fᵒᵖ' ᵒᵖᶠ = F :=
|
||||
begin
|
||||
fapply functor_eq: esimp,
|
||||
{ intro c c' f, esimp, exact !id_right ⬝ !id_left}
|
||||
end
|
||||
|
||||
definition opposite_opposite_rev_functor (F : C ⇒ D) : Fᵒᵖᶠᵒᵖ' = F :=
|
||||
begin
|
||||
fapply functor_eq: esimp,
|
||||
{ intro c c' f, esimp, exact !id_leftright}
|
||||
end
|
||||
|
||||
definition opposite_compose (G : D ⇒ E) (F : C ⇒ D) : (G ∘f F)ᵒᵖᶠ = Gᵒᵖᶠ ∘f Fᵒᵖᶠ :=
|
||||
idp
|
||||
|
||||
definition opposite_nat_trans [constructor] {F G : C ⇒ D} (η : F ⟹ G) : Gᵒᵖᶠ ⟹ Fᵒᵖᶠ :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact η c},
|
||||
{ intro c c' f, exact !naturality⁻¹},
|
||||
end
|
||||
|
||||
definition opposite_rev_nat_trans [constructor] {F G : Cᵒᵖ ⇒ Dᵒᵖ} (η : F ⟹ G) : Gᵒᵖ' ⟹ Fᵒᵖ' :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact η c},
|
||||
{ intro c c' f, exact !(@naturality Cᵒᵖ Dᵒᵖ)⁻¹},
|
||||
end
|
||||
|
||||
definition opposite_nat_trans_rev [constructor] {F G : C ⇒ D} (η : Fᵒᵖᶠ ⟹ Gᵒᵖᶠ) : G ⟹ F :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact η c},
|
||||
{ intro c c' f, exact !(@naturality Cᵒᵖ Dᵒᵖ _ _ η)⁻¹},
|
||||
end
|
||||
|
||||
definition opposite_rev_nat_trans_rev [constructor] {F G : Cᵒᵖ ⇒ Dᵒᵖ} (η : Fᵒᵖ' ⟹ Gᵒᵖ') : G ⟹ F :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact η c},
|
||||
{ intro c c' f, exact (naturality η f)⁻¹},
|
||||
end
|
||||
|
||||
definition opposite_iso [constructor] {ob : Type} [C : precategory ob] {a b : ob}
|
||||
(H : @iso _ C a b) : @iso _ (opposite C) a b :=
|
||||
begin
|
||||
fapply @iso.MK _ (opposite C),
|
||||
{ exact to_inv H},
|
||||
{ exact to_hom H},
|
||||
{ exact to_left_inverse H},
|
||||
{ exact to_right_inverse H},
|
||||
end
|
||||
|
||||
definition iso_of_opposite_iso [constructor] {ob : Type} [C : precategory ob] {a b : ob}
|
||||
(H : @iso _ (opposite C) a b) : @iso _ C a b :=
|
||||
begin
|
||||
fapply iso.MK,
|
||||
{ exact to_inv H},
|
||||
{ exact to_hom H},
|
||||
{ exact to_left_inverse H},
|
||||
{ exact to_right_inverse H},
|
||||
end
|
||||
|
||||
definition opposite_iso_equiv [constructor] {ob : Type} [C : precategory ob] (a b : ob)
|
||||
: @iso _ (opposite C) a b ≃ @iso _ C a b :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact iso_of_opposite_iso},
|
||||
{ exact opposite_iso},
|
||||
{ intro H, apply iso_eq, reflexivity},
|
||||
{ intro H, apply iso_eq, reflexivity},
|
||||
end
|
||||
|
||||
definition is_univalent_opposite (C : Category) : is_univalent (Opposite C) :=
|
||||
begin
|
||||
intro x y,
|
||||
fapply is_equiv_of_equiv_of_homotopy,
|
||||
{ refine @eq_equiv_iso C C x y ⬝e _, symmetry, esimp at *, apply opposite_iso_equiv},
|
||||
{ intro p, induction p, reflexivity}
|
||||
end
|
||||
|
||||
definition category_opposite [constructor] (C : Category) : category (Opposite C) :=
|
||||
category.mk _ (is_univalent_opposite C)
|
||||
|
||||
definition Category_opposite [constructor] (C : Category) : Category :=
|
||||
Category.mk _ (category_opposite C)
|
||||
|
||||
end category
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jakob von Raumer
|
||||
|
||||
Categories of (hprop value) ordered sets.
|
||||
-/
|
||||
import ..category algebra.order types.fin
|
||||
|
||||
open algebra category is_trunc is_equiv equiv iso
|
||||
|
||||
namespace category
|
||||
|
||||
section
|
||||
universe variable l
|
||||
parameters (A : Type.{l}) [HA : is_set A] [OA : weak_order.{l} A]
|
||||
[Hle : Π a b : A, is_prop (a ≤ b)]
|
||||
include A HA OA Hle
|
||||
|
||||
definition precategory_order [constructor] : precategory.{l l} A :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro a b, exact a ≤ b },
|
||||
{ intro a b c, exact ge.trans },
|
||||
{ intro a, apply le.refl },
|
||||
do 5 (intros; apply is_prop.elim),
|
||||
{ intros, apply is_trunc_succ }
|
||||
end
|
||||
|
||||
local attribute [instance] precategory_order
|
||||
|
||||
definition category_order : category.{l l} A :=
|
||||
begin
|
||||
fapply category.mk precategory_order,
|
||||
intros a b, fapply adjointify,
|
||||
{ intro f, apply le.antisymm, apply iso.to_hom f, apply iso.to_inv f },
|
||||
{ intro f, fapply iso_eq, esimp[precategory_order], apply is_prop.elim },
|
||||
{ intro p, apply is_prop.elim }
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,143 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Product precategory and (TODO) category
|
||||
-/
|
||||
|
||||
import ..category ..nat_trans hit.trunc
|
||||
|
||||
open eq prod is_trunc functor sigma trunc iso prod.ops nat_trans
|
||||
|
||||
namespace category
|
||||
definition precategory_prod [constructor] [instance] (obC obD : Type)
|
||||
[C : precategory obC] [D : precategory obD] : precategory (obC × obD) :=
|
||||
precategory.mk' (λ a b, hom a.1 b.1 × hom a.2 b.2)
|
||||
(λ a b c g f, (g.1 ∘ f.1, g.2 ∘ f.2))
|
||||
(λ a, (id, id))
|
||||
(λ a b c d h g f, pair_eq !assoc !assoc )
|
||||
(λ a b c d h g f, pair_eq !assoc' !assoc' )
|
||||
(λ a b f, prod_eq !id_left !id_left )
|
||||
(λ a b f, prod_eq !id_right !id_right)
|
||||
(λ a, prod_eq !id_id !id_id)
|
||||
_
|
||||
|
||||
definition Precategory_prod [reducible] [constructor] (C D : Precategory) : Precategory :=
|
||||
precategory.Mk (precategory_prod C D)
|
||||
|
||||
infixr ` ×c `:70 := Precategory_prod
|
||||
|
||||
variables {C C' D D' X : Precategory} {u v : carrier (C ×c D)}
|
||||
|
||||
theorem prod_hom_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: hom_of_eq (prod_eq p q) = (hom_of_eq p, hom_of_eq q) :=
|
||||
by induction u; induction v; esimp at *; induction p; induction q; reflexivity
|
||||
|
||||
theorem prod_inv_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: inv_of_eq (prod_eq p q) = (inv_of_eq p, inv_of_eq q) :=
|
||||
by induction u; induction v; esimp at *; induction p; induction q; reflexivity
|
||||
|
||||
theorem pr1_hom_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: (hom_of_eq (prod_eq p q)).1 = hom_of_eq p :=
|
||||
by exact ap pr1 !prod_hom_of_eq
|
||||
|
||||
theorem pr1_inv_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: (inv_of_eq (prod_eq p q)).1 = inv_of_eq p :=
|
||||
by exact ap pr1 !prod_inv_of_eq
|
||||
|
||||
theorem pr2_hom_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: (hom_of_eq (prod_eq p q)).2 = hom_of_eq q :=
|
||||
by exact ap pr2 !prod_hom_of_eq
|
||||
|
||||
theorem pr2_inv_of_eq (p : u.1 = v.1) (q : u.2 = v.2)
|
||||
: (inv_of_eq (prod_eq p q)).2 = inv_of_eq q :=
|
||||
by exact ap pr2 !prod_inv_of_eq
|
||||
|
||||
definition pr1_functor [constructor] : C ×c D ⇒ C :=
|
||||
functor.mk pr1
|
||||
(λa b, pr1)
|
||||
(λa, idp)
|
||||
(λa b c g f, idp)
|
||||
|
||||
definition pr2_functor [constructor] : C ×c D ⇒ D :=
|
||||
functor.mk pr2
|
||||
(λa b, pr2)
|
||||
(λa, idp)
|
||||
(λa b c g f, idp)
|
||||
|
||||
definition functor_prod [constructor] [reducible] (F : X ⇒ C) (G : X ⇒ D) : X ⇒ C ×c D :=
|
||||
functor.mk (λ a, pair (F a) (G a))
|
||||
(λ a b f, pair (F f) (G f))
|
||||
(λ a, abstract pair_eq !respect_id !respect_id end)
|
||||
(λ a b c g f, abstract pair_eq !respect_comp !respect_comp end)
|
||||
|
||||
infixr ` ×f `:70 := functor_prod
|
||||
|
||||
definition prod_functor_eta (F : X ⇒ C ×c D) : pr1_functor ∘f F ×f pr2_functor ∘f F = F :=
|
||||
begin
|
||||
fapply functor_eq: esimp,
|
||||
{ intro e, apply prod_eq: reflexivity},
|
||||
{ intro e e' f, apply prod_eq: esimp,
|
||||
{ refine ap (λx, x ∘ _ ∘ _) !pr1_hom_of_eq ⬝ _,
|
||||
refine ap (λx, _ ∘ _ ∘ x) !pr1_inv_of_eq ⬝ _, esimp,
|
||||
apply id_leftright},
|
||||
{ refine ap (λx, x ∘ _ ∘ _) !pr2_hom_of_eq ⬝ _,
|
||||
refine ap (λx, _ ∘ _ ∘ x) !pr2_inv_of_eq ⬝ _, esimp,
|
||||
apply id_leftright}}
|
||||
end
|
||||
|
||||
definition pr1_functor_prod (F : X ⇒ C) (G : X ⇒ D) : pr1_functor ∘f (F ×f G) = F :=
|
||||
functor_eq (λx, idp)
|
||||
(λx y f, !id_leftright)
|
||||
|
||||
definition pr2_functor_prod (F : X ⇒ C) (G : X ⇒ D) : pr2_functor ∘f (F ×f G) = G :=
|
||||
functor_eq (λx, idp)
|
||||
(λx y f, !id_leftright)
|
||||
|
||||
-- definition universal_property_prod {C D X : Precategory} (F : X ⇒ C) (G : X ⇒ D)
|
||||
-- : is_contr (Σ(H : X ⇒ C ×c D), pr1_functor ∘f H = F × pr2_functor ∘f H = G) :=
|
||||
-- is_contr.mk
|
||||
-- ⟨functor_prod F G, (pr1_functor_prod F G, pr2_functor_prod F G)⟩
|
||||
-- begin
|
||||
-- intro v, induction v with H w, induction w with p q,
|
||||
-- symmetry, fapply sigma_eq: esimp,
|
||||
-- { fapply functor_eq,
|
||||
-- { intro x, apply prod_eq: esimp,
|
||||
-- { exact ap010 to_fun_ob p x},
|
||||
-- { exact ap010 to_fun_ob q x}},
|
||||
-- { intro x y f, apply prod_eq: esimp,
|
||||
-- { exact sorry},
|
||||
-- { exact sorry}}},
|
||||
-- { exact sorry}
|
||||
-- end
|
||||
|
||||
definition prod_functor_prod [constructor] (F : C ⇒ D) (G : C' ⇒ D') : C ×c C' ⇒ D ×c D' :=
|
||||
(F ∘f pr1_functor) ×f (G ∘f pr2_functor)
|
||||
|
||||
definition prod_nat_trans [constructor] {C D D' : Precategory}
|
||||
{F F' : C ⇒ D} {G G' : C ⇒ D'} (η : F ⟹ F') (θ : G ⟹ G') : F ×f G ⟹ F' ×f G' :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact (η c, θ c)},
|
||||
{ intro c c' f, apply prod_eq: esimp:apply naturality}
|
||||
end
|
||||
|
||||
infixr ` ×n `:70 := prod_nat_trans
|
||||
|
||||
definition prod_flip_functor [constructor] (C D : Precategory) : C ×c D ⇒ D ×c C :=
|
||||
functor.mk (λp, (p.2, p.1))
|
||||
(λp p' h, (h.2, h.1))
|
||||
(λp, idp)
|
||||
(λp p' p'' h' h, idp)
|
||||
|
||||
definition functor_prod_flip_functor_prod_flip (C D : Precategory)
|
||||
: prod_flip_functor D C ∘f (prod_flip_functor C D) = functor.id :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{ intro p, apply prod.eta},
|
||||
{ intro p p' h, cases p with c d, cases p' with c' d',
|
||||
apply id_leftright}
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,499 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
||||
The pushout of categories
|
||||
|
||||
The morphisms in the pushout of two categories is defined as a quotient on lists of composable
|
||||
morphisms. For this we use the notion of paths in a graph.
|
||||
-/
|
||||
|
||||
import ..category ..nat_trans hit.set_quotient algebra.relation ..groupoid algebra.graph
|
||||
.functor
|
||||
|
||||
open eq is_trunc functor trunc sum set_quotient relation iso category sigma nat nat_trans
|
||||
|
||||
/- 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⦄, paths R a a' → paths R a a' → Type)
|
||||
variables ⦃a a' a₁ a₂ a₃ a₄ : A⦄
|
||||
definition paths_trel [constructor] (l l' : paths R a a') : Prop :=
|
||||
∥paths_rel Q l l'∥
|
||||
|
||||
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 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 paths_id [constructor] (a : A) : mor a a :=
|
||||
class_of nil
|
||||
|
||||
local infix ` ∘∘ `:60 := paths_compose
|
||||
local notation `p1` := paths_id _
|
||||
|
||||
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,
|
||||
induction g using set_quotient.rec_prop with g,
|
||||
induction f using set_quotient.rec_prop with f,
|
||||
rewrite [▸*, append_assoc]
|
||||
end
|
||||
|
||||
theorem paths_id_left (f : mor a a') : p1 ∘∘ f = f :=
|
||||
begin
|
||||
induction f using set_quotient.rec_prop with f,
|
||||
reflexivity
|
||||
end
|
||||
|
||||
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_paths [constructor] : Precategory :=
|
||||
precategory.MK A
|
||||
mor
|
||||
_
|
||||
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' : 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 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 := paths_inv
|
||||
|
||||
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 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_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 paths
|
||||
open paths
|
||||
|
||||
namespace category
|
||||
|
||||
/- We also define the pushout of two groupoids with a type of basepoints, which are surjectively
|
||||
mapped into C (although we don't need to assume that this mapping is surjective for the
|
||||
definition) -/
|
||||
|
||||
section
|
||||
inductive bpushout_prehom_index {S : Type} {C D E : Precategory} (k : S → C) (F : C ⇒ D)
|
||||
(G : C ⇒ E) : D + E → D + E → Type :=
|
||||
| iD : Π{d d' : D} (f : d ⟶ d'), bpushout_prehom_index k F G (inl d) (inl d')
|
||||
| iE : Π{e e' : E} (g : e ⟶ e'), bpushout_prehom_index k F G (inr e) (inr e')
|
||||
| DE : Π(s : S), bpushout_prehom_index k F G (inl (F (k s))) (inr (G (k s)))
|
||||
| ED : Π(s : S), bpushout_prehom_index k F G (inr (G (k s))) (inl (F (k s)))
|
||||
|
||||
open bpushout_prehom_index
|
||||
|
||||
definition bpushout_prehom {S : Type} {C D E : Precategory} (k : S → C) (F : C ⇒ D) (G : C ⇒ E) :
|
||||
D + E → D + E → Type :=
|
||||
paths (bpushout_prehom_index k F G)
|
||||
|
||||
inductive bpushout_hom_rel_index {S : Type} {C D E : Precategory} (k : S → C) (F : C ⇒ D)
|
||||
(G : C ⇒ E) : Π⦃x x' : D + E⦄,
|
||||
bpushout_prehom k F G x x' → bpushout_prehom k F G x x' → Type :=
|
||||
| DD : Π{d₁ d₂ d₃ : D} (g : d₂ ⟶ d₃) (f : d₁ ⟶ d₂),
|
||||
bpushout_hom_rel_index k F G [iD k F G g, iD k F G f] [iD k F G (g ∘ f)]
|
||||
| EE : Π{e₁ e₂ e₃ : E} (g : e₂ ⟶ e₃) (f : e₁ ⟶ e₂),
|
||||
bpushout_hom_rel_index k F G [iE k F G g, iE k F G f] [iE k F G (g ∘ f)]
|
||||
| DED : Π(s : S), bpushout_hom_rel_index k F G [ED k F G s, DE k F G s] nil
|
||||
| EDE : Π(s : S), bpushout_hom_rel_index k F G [DE k F G s, ED k F G s] nil
|
||||
| idD : Π(d : D), bpushout_hom_rel_index k F G [iD k F G (ID d)] nil
|
||||
| idE : Π(e : E), bpushout_hom_rel_index k F G [iE k F G (ID e)] nil
|
||||
| cohDE : Π{s₁ s₂ : S} (h : k s₁ ⟶ k s₂),
|
||||
bpushout_hom_rel_index k F G [iE k F G (G h), DE k F G s₁] [DE k F G s₂, iD k F G (F h)]
|
||||
| cohED : Π{s₁ s₂ : S} (h : k s₁ ⟶ k s₂),
|
||||
bpushout_hom_rel_index k F G [ED k F G s₂, iE k F G (G h)] [iD k F G (F h), ED k F G s₁]
|
||||
|
||||
open bpushout_hom_rel_index paths.paths_rel
|
||||
|
||||
definition Precategory_bpushout [constructor] {S : Type} {C D E : Precategory}
|
||||
(k : S → C) (F : C ⇒ D) (G : C ⇒ E) : Precategory :=
|
||||
Precategory_paths (bpushout_hom_rel_index k F G)
|
||||
|
||||
parameters {C D E X : Precategory} (F : C ⇒ D) (G : C ⇒ E) (H : D ⇒ X) (K : E ⇒ X)
|
||||
(η : H ∘f F ≅ K ∘f G)
|
||||
|
||||
definition Cpushout [constructor] : Precategory :=
|
||||
Precategory_bpushout (λc, c) F G
|
||||
|
||||
definition Cpushout_inl [constructor] : D ⇒ Cpushout :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ exact inl},
|
||||
{ intro d d' f, exact class_of [iD (λc, c) F G f]},
|
||||
{ intro d, refine eq_of_rel (tr (paths_rel_of_Q _)), apply idD},
|
||||
{ intro d₁ d₂ d₃ g f, refine (eq_of_rel (tr (paths_rel_of_Q _)))⁻¹, apply DD}
|
||||
end
|
||||
|
||||
definition Cpushout_inr [constructor] : E ⇒ Cpushout :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ exact inr},
|
||||
{ intro e e' f, exact class_of [iE (λc, c) F G f]},
|
||||
{ intro e, refine eq_of_rel (tr (paths_rel_of_Q _)), apply idE},
|
||||
{ intro e₁ e₂ e₃ g f, refine (eq_of_rel (tr (paths_rel_of_Q _)))⁻¹, apply EE}
|
||||
end
|
||||
|
||||
definition Cpushout_coh [constructor] : Cpushout_inl ∘f F ≅ Cpushout_inr ∘f G :=
|
||||
begin
|
||||
fapply natural_iso.MK,
|
||||
{ intro c, exact class_of [DE (λ c, c) F G c]},
|
||||
{ intro c c' f, refine eq_of_rel (tr (paths_rel_of_Q !cohDE))},
|
||||
{ intro c, exact class_of [ED (λ c, c) F G c]},
|
||||
{ intro c, refine eq_of_rel (tr (paths_rel_of_Q !DED))},
|
||||
{ intro c, refine eq_of_rel (tr (paths_rel_of_Q !EDE))},
|
||||
end
|
||||
|
||||
--(class_of [DE (λ c, c) F G s])
|
||||
variables ⦃x x' x₁ x₂ x₃ : Cpushout⦄
|
||||
include H K
|
||||
local notation `R` := bpushout_prehom_index (λ c, c) F G
|
||||
local notation `Q` := bpushout_hom_rel_index (λ c, c) F G
|
||||
|
||||
definition Cpushout_functor_ob [unfold 9] (x : Cpushout) : X :=
|
||||
begin
|
||||
induction x with d e,
|
||||
{ exact H d},
|
||||
{ exact K e}
|
||||
end
|
||||
|
||||
include η
|
||||
parameters {F G H K}
|
||||
definition Cpushout_functor_reduction_rule [unfold 12] (i : R x x') :
|
||||
Cpushout_functor_ob x ⟶ Cpushout_functor_ob x' :=
|
||||
begin
|
||||
induction i,
|
||||
{ exact H f},
|
||||
{ exact K g},
|
||||
{ exact natural_map (to_hom η) s},
|
||||
{ exact natural_map (to_inv η) s}
|
||||
end
|
||||
|
||||
definition Cpushout_functor_list (l : paths R x x') :
|
||||
Cpushout_functor_ob x ⟶ Cpushout_functor_ob x' :=
|
||||
realize _
|
||||
Cpushout_functor_reduction_rule
|
||||
(λa, id)
|
||||
(λa b c g f, f ∘ g) l
|
||||
|
||||
definition Cpushout_functor_list_nil (x : Cpushout) :
|
||||
Cpushout_functor_list (@nil _ _ x) = id :=
|
||||
idp
|
||||
|
||||
definition Cpushout_functor_list_cons (r : R x₂ x₃) (l : paths R x₁ x₂) :
|
||||
Cpushout_functor_list (r :: l) = Cpushout_functor_reduction_rule r ∘ Cpushout_functor_list l :=
|
||||
idp
|
||||
|
||||
definition Cpushout_functor_list_singleton (r : R x₁ x₂) :
|
||||
Cpushout_functor_list [r] = Cpushout_functor_reduction_rule r :=
|
||||
realize_singleton (λa b f, id_right f) r
|
||||
|
||||
definition Cpushout_functor_list_pair (r₂ : R x₂ x₃) (r₁ : R x₁ x₂) :
|
||||
Cpushout_functor_list [r₂, r₁] =
|
||||
Cpushout_functor_reduction_rule r₂ ∘ Cpushout_functor_reduction_rule r₁ :=
|
||||
realize_pair (λa b f, id_right f) r₂ r₁
|
||||
|
||||
definition Cpushout_functor_list_append (l₂ : paths R x₂ x₃) (l₁ : paths R x₁ x₂) :
|
||||
Cpushout_functor_list (l₂ ++ l₁) = Cpushout_functor_list l₂ ∘ Cpushout_functor_list l₁ :=
|
||||
realize_append (λa b c d h g f, assoc f g h) (λa b f, id_left f) l₂ l₁
|
||||
|
||||
theorem Cpushout_functor_list_rel {l l' : paths R x x'} (q : Q l l') :
|
||||
Cpushout_functor_list l = Cpushout_functor_list l' :=
|
||||
begin
|
||||
induction q,
|
||||
{ rewrite [Cpushout_functor_list_pair, Cpushout_functor_list_singleton],
|
||||
exact (respect_comp H g f)⁻¹},
|
||||
{ rewrite [Cpushout_functor_list_pair, Cpushout_functor_list_singleton],
|
||||
exact (respect_comp K g f)⁻¹},
|
||||
{ rewrite [Cpushout_functor_list_pair, Cpushout_functor_list_nil],
|
||||
exact ap010 natural_map (to_left_inverse η) s},
|
||||
{ rewrite [Cpushout_functor_list_pair, Cpushout_functor_list_nil],
|
||||
exact ap010 natural_map (to_right_inverse η) s},
|
||||
{ rewrite [Cpushout_functor_list_singleton, Cpushout_functor_list_nil], exact respect_id H d},
|
||||
{ rewrite [Cpushout_functor_list_singleton, Cpushout_functor_list_nil], exact respect_id K e},
|
||||
{ rewrite [+Cpushout_functor_list_pair], exact naturality (to_hom η) h},
|
||||
{ rewrite [+Cpushout_functor_list_pair], exact (naturality (to_inv η) h)⁻¹}
|
||||
end
|
||||
|
||||
definition Cpushout_functor_hom [unfold 12] (f : x ⟶ x') :
|
||||
Cpushout_functor_ob x ⟶ Cpushout_functor_ob x' :=
|
||||
begin
|
||||
induction f with l l l' q,
|
||||
{ exact Cpushout_functor_list l},
|
||||
{ esimp at *, induction q with q, refine realize_eq _ _ _ q,
|
||||
{ intros, apply assoc},
|
||||
{ intros, apply id_left},
|
||||
intro a₁ a₂ l₁ l₁ q, exact Cpushout_functor_list_rel q}
|
||||
end
|
||||
|
||||
definition Cpushout_functor [constructor] : Cpushout ⇒ X :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ exact Cpushout_functor_ob},
|
||||
{ exact Cpushout_functor_hom},
|
||||
{ intro x, reflexivity},
|
||||
{ intro x₁ x₂ x₃ g f,
|
||||
induction g using set_quotient.rec_prop with l₂,
|
||||
induction f using set_quotient.rec_prop with l₁,
|
||||
exact Cpushout_functor_list_append l₂ l₁}
|
||||
end
|
||||
|
||||
definition Cpushout_functor_inl [constructor] : Cpushout_functor ∘f Cpushout_inl ≅ H :=
|
||||
begin
|
||||
fapply natural_iso.mk,
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro d, exact id},
|
||||
{ intro d d' f, rewrite [▸*, Cpushout_functor_list_singleton], apply comp_id_eq_id_comp}},
|
||||
esimp, exact _
|
||||
end
|
||||
|
||||
definition Cpushout_functor_inr [constructor] : Cpushout_functor ∘f Cpushout_inr ≅ K :=
|
||||
begin
|
||||
fapply natural_iso.mk,
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro d, exact id},
|
||||
{ intro d d' f, rewrite [▸*, Cpushout_functor_list_singleton], apply comp_id_eq_id_comp}},
|
||||
esimp, exact _
|
||||
end
|
||||
|
||||
definition Cpushout_functor_coh (c : C) : natural_map (to_hom Cpushout_functor_inr) (G c) ∘
|
||||
Cpushout_functor (natural_map (to_hom Cpushout_coh) c) ∘
|
||||
natural_map (to_inv Cpushout_functor_inl) (F c) = natural_map (to_hom η) c :=
|
||||
!id_leftright ⬝ !Cpushout_functor_list_singleton
|
||||
|
||||
definition Cpushout_functor_unique_ob [unfold 13] (L : Cpushout ⇒ X) (η₁ : L ∘f Cpushout_inl ≅ H)
|
||||
(η₂ : L ∘f Cpushout_inr ≅ K) (x : Cpushout) : L x ⟶ Cpushout_functor x :=
|
||||
begin
|
||||
induction x with d e,
|
||||
{ exact natural_map (to_hom η₁) d},
|
||||
{ exact natural_map (to_hom η₂) e}
|
||||
end
|
||||
|
||||
definition Cpushout_functor_unique_inv_ob [unfold 13] (L : Cpushout ⇒ X)
|
||||
(η₁ : L ∘f Cpushout_inl ≅ H) (η₂ : L ∘f Cpushout_inr ≅ K) (x : Cpushout) :
|
||||
Cpushout_functor x ⟶ L x :=
|
||||
begin
|
||||
induction x with d e,
|
||||
{ exact natural_map (to_inv η₁) d},
|
||||
{ exact natural_map (to_inv η₂) e}
|
||||
end
|
||||
|
||||
definition Cpushout_functor_unique_nat_singleton (L : Cpushout ⇒ X) (η₁ : L ∘f Cpushout_inl ≅ H)
|
||||
(η₂ : L ∘f Cpushout_inr ≅ K)
|
||||
(p : Πs, natural_map (to_hom η₂) (to_fun_ob G s) ∘
|
||||
to_fun_hom L (natural_map (to_hom Cpushout_coh) s) ∘
|
||||
natural_map (to_inv η₁) (to_fun_ob F s) = natural_map (to_hom η) s) (r : R x x') :
|
||||
Cpushout_functor_reduction_rule r ∘ Cpushout_functor_unique_ob L η₁ η₂ x =
|
||||
Cpushout_functor_unique_ob L η₁ η₂ x' ∘ L (class_of [r]) :=
|
||||
begin
|
||||
induction r,
|
||||
{ exact naturality (to_hom η₁) f},
|
||||
{ exact naturality (to_hom η₂) g},
|
||||
{ refine ap (λx, x ∘ _) (p s)⁻¹ ⬝ _, refine !assoc' ⬝ _, apply ap (λx, _ ∘ x),
|
||||
refine !assoc' ⬝ _ ⬝ !id_right, apply ap (λx, _ ∘ x),
|
||||
exact ap010 natural_map (to_left_inverse η₁) (F s)},
|
||||
{ apply comp.cancel_left (to_hom (componentwise_iso η s)),
|
||||
refine !assoc ⬝ _ ⬝ ap (λx, x ∘ _) (p s),
|
||||
refine ap (λx, x ∘ _) (ap010 natural_map (to_right_inverse η) s) ⬝ _ ⬝ !assoc,
|
||||
refine !id_left ⬝ !id_right⁻¹ ⬝ _, apply ap (λx, _ ∘ x),
|
||||
refine _ ⬝ ap (λx, _ ∘ x) (ap (λx, x ∘ _) _⁻¹ ⬝ !assoc') ⬝ !assoc,
|
||||
rotate 2, exact ap010 natural_map (to_left_inverse η₁) (F s),
|
||||
refine _⁻¹ ⬝ ap (λx, _ ∘ x) !id_left⁻¹, refine (respect_comp L _ _)⁻¹ ⬝ _ ⬝ respect_id L _,
|
||||
apply ap (to_fun_hom L), refine eq_of_rel (tr (paths_rel_of_Q _)), apply EDE},
|
||||
end
|
||||
|
||||
definition Cpushout_functor_unique [constructor] (L : Cpushout ⇒ X) (η₁ : L ∘f Cpushout_inl ≅ H)
|
||||
(η₂ : L ∘f Cpushout_inr ≅ K)
|
||||
(p : Πs, natural_map (to_hom η₂) (to_fun_ob G s) ∘
|
||||
to_fun_hom L (natural_map (to_hom Cpushout_coh) s) ∘
|
||||
natural_map (to_inv η₁) (to_fun_ob F s) = natural_map (to_hom η) s) :
|
||||
L ≅ Cpushout_functor :=
|
||||
begin
|
||||
fapply natural_iso.MK,
|
||||
{ exact Cpushout_functor_unique_ob L η₁ η₂},
|
||||
{ intro x x' f, induction f using set_quotient.rec_prop with l,
|
||||
esimp, induction l with x x₁ x₂ x₃ r l IH,
|
||||
{ refine !id_left ⬝ !id_right⁻¹ ⬝ _⁻¹, apply ap (λx, _ ∘ x), apply respect_id},
|
||||
{ rewrite [Cpushout_functor_list_cons, assoc', ▸*, IH, assoc, ▸*,
|
||||
Cpushout_functor_unique_nat_singleton L η₁ η₂ p r, ▸*, assoc', -respect_comp L]}},
|
||||
{ exact Cpushout_functor_unique_inv_ob L η₁ η₂},
|
||||
{ intro x, induction x with d e,
|
||||
{ exact ap010 natural_map (to_left_inverse η₁) d},
|
||||
{ exact ap010 natural_map (to_left_inverse η₂) e}},
|
||||
{ intro x, induction x with d e,
|
||||
{ exact ap010 natural_map (to_right_inverse η₁) d},
|
||||
{ exact ap010 natural_map (to_right_inverse η₂) e}},
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
open bpushout_prehom_index prod prod.ops is_equiv equiv
|
||||
definition Cpushout_universal {C D E : Precategory} {X : Category} (F : C ⇒ D) (G : C ⇒ E)
|
||||
(H : D ⇒ X) (K : E ⇒ X) (η : H ∘f F ≅ K ∘f G) :
|
||||
is_contr (Σ(L : Cpushout F G ⇒ X) (θ : L ∘f Cpushout_inl F G ≅ H × L ∘f Cpushout_inr F G ≅ K),
|
||||
Πs, natural_map (to_hom θ.2) (to_fun_ob G s) ∘ to_fun_hom L (class_of [DE (λ c, c) F G s]) ∘
|
||||
natural_map (to_inv θ.1) (to_fun_ob F s) = natural_map (to_hom η) s) :=
|
||||
begin
|
||||
fapply is_contr.mk,
|
||||
{ exact ⟨Cpushout_functor η, (Cpushout_functor_inl η, Cpushout_functor_inr η),
|
||||
Cpushout_functor_coh η⟩},
|
||||
intro v₁, induction v₁ with L v₂, induction v₂ with θ p, induction θ with θ₁ θ₂,
|
||||
fapply sigma_eq,
|
||||
{ esimp, apply eq_of_iso, symmetry, exact Cpushout_functor_unique η L θ₁ θ₂ p},
|
||||
fapply sigma_pathover,
|
||||
{ apply prod_pathover: esimp,
|
||||
{ apply iso_pathover,
|
||||
apply hom_pathover_functor_left_constant_right (precomposition_functor _ _),
|
||||
apply nat_trans_eq, intro d,
|
||||
xrewrite [↑[hom_of_eq], to_right_inv !eq_equiv_iso, ▸*],
|
||||
exact (ap010 natural_map (to_right_inverse θ₁) d)⁻¹},
|
||||
{ apply iso_pathover,
|
||||
apply hom_pathover_functor_left_constant_right (precomposition_functor _ _),
|
||||
apply nat_trans_eq, intro e,
|
||||
xrewrite [↑[hom_of_eq], to_right_inv !eq_equiv_iso, ▸*],
|
||||
exact (ap010 natural_map (to_right_inverse θ₂) e)⁻¹}},
|
||||
apply is_prop.elimo
|
||||
end
|
||||
|
||||
local attribute prod.eq_pr1 prod.eq_pr2 [reducible]
|
||||
definition Cpushout_equiv {C D E : Precategory} {X : Category} (F : C ⇒ D) (G : C ⇒ E) :
|
||||
(Cpushout F G ⇒ X) ≃ Σ(H : (D ⇒ X) × (E ⇒ X)), H.1 ∘f F ≅ H.2 ∘f G :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro K, refine ⟨(K ∘f Cpushout_inl F G, K ∘f Cpushout_inr F G), _⟩,
|
||||
exact !assoc_iso⁻¹ⁱ ⬝i (K ∘fi Cpushout_coh F G) ⬝i !assoc_iso},
|
||||
{ intro v, cases v with w η, cases w with K L, exact Cpushout_functor η},
|
||||
{ exact abstract begin intro v, cases v with w η, cases w with K L, esimp at *,
|
||||
fapply sigma_eq,
|
||||
{ fapply prod_eq: esimp; apply eq_of_iso,
|
||||
{ exact Cpushout_functor_inl η},
|
||||
{ exact Cpushout_functor_inr η}},
|
||||
esimp, apply iso_pathover, apply hom_pathover,
|
||||
rewrite [ap_compose' _ pr₁, ap_compose' _ pr₂, prod_eq_pr1, prod_eq_pr2],
|
||||
rewrite [-+respect_hom_of_eq (precomposition_functor _ _), +hom_of_eq_eq_of_iso],
|
||||
apply nat_trans_eq, intro c, esimp [category.to_precategory],
|
||||
rewrite [+id_left, +id_right, Cpushout_functor_list_singleton] end end},
|
||||
{ exact abstract begin intro K, esimp,
|
||||
refine eq_base_of_is_prop_sigma _ !is_trunc_succ _ _, rotate 1,
|
||||
{ refine Cpushout_universal F G (K ∘f Cpushout_inl F G) (K ∘f Cpushout_inr F G) _,
|
||||
exact !assoc_iso⁻¹ⁱ ⬝i (K ∘fi Cpushout_coh F G) ⬝i !assoc_iso},
|
||||
{ esimp, fconstructor, esimp, split,
|
||||
{ fapply natural_iso.mk',
|
||||
{ intro c, reflexivity},
|
||||
{ intro c c' f, rewrite [▸*, id_right, Cpushout_functor_list_singleton, id_left]}},
|
||||
{ fapply natural_iso.mk',
|
||||
{ intro c, reflexivity},
|
||||
{ intro c c' f, rewrite [▸*, id_right, Cpushout_functor_list_singleton, id_left]}},
|
||||
intro c, rewrite [▸*, id_left, id_right, Cpushout_functor_list_singleton]},
|
||||
{ esimp, fconstructor,
|
||||
{ split: reflexivity},
|
||||
intro c, reflexivity} end end}
|
||||
end
|
||||
|
||||
/- Pushout of groupoids with a type of basepoints -/
|
||||
section
|
||||
variables {S : Type} {C D E : Groupoid} (k : S → C) (F : C ⇒ D) (G : C ⇒ E)
|
||||
variables ⦃x x' x₁ x₂ x₃ x₄ : Precategory_bpushout k F G⦄
|
||||
open bpushout_prehom_index paths.paths_rel bpushout_hom_rel_index
|
||||
definition bpushout_index_inv [unfold 8] (i : bpushout_prehom_index k F G x x') :
|
||||
bpushout_prehom_index k F G x' x :=
|
||||
begin
|
||||
induction i,
|
||||
{ exact iD k F G f⁻¹},
|
||||
{ exact iE k F G g⁻¹},
|
||||
{ exact ED k F G s},
|
||||
{ exact DE k F G s},
|
||||
end
|
||||
|
||||
theorem bpushout_index_reverse {l l' : bpushout_prehom k F G x x'}
|
||||
(q : bpushout_hom_rel_index k F G l l') : paths_rel (bpushout_hom_rel_index k F G)
|
||||
(reverse (bpushout_index_inv k F G) l) (reverse (bpushout_index_inv k F G) l') :=
|
||||
begin
|
||||
induction q: apply paths_rel_of_Q;
|
||||
try rewrite reverse_singleton; rewrite *reverse_pair; try rewrite reverse_nil; esimp;
|
||||
try rewrite [comp_inverse]; try rewrite [id_inverse]; rewrite [-*respect_inv]; constructor
|
||||
end
|
||||
|
||||
theorem bpushout_index_li (i : bpushout_prehom_index k F G x x') :
|
||||
paths_rel (bpushout_hom_rel_index k F G) [bpushout_index_inv k F G i, i] nil :=
|
||||
begin
|
||||
induction i: esimp,
|
||||
{ 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 bpushout_index_ri (i : bpushout_prehom_index k F G x x') :
|
||||
paths_rel (bpushout_hom_rel_index k F G) [i, bpushout_index_inv k F G i] nil :=
|
||||
begin
|
||||
induction i: esimp,
|
||||
{ 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_bpushout [constructor] : Groupoid :=
|
||||
Groupoid_paths (bpushout_hom_rel_index k F G) (bpushout_index_inv k F G)
|
||||
(bpushout_index_reverse k F G) (bpushout_index_li k F G) (bpushout_index_ri k F G)
|
||||
|
||||
definition Gpushout [constructor] : Groupoid :=
|
||||
Groupoid_bpushout (λc, c) F G
|
||||
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,441 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2016 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Jakob von Raumer
|
||||
|
||||
The Rezk completion
|
||||
-/
|
||||
|
||||
import algebra.category hit.two_quotient types.trunc types.arrow algebra.category.functor.attributes
|
||||
|
||||
open eq category equiv trunc_two_quotient is_trunc iso e_closure function pi trunctype
|
||||
|
||||
namespace rezk
|
||||
section
|
||||
|
||||
universes l k
|
||||
parameters {A : Type.{l}} [C : precategory.{l k} A]
|
||||
include C
|
||||
|
||||
inductive rezk_Q : Π ⦃a b : A⦄, e_closure iso a b → e_closure iso a b → Type :=
|
||||
| comp_con : Π ⦃a b c : A⦄ (g : b ≅ c) (f : a ≅ b) , rezk_Q [f ⬝i g] ([f] ⬝r [g])
|
||||
|
||||
definition rezk_carrier := trunc_two_quotient 1 iso rezk_Q
|
||||
|
||||
local attribute rezk_carrier [reducible]
|
||||
definition is_trunc_rezk_carrier [instance] : is_trunc 1 rezk_carrier := _
|
||||
|
||||
variables {a b c : A}
|
||||
definition elt (a : A) : rezk_carrier := incl0 a
|
||||
definition pth (f : a ≅ b) : elt a = elt b := incl1 f
|
||||
|
||||
definition resp_comp (g : b ≅ c) (f : a ≅ b) : pth (f ⬝i g) = pth f ⬝ pth g :=
|
||||
incl2 (rezk_Q.comp_con g f)
|
||||
|
||||
definition resp_id (a : A) : pth (iso.refl a) = idp :=
|
||||
begin
|
||||
apply cancel_right (pth (iso.refl a)), refine _ ⬝ !idp_con⁻¹,
|
||||
refine !resp_comp⁻¹ ⬝ _,
|
||||
apply ap pth, apply iso_eq, apply id_left,
|
||||
end
|
||||
|
||||
protected definition rec {P : rezk_carrier → Type} [Π x, is_trunc 1 (P x)]
|
||||
(Pe : Π a, P (elt a)) (Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a =[pth f] Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b),
|
||||
change_path (resp_comp g f) (Pp (f ⬝i g)) = Pp f ⬝o Pp g)
|
||||
(x : rezk_carrier) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ apply Pe },
|
||||
{ apply Pp },
|
||||
{ induction q with a b c g f, apply Pcomp }
|
||||
end
|
||||
|
||||
protected definition rec_on {P : rezk_carrier → Type} [Π x, is_trunc 1 (P x)]
|
||||
(x : rezk_carrier)
|
||||
(Pe : Π a, P (elt a)) (Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a =[pth f] Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b),
|
||||
change_path (resp_comp g f) (Pp (f ⬝i g)) = Pp f ⬝o Pp g) : P x :=
|
||||
rec Pe Pp Pcomp x
|
||||
|
||||
protected definition set_rec {P : rezk_carrier → Type} [Π x, is_set (P x)]
|
||||
(Pe : Π a, P (elt a)) (Pp : Π⦃a b⦄ (f : a ≅ b), Pe a =[pth f] Pe b)
|
||||
(x : rezk_carrier) : P x :=
|
||||
rec Pe Pp !center x
|
||||
|
||||
protected definition prop_rec {P : rezk_carrier → Type} [Π x, is_prop (P x)]
|
||||
(Pe : Π a, P (elt a)) (x : rezk_carrier) : P x :=
|
||||
rec Pe !center !center x
|
||||
|
||||
protected definition elim {P : Type} [is_trunc 1 P] (Pe : A → P)
|
||||
(Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a = Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b), Pp (f ⬝i g) = Pp f ⬝ Pp g)
|
||||
(x : rezk_carrier) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact Pe a },
|
||||
{ exact Pp s },
|
||||
{ induction q with a b c g f, exact Pcomp g f }
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} [is_trunc 1 P] (x : rezk_carrier)
|
||||
(Pe : A → P) (Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a = Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b), Pp (f ⬝i g) = Pp f ⬝ Pp g) : P :=
|
||||
elim Pe Pp Pcomp x
|
||||
|
||||
protected definition set_elim [reducible] {P : Type} [is_set P] (Pe : A → P)
|
||||
(Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a = Pe b) (x : rezk_carrier) : P :=
|
||||
elim Pe Pp !center x
|
||||
|
||||
protected definition prop_elim [reducible] {P : Type} [is_prop P] (Pe : A → P)
|
||||
(x : rezk_carrier) : P :=
|
||||
elim Pe !center !center x
|
||||
|
||||
definition elim_pth {P : Type} [is_trunc 1 P] {Pe : A → P} {Pp : Π⦃a b⦄ (f : a ≅ b), Pe a = Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ≅ c) (f : a ≅ b), Pp (f ⬝i g) = Pp f ⬝ Pp g) {a b : A} (f : a ≅ b) :
|
||||
ap (elim Pe Pp Pcomp) (pth f) = Pp f :=
|
||||
!elim_incl1
|
||||
|
||||
--TODO generalize this to arbitrary truncated two-quotients or not?
|
||||
protected definition elim_set.{m} [reducible] (Pe : A → Set.{m}) (Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a ≃ Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b) (x : Pe a), Pp (f ⬝i g) x = Pp g (Pp f x))
|
||||
(x : rezk_carrier) : Set.{m} :=
|
||||
elim Pe (λa b f, tua (Pp f)) (λa b c g f, ap tua (equiv_eq (Pcomp g f)) ⬝ !tua_trans) x
|
||||
|
||||
protected definition elim_set_pt.{m} [reducible] (Pe : A → Set.{m}) (Pp : Π ⦃a b⦄ (f : a ≅ b), Pe a ≃ Pe b)
|
||||
(Pcomp : Π ⦃a b c⦄ (g : b ≅ c) (f : a ≅ b) (x : Pe a), Pp (f ⬝i g) x = Pp g (Pp f x))
|
||||
(a : A) : trunctype.carrier (rezk.elim_set Pe Pp Pcomp (elt a)) = Pe a :=
|
||||
idp
|
||||
|
||||
protected theorem elim_set_pth {Pe : A → Set} {Pp : Π⦃a b⦄ (f : a ≅ b), Pe a ≃ Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ≅ c) (f : a ≅ b) (x : Pe a), Pp (f ⬝i g) x = Pp g (Pp f x))
|
||||
{a b : A} (f : a ≅ b) :
|
||||
transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
|
||||
begin
|
||||
rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*],
|
||||
rewrite [ap_compose' trunctype.carrier, elim_pth], apply tcast_tua_fn
|
||||
end
|
||||
|
||||
end
|
||||
end rezk open rezk
|
||||
|
||||
attribute rezk.elt [constructor]
|
||||
attribute rezk.rec rezk.elim [unfold 8] [recursor 8]
|
||||
attribute rezk.rec_on rezk.elim_on [unfold 5]
|
||||
attribute rezk.set_rec rezk.set_elim [unfold 7]
|
||||
attribute rezk.prop_rec rezk.prop_elim
|
||||
rezk.elim_set [unfold 6]
|
||||
|
||||
namespace rezk
|
||||
section
|
||||
universes l k
|
||||
parameters (A : Type.{l}) (C : precategory.{l k} A)
|
||||
|
||||
definition rezk_hom_left_pt [constructor] (a : A) (b : @rezk_carrier A C) : Set.{k} :=
|
||||
begin
|
||||
refine rezk.elim_set _ _ _ b,
|
||||
{ clear b, intro b, exact trunctype.mk' 0 (hom a b) },
|
||||
{ clear b, intro b b' f, apply equiv_postcompose (iso.to_hom f) },
|
||||
{ clear b, intro b b' b'' f g x, apply !assoc⁻¹ }
|
||||
end
|
||||
|
||||
private definition pathover_rezk_hom_left_pt {a b c : A} (f : hom a b) (g : b ≅ c) :
|
||||
pathover (rezk_hom_left_pt a) f (pth g) ((to_hom g) ∘ f) :=
|
||||
begin
|
||||
apply pathover_of_tr_eq, apply @homotopy_of_eq _ _ _ (λ f, (to_hom g) ∘ f),
|
||||
apply rezk.elim_set_pth,
|
||||
end
|
||||
|
||||
definition rezk_hom_left_pth_1_trunc [instance] (a a' : A) (f : a ≅ a') :
|
||||
Π b, is_trunc 1 (carrier (rezk_hom_left_pt a b) ≃ carrier (rezk_hom_left_pt a' b)) :=
|
||||
λ b, is_trunc_equiv _ _ _
|
||||
|
||||
definition rezk_hom_left_pth (a a' : A) (f : a ≅ a') (b : rezk_carrier) :
|
||||
carrier (rezk_hom_left_pt a b) ≃ carrier (rezk_hom_left_pt a' b) :=
|
||||
begin
|
||||
--induction b using rezk.rec with b' b' b g, --why does this not work if it works below?
|
||||
refine @rezk.rec _ _ _ (rezk_hom_left_pth_1_trunc a a' f) _ _ _ b,
|
||||
intro b, apply equiv_precompose (to_hom f⁻¹ⁱ), --how do i unfold properly at this point?
|
||||
{ intro b b' g, apply equiv_pathover, intro g' g'' H,
|
||||
refine !pathover_rezk_hom_left_pt ⬝op _,
|
||||
refine !assoc ⬝ ap (λ x, x ∘ _) _, refine eq_of_parallel_po_right _ H,
|
||||
apply pathover_rezk_hom_left_pt },
|
||||
intro b b' b'' g g', apply @is_prop.elim, apply is_trunc_pathover, apply is_trunc_equiv
|
||||
end
|
||||
|
||||
definition rezk_hom [unfold 3 4] (a b : @rezk_carrier A C) : Set.{k} :=
|
||||
begin
|
||||
refine rezk.elim_set _ _ _ a,
|
||||
{ clear a, intro a, exact rezk_hom_left_pt a b },
|
||||
{ clear a, intro a a' f, apply rezk_hom_left_pth a a' f },
|
||||
{ clear a, intro a a' a'' Ef Eg Rfg, induction b using rezk.rec,
|
||||
apply assoc, apply is_prop.elimo, apply is_set.elimo }
|
||||
end
|
||||
|
||||
private definition pathover_rezk_hom_left {a b c : A} (f : hom a c) (g : a ≅ b) :
|
||||
pathover (λ x, rezk_hom x (elt c)) f (pth g) (f ∘ (to_hom g)⁻¹) :=
|
||||
begin
|
||||
apply pathover_of_tr_eq, apply @homotopy_of_eq _ _ _ (λ f, f ∘ (to_hom g)⁻¹),
|
||||
apply rezk.elim_set_pth,
|
||||
end
|
||||
|
||||
private definition pathover_rezk_hom_right {a b c : A} (f : hom a b) (g : b ≅ c) : --todo delete?
|
||||
pathover (rezk_hom (elt a)) f (pth g) ((to_hom g) ∘ f) :=
|
||||
begin
|
||||
apply pathover_rezk_hom_left_pt,
|
||||
end
|
||||
|
||||
private definition transport_rezk_hom_eq_comp {a c : A} (f : hom a a) (g : a ≅ c) :
|
||||
transport (λ x, rezk_hom x x) (pth g) f = (to_hom g) ∘ f ∘ (to_hom g)⁻¹ :=
|
||||
begin
|
||||
apply concat, apply tr_diag_eq_tr_tr rezk_hom,
|
||||
apply concat, apply ap (λ x, _ ▸ x),
|
||||
apply tr_eq_of_pathover, apply pathover_rezk_hom_left,
|
||||
apply tr_eq_of_pathover, apply pathover_rezk_hom_left_pt
|
||||
end
|
||||
|
||||
definition rezk_id (a : @rezk_carrier A C) : rezk_hom a a :=
|
||||
begin
|
||||
induction a using rezk.rec,
|
||||
apply id,
|
||||
{ apply pathover_of_tr_eq, refine !transport_rezk_hom_eq_comp ⬝ _,
|
||||
refine (ap (λ x, to_hom f ∘ x) !id_left) ⬝ _, apply right_inverse },
|
||||
apply is_set.elimo
|
||||
end
|
||||
|
||||
definition rezk_comp_pt_pt [reducible] {c : rezk_carrier} {a b : A}
|
||||
(g : carrier (rezk_hom (elt b) c))
|
||||
(f : carrier (rezk_hom (elt a) (elt b))) : carrier (rezk_hom (elt a) c) :=
|
||||
begin
|
||||
induction c using rezk.set_rec with c c c' ic,
|
||||
exact g ∘ f,
|
||||
{ apply arrow_pathover_left, intro d,
|
||||
apply concato !pathover_rezk_hom_left_pt, apply pathover_idp_of_eq,
|
||||
apply concat, apply assoc, apply ap (λ x, x ∘ f),
|
||||
apply inverse, apply tr_eq_of_pathover, apply pathover_rezk_hom_left_pt },
|
||||
end
|
||||
|
||||
definition rezk_comp_pt_pth [reducible] {c : rezk_carrier} {a b b' : A} {ib : iso b b'} :
|
||||
pathover (λ b, carrier (rezk_hom b c) → carrier (rezk_hom (elt a) b) → carrier (rezk_hom (elt a) c))
|
||||
(λ g f, rezk_comp_pt_pt g f) (pth ib) (λ g f, rezk_comp_pt_pt g f) :=
|
||||
begin
|
||||
apply arrow_pathover_left, intro x,
|
||||
apply arrow_pathover_left, intro y,
|
||||
induction c using rezk.set_rec with c c c' ic,
|
||||
{ apply pathover_of_eq, apply inverse,
|
||||
apply concat, apply ap (λ x, rezk_comp_pt_pt x _), apply tr_eq_of_pathover,
|
||||
apply pathover_rezk_hom_left,
|
||||
apply concat, apply ap (rezk_comp_pt_pt _), apply tr_eq_of_pathover,
|
||||
apply pathover_rezk_hom_left_pt,
|
||||
refine !assoc ⬝ ap (λ x, x ∘ y) _,
|
||||
refine !assoc⁻¹ ⬝ _,
|
||||
refine ap (λ y, x ∘ y) !iso.left_inverse ⬝ _,
|
||||
apply id_right },
|
||||
apply @is_prop.elimo
|
||||
end
|
||||
|
||||
definition rezk_comp {a b c : @rezk_carrier A C} (g : rezk_hom b c) (f : rezk_hom a b) :
|
||||
rezk_hom a c :=
|
||||
begin
|
||||
induction a using rezk.set_rec with a a a' ia,
|
||||
{ induction b using rezk.set_rec with b b b' ib,
|
||||
apply rezk_comp_pt_pt g f, apply rezk_comp_pt_pth },
|
||||
{ induction b using rezk.set_rec with b b b' ib,
|
||||
apply arrow_pathover_left, intro f,
|
||||
induction c using rezk.set_rec with c c c' ic,
|
||||
{ apply concato, apply pathover_rezk_hom_left,
|
||||
apply pathover_idp_of_eq, refine !assoc⁻¹ ⬝ ap (λ x, g ∘ x) _⁻¹,
|
||||
apply tr_eq_of_pathover, apply pathover_rezk_hom_left },
|
||||
apply is_prop.elimo,
|
||||
apply is_prop.elimo }
|
||||
end
|
||||
|
||||
definition is_set_rezk_hom [instance] (a b : @rezk_carrier A C) : is_set (rezk_hom a b) :=
|
||||
_
|
||||
|
||||
protected definition id_left {a b : @rezk_carrier A C} (f : rezk_hom a b) :
|
||||
rezk_comp (rezk_id b) f = f :=
|
||||
begin
|
||||
induction a using rezk.prop_rec with a a a' ia,
|
||||
induction b using rezk.prop_rec with b b b' ib,
|
||||
apply id_left,
|
||||
end
|
||||
|
||||
protected definition id_right {a b : @rezk_carrier A C} (f : rezk_hom a b) :
|
||||
rezk_comp f (rezk_id a) = f :=
|
||||
begin
|
||||
induction a using rezk.prop_rec with a a a' ia,
|
||||
induction b using rezk.prop_rec with b b b' ib,
|
||||
apply id_right,
|
||||
end
|
||||
|
||||
protected definition assoc {a b c d : @rezk_carrier A C} (h : rezk_hom c d)
|
||||
(g : rezk_hom b c) (f : rezk_hom a b) :
|
||||
rezk_comp h (rezk_comp g f) = rezk_comp (rezk_comp h g) f :=
|
||||
begin
|
||||
induction a using rezk.prop_rec with a a a' ia,
|
||||
induction b using rezk.prop_rec with b b b' ib,
|
||||
induction c using rezk.prop_rec with c c c' ic,
|
||||
induction d using rezk.prop_rec with d d d' id,
|
||||
apply assoc,
|
||||
end
|
||||
|
||||
definition rezk_precategory [instance] : precategory (@rezk_carrier A C) :=
|
||||
precategory.mk rezk_hom @rezk_comp rezk_id @assoc @id_left @id_right
|
||||
|
||||
end
|
||||
|
||||
definition to_rezk_Precategory.{l k} : Precategory.{l k} → Precategory.{(max l k) k} :=
|
||||
begin
|
||||
intro C, apply Precategory.mk (@rezk_carrier (Precategory.carrier C) C),
|
||||
apply rezk_precategory _ _,
|
||||
end
|
||||
|
||||
definition rezk_functor [constructor] (C : Precategory) : functor C (to_rezk_Precategory C) :=
|
||||
begin
|
||||
fapply functor.mk, apply elt,
|
||||
{ intro a b f, exact f },
|
||||
do 2 (intros; reflexivity)
|
||||
end
|
||||
|
||||
section
|
||||
parameters {A : Type} [C : precategory A]
|
||||
include C
|
||||
|
||||
protected definition elt_iso_of_iso [reducible] {a b : A} (f : a ≅ b) : elt a ≅ elt b :=
|
||||
begin
|
||||
fapply iso.mk, apply to_hom f, apply functor.preserve_is_iso (rezk_functor _)
|
||||
end
|
||||
|
||||
protected definition iso_of_elt_iso [reducible] {a b : A} (f : elt a ≅ elt b) : a ≅ b :=
|
||||
begin
|
||||
cases f with f Hf, cases Hf with inv linv rinv,
|
||||
fapply iso.mk, exact f, fapply is_iso.mk, exact inv, exact linv, exact rinv
|
||||
end
|
||||
|
||||
protected definition iso_of_elt_iso_distrib {a b c : A} (f : elt a ≅ elt b) (g : elt b ≅ elt c) :
|
||||
iso_of_elt_iso (f ⬝i g) = (iso_of_elt_iso f) ⬝i (iso_of_elt_iso g) :=
|
||||
begin
|
||||
cases g with g Hg, cases Hg with invg linvg rinvg,
|
||||
cases f with f Hf, cases Hf with invf linvf rinvf,
|
||||
reflexivity
|
||||
end
|
||||
|
||||
protected definition iso_equiv_elt_iso (a b : A) : (a ≅ b) ≃ (elt a ≅ elt b) :=
|
||||
begin
|
||||
fapply equiv.MK, apply elt_iso_of_iso, apply iso_of_elt_iso,
|
||||
{ intro f, cases f with f Hf, cases Hf with inv linv rinv, fapply iso_eq, reflexivity },
|
||||
{ intro f, fapply iso_eq, reflexivity }
|
||||
end
|
||||
|
||||
private definition hom_transport_eq_transport_hom {a b b' : @rezk_carrier A C} (f : a ≅ b)
|
||||
(p : b = b') : to_hom (transport (iso a) p f) = transport (λ x, hom _ _) p (to_hom f) :=
|
||||
by cases p; reflexivity
|
||||
|
||||
private definition hom_transport_eq_transport_hom' {a a' b : @rezk_carrier A C} (f : a ≅ b)
|
||||
(p : a = a') : to_hom (transport (λ x, iso x b) p f) = transport (λ x, hom _ _) p (to_hom f) :=
|
||||
by cases p; reflexivity
|
||||
|
||||
private definition pathover_iso_pth {a b b' : A} (f : elt a ≅ elt b)
|
||||
(ib : b ≅ b') : pathover (λ x, iso (elt a) x) f (pth ib) (f ⬝i elt_iso_of_iso ib) :=
|
||||
begin
|
||||
apply pathover_of_tr_eq, apply iso_eq,
|
||||
apply concat, apply hom_transport_eq_transport_hom,
|
||||
apply tr_eq_of_pathover, apply pathover_rezk_hom_right A C
|
||||
end
|
||||
|
||||
private definition pathover_iso_pth' {a a' b : A} (f : elt a ≅ elt b)
|
||||
(ia : a ≅ a') : pathover (λ x, iso x (elt b)) f (pth ia) (elt_iso_of_iso (iso.symm ia) ⬝i f) :=
|
||||
begin
|
||||
apply pathover_of_tr_eq, apply iso_eq,
|
||||
apply concat, apply hom_transport_eq_transport_hom',
|
||||
apply tr_eq_of_pathover, apply pathover_rezk_hom_left A C
|
||||
end
|
||||
|
||||
private definition eq_of_iso_pt {a : A} {b : @rezk_carrier A C} :
|
||||
elt a ≅ b → elt a = b :=
|
||||
begin
|
||||
intro f,
|
||||
induction b using rezk.set_rec with b b b' ib,
|
||||
apply pth, apply iso_of_elt_iso f,
|
||||
apply arrow_pathover, intro f g p, apply eq_pathover,
|
||||
refine !ap_constant ⬝ph _ ⬝hp !ap_id⁻¹, apply square_of_eq,
|
||||
refine !resp_comp⁻¹ ⬝ (ap pth _)⁻¹ ⬝ !idp_con⁻¹,
|
||||
apply concat, apply inverse, apply ap rezk.iso_of_elt_iso,
|
||||
apply eq_of_parallel_po_right (pathover_iso_pth _ _) p,
|
||||
apply concat, apply iso_of_elt_iso_distrib,
|
||||
apply ap (λ x, _ ⬝i x), apply equiv.to_left_inv !iso_equiv_elt_iso
|
||||
end
|
||||
|
||||
protected definition eq_of_iso {a b : @rezk_carrier A C} :
|
||||
a ≅ b → a = b :=
|
||||
begin
|
||||
intro f,
|
||||
induction a using rezk.set_rec with a a a' ia,
|
||||
apply eq_of_iso_pt f,
|
||||
{ induction b using rezk.set_rec with b b b' ib,
|
||||
{ apply arrow_pathover, intro f g p, apply eq_pathover,
|
||||
refine !ap_id ⬝ph _ ⬝hp !ap_constant⁻¹, apply square_of_eq,
|
||||
refine (ap pth _) ⬝ !resp_comp,
|
||||
assert H : g = (elt_iso_of_iso (iso.symm ia) ⬝i f),
|
||||
apply eq_of_parallel_po_right p (pathover_iso_pth' _ _),
|
||||
rewrite H, apply inverse,
|
||||
apply concat, apply ap (λ x, ia ⬝i x), apply iso_of_elt_iso_distrib,
|
||||
apply concat, apply ap (λ x, _ ⬝i (x ⬝i _)), apply equiv.to_left_inv !iso_equiv_elt_iso,
|
||||
apply iso_eq, apply inverse_comp_cancel_right },
|
||||
apply @is_prop.elimo }
|
||||
end
|
||||
|
||||
protected definition eq_of_iso_of_eq (a b : @rezk_carrier A C) (p : a = b) :
|
||||
eq_of_iso (iso_of_eq p) = p :=
|
||||
begin
|
||||
cases p, clear b,
|
||||
induction a using rezk.prop_rec,
|
||||
refine ap pth _ ⬝ !resp_id,
|
||||
apply iso_eq, reflexivity
|
||||
end
|
||||
|
||||
protected definition iso_of_eq_of_iso (a b : @rezk_carrier A C) (f : a ≅ b) :
|
||||
iso_of_eq (eq_of_iso f) = f :=
|
||||
begin
|
||||
induction a using rezk.prop_rec with a,
|
||||
induction b using rezk.prop_rec with b,
|
||||
cases f with f Hf, apply iso_eq,
|
||||
apply concat, apply ap to_hom, apply !transport_iso_of_eq⁻¹,
|
||||
apply concat, apply ap to_hom, apply tr_eq_of_pathover, apply pathover_iso_pth,
|
||||
cases Hf with invf linv rinv, apply id_right,
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
definition rezk_category.{l k} {A : Type.{l}} [C : precategory.{l k} A] :
|
||||
category.{(max l k) k} (@rezk_carrier.{l k} A C) :=
|
||||
begin
|
||||
fapply category.mk (rezk_precategory A C),
|
||||
intros, fapply is_equiv.adjointify,
|
||||
apply rezk.eq_of_iso,
|
||||
apply rezk.iso_of_eq_of_iso,
|
||||
apply rezk.eq_of_iso_of_eq
|
||||
end
|
||||
|
||||
section
|
||||
variable (C : Precategory)
|
||||
|
||||
definition fully_faithful_rezk_functor : fully_faithful (rezk_functor C) :=
|
||||
by intros; apply is_equiv.is_equiv_id
|
||||
|
||||
open trunc
|
||||
definition essentially_surj_rezk_functor : essentially_surjective (rezk_functor C) :=
|
||||
begin
|
||||
intro a, esimp[to_rezk_Precategory] at *,
|
||||
induction a using rezk.prop_rec with a, apply tr,
|
||||
constructor, apply iso.refl (elt a),
|
||||
end
|
||||
|
||||
definition is_weak_equiv_rezk_functor : is_weak_equivalence (rezk_functor C) :=
|
||||
prod.mk (fully_faithful_rezk_functor C) (essentially_surj_rezk_functor C)
|
||||
|
||||
end
|
||||
|
||||
end rezk
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Category of sets
|
||||
-/
|
||||
|
||||
import ..functor.basic ..category types.equiv types.lift
|
||||
|
||||
open eq category equiv iso is_equiv is_trunc function sigma
|
||||
|
||||
namespace category
|
||||
|
||||
definition precategory_Set.{u} [reducible] [constructor] : precategory Set.{u} :=
|
||||
precategory.mk (λx y : Set, x → y)
|
||||
(λx y z g f a, g (f a))
|
||||
(λx a, a)
|
||||
(λx y z w h g f, eq_of_homotopy (λa, idp))
|
||||
(λx y f, eq_of_homotopy (λa, idp))
|
||||
(λx y f, eq_of_homotopy (λa, idp))
|
||||
|
||||
definition Precategory_Set [reducible] [constructor] : Precategory :=
|
||||
Precategory.mk Set precategory_Set
|
||||
|
||||
abbreviation set [constructor] := Precategory_Set
|
||||
|
||||
namespace set
|
||||
local attribute is_equiv_subtype_eq [instance]
|
||||
definition iso_of_equiv [constructor] {A B : set} (f : A ≃ B) : A ≅ B :=
|
||||
iso.MK (to_fun f)
|
||||
(to_inv f)
|
||||
(eq_of_homotopy (left_inv (to_fun f)))
|
||||
(eq_of_homotopy (right_inv (to_fun f)))
|
||||
|
||||
definition equiv_of_iso [constructor] {A B : set} (f : A ≅ B) : A ≃ B :=
|
||||
begin
|
||||
apply equiv.MK (to_hom f) (iso.to_inv f),
|
||||
exact ap10 (to_right_inverse f),
|
||||
exact ap10 (to_left_inverse f)
|
||||
end
|
||||
|
||||
definition is_equiv_iso_of_equiv [constructor] (A B : set)
|
||||
: is_equiv (@iso_of_equiv A B) :=
|
||||
adjointify _ (λf, equiv_of_iso f)
|
||||
(λf, proof iso_eq idp qed)
|
||||
(λf, equiv_eq' idp)
|
||||
|
||||
local attribute is_equiv_iso_of_equiv [instance]
|
||||
|
||||
definition iso_of_eq_eq_compose (A B : Set) : @iso_of_eq _ _ A B =
|
||||
@iso_of_equiv A B ∘ @equiv_of_eq A B ∘ subtype_eq_inv _ _ ∘
|
||||
@ap _ _ (to_fun (trunctype.sigma_char 0)) A B :=
|
||||
eq_of_homotopy (λp, eq.rec_on p idp)
|
||||
|
||||
definition equiv_equiv_iso (A B : set) : (A ≃ B) ≃ (A ≅ B) :=
|
||||
equiv.MK (λf, iso_of_equiv f)
|
||||
(λf, proof equiv.MK (to_hom f)
|
||||
(iso.to_inv f)
|
||||
(ap10 (to_right_inverse f))
|
||||
(ap10 (to_left_inverse f)) qed)
|
||||
(λf, proof iso_eq idp qed)
|
||||
(λf, proof equiv_eq' idp qed)
|
||||
|
||||
definition equiv_eq_iso (A B : set) : (A ≃ B) = (A ≅ B) :=
|
||||
ua !equiv_equiv_iso
|
||||
|
||||
definition is_univalent_Set (A B : set) : is_equiv (iso_of_eq : A = B → A ≅ B) :=
|
||||
have H₁ : is_equiv (@iso_of_equiv A B ∘ @equiv_of_eq A B ∘ subtype_eq_inv _ _ ∘
|
||||
@ap _ _ (to_fun (trunctype.sigma_char 0)) A B), from
|
||||
@is_equiv_compose _ _ _ _ _
|
||||
(@is_equiv_compose _ _ _ _ _
|
||||
(@is_equiv_compose _ _ _ _ _
|
||||
_
|
||||
(@is_equiv_subtype_eq_inv _ _ _ _ _))
|
||||
!univalence)
|
||||
!is_equiv_iso_of_equiv,
|
||||
let H₂ := (iso_of_eq_eq_compose A B)⁻¹ in
|
||||
begin
|
||||
rewrite H₂ at H₁,
|
||||
assumption
|
||||
end
|
||||
end set
|
||||
|
||||
definition category_Set [instance] [constructor] : category Set :=
|
||||
category.mk precategory_Set set.is_univalent_Set
|
||||
|
||||
definition Category_Set [reducible] [constructor] : Category :=
|
||||
Category.mk Set category_Set
|
||||
|
||||
abbreviation cset [constructor] := Category_Set
|
||||
|
||||
open functor lift
|
||||
definition functor_lift.{u v} [constructor] : set.{u} ⇒ set.{max u v} :=
|
||||
functor.mk tlift
|
||||
(λa b, lift_functor)
|
||||
(λa, eq_of_homotopy (λx, by induction x; reflexivity))
|
||||
(λa b c g f, eq_of_homotopy (λx, by induction x; reflexivity))
|
||||
|
||||
|
||||
end category
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Sum precategory and (TODO) category
|
||||
-/
|
||||
|
||||
import ..category ..nat_trans types.sum
|
||||
|
||||
open eq sum is_trunc functor lift nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
--set_option pp.universes true
|
||||
definition sum_hom.{u v w x} [unfold 5 6] {obC : Type.{u}} {obD : Type.{v}}
|
||||
(C : precategory.{u w} obC) (D : precategory.{v x} obD)
|
||||
: obC + obD → obC + obD → Type.{max w x} :=
|
||||
sum.rec (λc, sum.rec (λc', lift (c ⟶ c')) (λd, lift empty))
|
||||
(λd, sum.rec (λc, lift empty) (λd', lift (d ⟶ d')))
|
||||
|
||||
theorem is_set_sum_hom {obC : Type} {obD : Type}
|
||||
(C : precategory obC) (D : precategory obD) (x y : obC + obD)
|
||||
: is_set (sum_hom C D x y) :=
|
||||
by induction x: induction y: esimp at *: exact _
|
||||
|
||||
local attribute is_set_sum_hom [instance]
|
||||
|
||||
definition precategory_sum [constructor] [instance] (obC obD : Type)
|
||||
[C : precategory obC] [D : precategory obD] : precategory (obC + obD) :=
|
||||
precategory.mk (sum_hom C D)
|
||||
(λ a b c g f, begin induction a: induction b: induction c: esimp at *;
|
||||
induction f with f; induction g with g; (contradiction | exact up (g ∘ f)) end)
|
||||
(λ a, by induction a: exact up id)
|
||||
(λ a b c d h g f,
|
||||
abstract begin induction a: induction b: induction c: induction d:
|
||||
esimp at *; induction f with f; induction g with g; induction h with h;
|
||||
esimp at *; try contradiction: apply ap up !assoc end end)
|
||||
(λ a b f, abstract begin induction a: induction b: esimp at *;
|
||||
induction f with f; esimp; try contradiction: exact ap up !id_left end end)
|
||||
(λ a b f, abstract begin induction a: induction b: esimp at *;
|
||||
induction f with f; esimp; try contradiction: exact ap up !id_right end end)
|
||||
|
||||
definition Precategory_sum [constructor] (C D : Precategory) : Precategory :=
|
||||
precategory.Mk (precategory_sum C D)
|
||||
|
||||
infixr ` +c `:65 := Precategory_sum
|
||||
variables {C C' D D' : Precategory}
|
||||
|
||||
definition inl_functor [constructor] : C ⇒ C +c D :=
|
||||
functor.mk inl
|
||||
(λa b, up)
|
||||
(λa, idp)
|
||||
(λa b c g f, idp)
|
||||
|
||||
definition inr_functor [constructor] : D ⇒ C +c D :=
|
||||
functor.mk inr
|
||||
(λa b, up)
|
||||
(λa, idp)
|
||||
(λa b c g f, idp)
|
||||
|
||||
definition sum_functor [constructor] (F : C ⇒ D) (G : C' ⇒ D) : C +c C' ⇒ D :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro a, induction a, exact F a, exact G a},
|
||||
{ intro a b f, induction a: induction b: esimp at *;
|
||||
induction f with f; esimp; try contradiction: (exact F f|exact G f)},
|
||||
{ exact abstract begin intro a, induction a: esimp; apply respect_id end end},
|
||||
{ intros a b c g f, induction a: induction b: induction c: esimp at *;
|
||||
induction f with f; induction g with g; try contradiction:
|
||||
esimp; apply respect_comp}, -- REPORT: abstracting this argument fails
|
||||
end
|
||||
|
||||
infixr ` +f `:65 := sum_functor
|
||||
|
||||
definition sum_functor_eta (F : C +c C' ⇒ D) : F ∘f inl_functor +f F ∘f inr_functor = F :=
|
||||
begin
|
||||
fapply functor_eq: esimp,
|
||||
{ intro a, induction a: reflexivity},
|
||||
{ exact abstract begin esimp, intro a b f,
|
||||
induction a: induction b: esimp at *; induction f with f; esimp;
|
||||
try contradiction: apply id_leftright end end}
|
||||
end
|
||||
|
||||
definition sum_functor_inl (F : C ⇒ D) (G : C' ⇒ D) : (F +f G) ∘f inl_functor = F :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
reflexivity,
|
||||
esimp, intros, apply id_leftright
|
||||
end
|
||||
|
||||
definition sum_functor_inr (F : C ⇒ D) (G : C' ⇒ D) : (F +f G) ∘f inr_functor = G :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
reflexivity,
|
||||
esimp, intros, apply id_leftright
|
||||
end
|
||||
|
||||
definition sum_functor_sum [constructor] (F : C ⇒ D) (G : C' ⇒ D') : C +c C' ⇒ D +c D' :=
|
||||
(inl_functor ∘f F) +f (inr_functor ∘f G)
|
||||
|
||||
definition sum_nat_trans [constructor] {F F' : C ⇒ D} {G G' : C' ⇒ D} (η : F ⟹ F') (θ : G ⟹ G')
|
||||
: F +f G ⟹ F' +f G' :=
|
||||
begin
|
||||
fapply nat_trans.mk,
|
||||
{ intro a, induction a: esimp, exact η a, exact θ a},
|
||||
{ intro a b f, induction a: induction b: esimp at *; induction f with f; esimp;
|
||||
try contradiction: apply naturality}
|
||||
end
|
||||
infixr ` +n `:65 := sum_nat_trans
|
||||
|
||||
end category
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Terminal category
|
||||
-/
|
||||
|
||||
import .indiscrete
|
||||
|
||||
open functor is_trunc unit eq
|
||||
|
||||
namespace category
|
||||
|
||||
definition terminal_precategory [constructor] : precategory unit :=
|
||||
indiscrete_precategory unit
|
||||
|
||||
definition Terminal_precategory [constructor] : Precategory :=
|
||||
precategory.Mk terminal_precategory
|
||||
|
||||
notation 1 := Terminal_precategory
|
||||
definition one_op : 1ᵒᵖ = 1 := idp
|
||||
|
||||
definition terminal_functor [constructor] (C : Precategory) : C ⇒ 1 :=
|
||||
functor.mk (λx, star)
|
||||
(λx y f, star)
|
||||
(λx, idp)
|
||||
(λx y z g f, idp)
|
||||
|
||||
definition is_contr_functor_one [instance] (C : Precategory) : is_contr (C ⇒ 1) :=
|
||||
is_contr.mk (terminal_functor C)
|
||||
begin
|
||||
intro F, fapply functor_eq,
|
||||
{ intro x, apply @is_prop.elim unit},
|
||||
{ intro x y f, apply @is_prop.elim unit}
|
||||
end
|
||||
|
||||
definition terminal_functor_op (C : Precategory)
|
||||
: (terminal_functor C)ᵒᵖᶠ = terminal_functor Cᵒᵖ := idp
|
||||
|
||||
definition terminal_functor_comp {C D : Precategory} (F : C ⇒ D)
|
||||
: (terminal_functor D) ∘f F = terminal_functor C := idp
|
||||
|
||||
definition point [constructor] (C : Precategory) (c : C) : 1 ⇒ C :=
|
||||
functor.mk (λx, c)
|
||||
(λx y f, id)
|
||||
(λx, idp)
|
||||
(λx y z g f, !id_id⁻¹)
|
||||
|
||||
-- we need id_id in the declaration of precategory to make this to hold definitionally
|
||||
definition point_op (C : Precategory) (c : C) : (point C c)ᵒᵖᶠ = point Cᵒᵖ c := idp
|
||||
|
||||
definition point_comp {C D : Precategory} (F : C ⇒ D) (c : C)
|
||||
: F ∘f point C c = point D (F c) := idp
|
||||
|
||||
end category
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import .category .strict .groupoid .constructions .limits .functor
|
||||
|
|
@ -1,274 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Adjoint functors
|
||||
-/
|
||||
|
||||
import .attributes .examples
|
||||
|
||||
open functor nat_trans is_trunc eq iso prod
|
||||
|
||||
namespace category
|
||||
|
||||
structure adjoint {C D : Precategory} (F : C ⇒ D) (G : D ⇒ C) :=
|
||||
(η : 1 ⟹ G ∘f F)
|
||||
(ε : F ∘f G ⟹ 1)
|
||||
(H : Π(c : C), ε (F c) ∘ F (η c) = ID (F c))
|
||||
(K : Π(d : D), G (ε d) ∘ η (G d) = ID (G d))
|
||||
|
||||
abbreviation to_unit [unfold 5] := @adjoint.η
|
||||
abbreviation to_counit [unfold 5] := @adjoint.ε
|
||||
abbreviation to_counit_unit_eq [unfold 5] := @adjoint.H
|
||||
abbreviation to_unit_counit_eq [unfold 5] := @adjoint.K
|
||||
|
||||
-- TODO: define is_left_adjoint in terms of adjoint:
|
||||
-- structure is_left_adjoint (F : C ⇒ D) :=
|
||||
-- (G : D ⇒ C) -- G
|
||||
-- (is_adjoint : adjoint F G)
|
||||
|
||||
infix ` ⊣ `:55 := adjoint
|
||||
|
||||
structure is_left_adjoint [class] {C D : Precategory} (F : C ⇒ D) :=
|
||||
(G : D ⇒ C)
|
||||
(η : 1 ⟹ G ∘f F)
|
||||
(ε : F ∘f G ⟹ 1)
|
||||
(H : Π(c : C), ε (F c) ∘ F (η c) = ID (F c))
|
||||
(K : Π(d : D), G (ε d) ∘ η (G d) = ID (G d))
|
||||
|
||||
abbreviation right_adjoint [unfold 4] := @is_left_adjoint.G
|
||||
abbreviation unit [unfold 4] := @is_left_adjoint.η
|
||||
abbreviation counit [unfold 4] := @is_left_adjoint.ε
|
||||
abbreviation counit_unit_eq [unfold 4] := @is_left_adjoint.H
|
||||
abbreviation unit_counit_eq [unfold 4] := @is_left_adjoint.K
|
||||
|
||||
theorem is_prop_is_left_adjoint [instance] {C : Category} {D : Precategory} (F : C ⇒ D)
|
||||
: is_prop (is_left_adjoint F) :=
|
||||
begin
|
||||
apply is_prop.mk,
|
||||
intro G G', cases G with G η ε H K, cases G' with G' η' ε' H' K',
|
||||
have lem₁ : Π(p : G = G'), p ▸ η = η' → p ▸ ε = ε'
|
||||
→ is_left_adjoint.mk G η ε H K = is_left_adjoint.mk G' η' ε' H' K',
|
||||
begin
|
||||
intros p q r, induction p, induction q, induction r, esimp,
|
||||
apply apd011 (is_left_adjoint.mk G η ε) !is_prop.elim !is_prop.elimo
|
||||
end,
|
||||
have lem₂ : Π (d : carrier D),
|
||||
(to_fun_hom G (natural_map ε' d) ∘
|
||||
natural_map η (to_fun_ob G' d)) ∘
|
||||
to_fun_hom G' (natural_map ε d) ∘
|
||||
natural_map η' (to_fun_ob G d) = id,
|
||||
begin
|
||||
intro d, esimp,
|
||||
rewrite [assoc],
|
||||
rewrite [-assoc (G (ε' d))],
|
||||
esimp, rewrite [nf_fn_eq_fn_nf_pt' G' ε η d],
|
||||
esimp, rewrite [assoc],
|
||||
esimp, rewrite [-assoc],
|
||||
rewrite [↑functor.compose, -respect_comp G],
|
||||
rewrite [nf_fn_eq_fn_nf_pt ε ε' d,nf_fn_eq_fn_nf_pt η' η (G d),▸*],
|
||||
rewrite [respect_comp G],
|
||||
rewrite [assoc,▸*,-assoc (G (ε d))],
|
||||
rewrite [↑functor.compose, -respect_comp G],
|
||||
rewrite [H' (G d)],
|
||||
rewrite [respect_id,▸*,id_right],
|
||||
apply K
|
||||
end,
|
||||
have lem₃ : Π (d : carrier D),
|
||||
(to_fun_hom G' (natural_map ε d) ∘
|
||||
natural_map η' (to_fun_ob G d)) ∘
|
||||
to_fun_hom G (natural_map ε' d) ∘
|
||||
natural_map η (to_fun_ob G' d) = id,
|
||||
begin
|
||||
intro d, esimp,
|
||||
rewrite [assoc, -assoc (G' (ε d))],
|
||||
esimp, rewrite [nf_fn_eq_fn_nf_pt' G ε' η' d],
|
||||
esimp, rewrite [assoc], esimp, rewrite [-assoc],
|
||||
rewrite [↑functor.compose, -respect_comp G'],
|
||||
rewrite [nf_fn_eq_fn_nf_pt ε' ε d,nf_fn_eq_fn_nf_pt η η' (G' d)],
|
||||
esimp,
|
||||
rewrite [respect_comp G'],
|
||||
rewrite [assoc,▸*,-assoc (G' (ε' d))],
|
||||
rewrite [↑functor.compose, -respect_comp G'],
|
||||
rewrite [H (G' d)],
|
||||
rewrite [respect_id,▸*,id_right],
|
||||
apply K'
|
||||
end,
|
||||
fapply lem₁,
|
||||
{ fapply functor.eq_of_pointwise_iso,
|
||||
{ fapply change_natural_map,
|
||||
{ exact (G' ∘fn1 ε) ∘n !assoc_natural_rev ∘n (η' ∘1nf G)},
|
||||
{ intro d, exact (G' (ε d) ∘ η' (G d))},
|
||||
{ intro d, exact ap (λx, _ ∘ x) !id_left}},
|
||||
{ intro d, fconstructor,
|
||||
{ exact (G (ε' d) ∘ η (G' d))},
|
||||
{ exact lem₂ d },
|
||||
{ exact lem₃ d }}},
|
||||
{ clear lem₁, refine transport_hom_of_eq_right _ η ⬝ _,
|
||||
krewrite hom_of_eq_compose_right,
|
||||
rewrite functor.hom_of_eq_eq_of_pointwise_iso,
|
||||
apply nat_trans_eq, intro c, esimp,
|
||||
refine !assoc⁻¹ ⬝ ap (λx, _ ∘ x) (nf_fn_eq_fn_nf_pt η η' c) ⬝ !assoc ⬝ _,
|
||||
esimp, rewrite [-respect_comp G',H c,respect_id G',▸*,id_left]},
|
||||
{ clear lem₁, refine transport_hom_of_eq_left _ ε ⬝ _,
|
||||
krewrite inv_of_eq_compose_left,
|
||||
rewrite functor.inv_of_eq_eq_of_pointwise_iso,
|
||||
apply nat_trans_eq, intro d, esimp,
|
||||
krewrite [respect_comp],
|
||||
rewrite [assoc,nf_fn_eq_fn_nf_pt ε' ε d,-assoc,▸*,H (G' d),id_right]}
|
||||
end
|
||||
|
||||
section
|
||||
universe variables u v w
|
||||
parameters {C : Precategory.{u v}} {D : Precategory.{w v}} {F : C ⇒ D} {G : D ⇒ C}
|
||||
(θ : hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅ hom_functor C ∘f prod_functor_prod 1 G)
|
||||
include θ
|
||||
|
||||
definition adj_unit [constructor] : 1 ⟹ G ∘f F :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact natural_map (to_hom θ) (c, F c) id},
|
||||
{ intro c c' f,
|
||||
note H := naturality (to_hom θ) (ID c, F f),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, id_right at K, ▸*, K, respect_id, +id_right],
|
||||
clear H K,
|
||||
note H := naturality (to_hom θ) (f, ID (F c')),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, respect_id at K,+id_left at K, K]}
|
||||
end
|
||||
|
||||
definition adj_counit [constructor] : F ∘f G ⟹ 1 :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro d, exact natural_map (to_inv θ) (G d, d) id, },
|
||||
{ intro d d' g,
|
||||
note H := naturality (to_inv θ) (Gᵒᵖᶠ g, ID d'),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, id_left at K, ▸*, K, respect_id, +id_left],
|
||||
clear H K,
|
||||
note H := naturality (to_inv θ) (ID (G d), g),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, respect_id at K,+id_right at K, K]}
|
||||
end
|
||||
|
||||
theorem adj_eq_unit (c : C) (d : D) (f : F c ⟶ d)
|
||||
: natural_map (to_hom θ) (c, d) f = G f ∘ adj_unit c :=
|
||||
begin
|
||||
esimp,
|
||||
note H := naturality (to_hom θ) (ID c, f),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, id_right at K, K, respect_id, +id_right],
|
||||
end
|
||||
|
||||
theorem adj_eq_counit (c : C) (d : D) (g : c ⟶ G d)
|
||||
: natural_map (to_inv θ) (c, d) g = adj_counit d ∘ F g :=
|
||||
begin
|
||||
esimp,
|
||||
note H := naturality (to_inv θ) (g, ID d),
|
||||
note K := ap10 H id,
|
||||
rewrite [▸* at K, id_left at K, K, respect_id, +id_left],
|
||||
end
|
||||
|
||||
definition adjoint.mk' [constructor] : F ⊣ G :=
|
||||
begin
|
||||
fapply adjoint.mk,
|
||||
{ exact adj_unit},
|
||||
{ exact adj_counit},
|
||||
{ intro c, esimp, refine (adj_eq_counit c (F c) (adj_unit c))⁻¹ ⬝ _,
|
||||
apply ap10 (to_left_inverse (componentwise_iso θ (c, F c)))},
|
||||
{ intro d, esimp, refine (adj_eq_unit (G d) d (adj_counit d))⁻¹ ⬝ _,
|
||||
apply ap10 (to_right_inverse (componentwise_iso θ (G d, d)))},
|
||||
end
|
||||
|
||||
end
|
||||
/- TODO (below): generalize above definitions to arbitrary categories
|
||||
section
|
||||
universe variables u₁ u₂ v₁ v₂
|
||||
parameters {C : Precategory.{u₁ v₁}} {D : Precategory.{u₂ v₂}} {F : C ⇒ D} {G : D ⇒ C}
|
||||
(θ : functor_lift.{v₂ v₁} ∘f hom_functor D ∘f prod_functor_prod Fᵒᵖᶠ 1 ≅
|
||||
functor_lift.{v₁ v₂} ∘f hom_functor C ∘f prod_functor_prod 1 G)
|
||||
include θ
|
||||
open lift
|
||||
definition adj_unit [constructor] : 1 ⟹ G ∘f F :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c, exact down (natural_map (to_hom θ) (c, F c) (up id))},
|
||||
{ intro c c' f,
|
||||
let H := naturality (to_hom θ) (ID c, F f),
|
||||
let K := ap10 H (up id),
|
||||
rewrite [▸* at K, id_right at K, ▸*, K, respect_id, +id_right],
|
||||
clear H K,
|
||||
let H := naturality (to_hom θ) (f, ID (F c')),
|
||||
let K := ap10 H id,
|
||||
rewrite [▸* at K, respect_id at K,+id_left at K, K]}
|
||||
end
|
||||
|
||||
definition adj_counit [constructor] : F ∘f G ⟹ 1 :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro d, exact natural_map (to_inv θ) (G d, d) id, },
|
||||
{ intro d d' g,
|
||||
let H := naturality (to_inv θ) (Gᵒᵖᶠ g, ID d'),
|
||||
let K := ap10 H id,
|
||||
rewrite [▸* at K, id_left at K, ▸*, K, respect_id, +id_left],
|
||||
clear H K,
|
||||
let H := naturality (to_inv θ) (ID (G d), g),
|
||||
let K := ap10 H id,
|
||||
rewrite [▸* at K, respect_id at K,+id_right at K, K]}
|
||||
end
|
||||
|
||||
theorem adj_eq_unit (c : C) (d : D) (f : F c ⟶ d)
|
||||
: natural_map (to_hom θ) (c, d) (up f) = G f ∘ adj_unit c :=
|
||||
begin
|
||||
esimp,
|
||||
let H := naturality (to_hom θ) (ID c, f),
|
||||
let K := ap10 H id,
|
||||
rewrite [▸* at K, id_right at K, K, respect_id, +id_right],
|
||||
end
|
||||
|
||||
theorem adj_eq_counit (c : C) (d : D) (g : c ⟶ G d)
|
||||
: natural_map (to_inv θ) (c, d) (up g) = adj_counit d ∘ F g :=
|
||||
begin
|
||||
esimp,
|
||||
let H := naturality (to_inv θ) (g, ID d),
|
||||
let K := ap10 H id,
|
||||
rewrite [▸* at K, id_left at K, K, respect_id, +id_left],
|
||||
end
|
||||
|
||||
definition adjoint.mk' [constructor] : F ⊣ G :=
|
||||
begin
|
||||
fapply adjoint.mk,
|
||||
{ exact adj_unit},
|
||||
{ exact adj_counit},
|
||||
{ intro c, esimp, refine (adj_eq_counit c (F c) (adj_unit c))⁻¹ ⬝ _,
|
||||
apply ap10 (to_left_inverse (componentwise_iso θ (c, F c)))},
|
||||
{ intro d, esimp, refine (adj_eq_unit (G d) d (adj_counit d))⁻¹ ⬝ _,
|
||||
apply ap10 (to_right_inverse (componentwise_iso θ (G d, d)))},
|
||||
end
|
||||
|
||||
end
|
||||
-/
|
||||
|
||||
variables {C D : Precategory} {F : C ⇒ D} {G : D ⇒ C}
|
||||
|
||||
definition adjoint_opposite [constructor] (H : F ⊣ G) : Gᵒᵖᶠ ⊣ Fᵒᵖᶠ :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ rexact opposite_nat_trans (to_counit H)},
|
||||
{ rexact opposite_nat_trans (to_unit H)},
|
||||
{ rexact to_unit_counit_eq H},
|
||||
{ rexact to_counit_unit_eq H}
|
||||
end
|
||||
|
||||
definition adjoint_of_opposite [constructor] (H : Fᵒᵖᶠ ⊣ Gᵒᵖᶠ) : G ⊣ F :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ rexact opposite_rev_nat_trans (to_counit H)},
|
||||
{ rexact opposite_rev_nat_trans (to_unit H)},
|
||||
{ rexact to_unit_counit_eq H},
|
||||
{ rexact to_counit_unit_eq H}
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
|
||||
import .equivalence
|
||||
|
||||
open eq functor nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
variables {C D E : Precategory} (F : C ⇒ D) (G : D ⇒ C) (H : D ≅c E)
|
||||
/-
|
||||
definition adjoint_compose [constructor] (K : F ⊣ G)
|
||||
: H ∘f F ⊣ G ∘f H⁻¹ᴱ :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ fapply change_natural_map,
|
||||
{ exact calc
|
||||
1 ⟹ G ∘f F : to_unit K
|
||||
... ⟹ (G ∘f 1) ∘f F : !id_right_natural_rev ∘nf F
|
||||
... ⟹ (G ∘f (H⁻¹ ∘f H)) ∘f F : (G ∘fn unit H) ∘nf F
|
||||
... ⟹ ((G ∘f H⁻¹) ∘f H) ∘f F : !assoc_natural ∘nf F
|
||||
... ⟹ (G ∘f H⁻¹) ∘f (H ∘f F) : assoc_natural_rev},
|
||||
{ intro c, esimp, exact G (unit H (F c)) ∘ to_unit K c},
|
||||
{ intro c, rewrite [▸*, +id_left]}},
|
||||
{ fapply change_natural_map,
|
||||
{ exact calc
|
||||
(H ∘f F) ∘f (G ∘f H⁻¹)
|
||||
⟹ ((H ∘f F) ∘f G) ∘f H⁻¹ : assoc_natural
|
||||
... ⟹ (H ∘f (F ∘f G)) ∘f H⁻¹ : !assoc_natural_rev ∘nf H⁻¹
|
||||
... ⟹ (H ∘f 1) ∘f H⁻¹ : (H ∘fn to_counit K) ∘nf H⁻¹
|
||||
... ⟹ H ∘f H⁻¹ : !id_right_natural ∘nf H⁻¹
|
||||
... ⟹ 1 : counit H},
|
||||
{ intro e, esimp, exact counit H e ∘ to_fun_hom H (to_counit K (H⁻¹ e))},
|
||||
{ intro c, rewrite [▸*, +id_right, +id_left]}},
|
||||
{ intro c, rewrite [▸*, +respect_comp], refine !assoc ⬝ ap (λx, x ∘ _) !assoc⁻¹ ⬝ _,
|
||||
rewrite [-respect_comp],
|
||||
},
|
||||
{ }
|
||||
end
|
||||
-/
|
||||
end category
|
||||
|
|
@ -1,198 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Attributes of functors (full, faithful, split essentially surjective, ...)
|
||||
|
||||
Adjoint functors, isomorphisms and equivalences have their own file
|
||||
-/
|
||||
|
||||
import .basic function arity
|
||||
|
||||
open eq functor trunc prod is_equiv iso equiv function is_trunc sigma
|
||||
|
||||
namespace category
|
||||
variables {C D E : Precategory} {F : C ⇒ D} {G : D ⇒ C}
|
||||
|
||||
definition faithful [class] (F : C ⇒ D) := Π⦃c c' : C⦄ ⦃f f' : c ⟶ c'⦄, F f = F f' → f = f'
|
||||
definition full [class] (F : C ⇒ D) := Π⦃c c' : C⦄, is_surjective (@(to_fun_hom F) c c')
|
||||
definition fully_faithful [class] (F : C ⇒ D) := Π(c c' : C), is_equiv (@(to_fun_hom F) c c')
|
||||
definition split_essentially_surjective [class] (F : C ⇒ D) := Π(d : D), Σ(c : C), F c ≅ d
|
||||
definition essentially_surjective [class] (F : C ⇒ D) := Π(d : D), ∃(c : C), F c ≅ d
|
||||
|
||||
definition is_weak_equivalence [class] (F : C ⇒ D) :=
|
||||
fully_faithful F × essentially_surjective F
|
||||
|
||||
definition is_equiv_of_fully_faithful [instance] (F : C ⇒ D)
|
||||
[H : fully_faithful F] (c c' : C) : is_equiv (@(to_fun_hom F) c c') :=
|
||||
!H
|
||||
|
||||
definition fully_faithful_of_is_weak_equivalence [instance] (F : C ⇒ D)
|
||||
[H : is_weak_equivalence F] : fully_faithful F :=
|
||||
pr1 H
|
||||
|
||||
definition essentially_surjective_of_is_weak_equivalence [instance] (F : C ⇒ D)
|
||||
[H : is_weak_equivalence F] : essentially_surjective F :=
|
||||
pr2 H
|
||||
|
||||
definition hom_inv [reducible] (F : C ⇒ D) [H : fully_faithful F] {c c' : C} (f : F c ⟶ F c')
|
||||
: c ⟶ c' :=
|
||||
(to_fun_hom F)⁻¹ᶠ f
|
||||
|
||||
definition hom_inv_respect_id (F : C ⇒ D) [H : fully_faithful F] (c : C) :
|
||||
hom_inv F (ID (F c)) = id :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
exact !(right_inv (to_fun_hom F)) ⬝ !respect_id⁻¹,
|
||||
end
|
||||
|
||||
definition hom_inv_respect_comp (F : C ⇒ D) [H : fully_faithful F] {a b c : C}
|
||||
(g : F b ⟶ F c) (f : F a ⟶ F b) : hom_inv F (g ∘ f) = hom_inv F g ∘ hom_inv F f :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
refine !(right_inv (to_fun_hom F)) ⬝ _ ⬝ !respect_comp⁻¹,
|
||||
rewrite [right_inv (to_fun_hom F), right_inv (to_fun_hom F)],
|
||||
end
|
||||
|
||||
definition reflect_is_iso [constructor] (F : C ⇒ D) [H : fully_faithful F] {c c' : C}
|
||||
(f : c ⟶ c') [H : is_iso (F f)] : is_iso f :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ exact (to_fun_hom F)⁻¹ᶠ (F f)⁻¹},
|
||||
{ apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
rewrite [respect_comp,right_inv (to_fun_hom F),respect_id,left_inverse]},
|
||||
{ apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
rewrite [respect_comp,right_inv (to_fun_hom F),respect_id,right_inverse]},
|
||||
end
|
||||
|
||||
definition reflect_iso [constructor] (F : C ⇒ D) [H : fully_faithful F] {c c' : C}
|
||||
(f : F c ≅ F c') : c ≅ c' :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ exact (to_fun_hom F)⁻¹ᶠ f},
|
||||
{ have H : is_iso (F ((to_fun_hom F)⁻¹ᶠ f)), from
|
||||
have H' : is_iso (to_hom f), from _,
|
||||
(right_inv (to_fun_hom F) (to_hom f))⁻¹ ▸ H',
|
||||
exact reflect_is_iso F _},
|
||||
end
|
||||
|
||||
theorem reflect_inverse (F : C ⇒ D) [H : fully_faithful F] {c c' : C} (f : c ⟶ c')
|
||||
[H' : is_iso f] : (to_fun_hom F)⁻¹ᶠ (F f)⁻¹ = f⁻¹ :=
|
||||
@inverse_eq_inverse _ _ _ _ _ _ (reflect_is_iso F f) H' idp
|
||||
|
||||
definition hom_equiv_F_hom_F [constructor] (F : C ⇒ D)
|
||||
[H : fully_faithful F] (c c' : C) : (c ⟶ c') ≃ (F c ⟶ F c') :=
|
||||
equiv.mk _ !H
|
||||
|
||||
definition iso_equiv_F_iso_F [constructor] (F : C ⇒ D)
|
||||
[H : fully_faithful F] (c c' : C) : (c ≅ c') ≃ (F c ≅ F c') :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact to_fun_iso F},
|
||||
{ apply reflect_iso F},
|
||||
{ exact abstract begin
|
||||
intro f, induction f with f F', induction F' with g p q, apply iso_eq,
|
||||
esimp [reflect_iso], apply right_inv end end},
|
||||
{ exact abstract begin
|
||||
intro f, induction f with f F', induction F' with g p q, apply iso_eq,
|
||||
esimp [reflect_iso], apply right_inv end end},
|
||||
end
|
||||
|
||||
definition full_of_fully_faithful [instance] (F : C ⇒ D) [H : fully_faithful F] : full F :=
|
||||
λc c' g, tr (fiber.mk ((@(to_fun_hom F) c c')⁻¹ᶠ g) !right_inv)
|
||||
|
||||
definition faithful_of_fully_faithful [instance] (F : C ⇒ D) [H : fully_faithful F]
|
||||
: faithful F :=
|
||||
λc c' f f' p, is_injective_of_is_embedding p
|
||||
|
||||
definition is_embedding_of_faithful [instance] (F : C ⇒ D) [H : faithful F] (c c' : C)
|
||||
: is_embedding (to_fun_hom F : c ⟶ c' → F c ⟶ F c') :=
|
||||
begin
|
||||
apply is_embedding_of_is_injective,
|
||||
apply H
|
||||
end
|
||||
|
||||
definition is_surjective_of_full [instance] (F : C ⇒ D) [H : full F] (c c' : C)
|
||||
: is_surjective (to_fun_hom F : c ⟶ c' → F c ⟶ F c') :=
|
||||
@H c c'
|
||||
|
||||
definition fully_faithful_of_full_of_faithful (H : faithful F) (K : full F)
|
||||
: fully_faithful F :=
|
||||
begin
|
||||
intro c c',
|
||||
apply is_equiv_of_is_surjective_of_is_embedding,
|
||||
end
|
||||
|
||||
theorem is_prop_fully_faithful [instance] (F : C ⇒ D) : is_prop (fully_faithful F) :=
|
||||
by unfold fully_faithful; exact _
|
||||
|
||||
theorem is_prop_full [instance] (F : C ⇒ D) : is_prop (full F) :=
|
||||
by unfold full; exact _
|
||||
|
||||
theorem is_prop_faithful [instance] (F : C ⇒ D) : is_prop (faithful F) :=
|
||||
by unfold faithful; exact _
|
||||
|
||||
theorem is_prop_essentially_surjective [instance] (F : C ⇒ D)
|
||||
: is_prop (essentially_surjective F) :=
|
||||
by unfold essentially_surjective; exact _
|
||||
|
||||
definition essentially_surjective_of_split_essentially_surjective [instance] (F : C ⇒ D)
|
||||
[H : split_essentially_surjective F] : essentially_surjective F :=
|
||||
λd, tr (H d)
|
||||
|
||||
definition fully_faithful_equiv (F : C ⇒ D) : fully_faithful F ≃ (faithful F × full F) :=
|
||||
equiv_of_is_prop (λH, (faithful_of_fully_faithful F, full_of_fully_faithful F))
|
||||
(λH, fully_faithful_of_full_of_faithful (pr1 H) (pr2 H))
|
||||
|
||||
/- alternative proof using direct calculation with equivalences
|
||||
|
||||
definition fully_faithful_equiv (F : C ⇒ D) : fully_faithful F ≃ (faithful F × full F) :=
|
||||
calc
|
||||
fully_faithful F
|
||||
≃ (Π(c c' : C), is_embedding (to_fun_hom F) × is_surjective (to_fun_hom F))
|
||||
: pi_equiv_pi_right (λc, pi_equiv_pi_right
|
||||
(λc', !is_equiv_equiv_is_embedding_times_is_surjective))
|
||||
... ≃ (Π(c : C), (Π(c' : C), is_embedding (to_fun_hom F)) ×
|
||||
(Π(c' : C), is_surjective (to_fun_hom F)))
|
||||
: pi_equiv_pi_right (λc, !equiv_prod_corec)
|
||||
... ≃ (Π(c c' : C), is_embedding (to_fun_hom F)) × full F
|
||||
: equiv_prod_corec
|
||||
... ≃ faithful F × full F
|
||||
: prod_equiv_prod_right (pi_equiv_pi_right (λc, pi_equiv_pi_right
|
||||
(λc', !is_embedding_equiv_is_injective)))
|
||||
-/
|
||||
|
||||
definition fully_faithful_compose (G : D ⇒ E) (F : C ⇒ D) [fully_faithful G] [fully_faithful F] :
|
||||
fully_faithful (G ∘f F) :=
|
||||
λc c', is_equiv_compose (to_fun_hom G) (to_fun_hom F)
|
||||
|
||||
definition full_compose (G : D ⇒ E) (F : C ⇒ D) [full G] [full F] : full (G ∘f F) :=
|
||||
λc c', is_surjective_compose (to_fun_hom G) (to_fun_hom F) _ _
|
||||
|
||||
definition faithful_compose (G : D ⇒ E) (F : C ⇒ D) [H₁ : faithful G] [H₂ : faithful F] :
|
||||
faithful (G ∘f F) :=
|
||||
λc c' f f' p, H₂ (H₁ p)
|
||||
|
||||
definition essentially_surjective_compose (G : D ⇒ E) (F : C ⇒ D) [H₁ : essentially_surjective G]
|
||||
[H₂ : essentially_surjective F] : essentially_surjective (G ∘f F) :=
|
||||
begin
|
||||
intro e,
|
||||
induction H₁ e with v, induction v with d p,
|
||||
induction H₂ d with w, induction w with c q,
|
||||
exact exists.intro c (to_fun_iso G q ⬝i p)
|
||||
end
|
||||
|
||||
definition split_essentially_surjective_compose (G : D ⇒ E) (F : C ⇒ D)
|
||||
[H₁ : split_essentially_surjective G] [H₂ : split_essentially_surjective F]
|
||||
: split_essentially_surjective (G ∘f F) :=
|
||||
begin
|
||||
intro e, induction H₁ e with d p, induction H₂ d with c q,
|
||||
exact ⟨c, to_fun_iso G q ⬝i p⟩
|
||||
end
|
||||
|
||||
/- we get the fact that the identity functor satisfies all these properties via the fact that it
|
||||
is an isomorphism -/
|
||||
|
||||
|
||||
end category
|
||||
|
|
@ -1,301 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
-/
|
||||
|
||||
import ..iso types.pi
|
||||
|
||||
open function category eq prod prod.ops equiv is_equiv sigma sigma.ops is_trunc funext iso pi
|
||||
|
||||
structure functor (C D : Precategory) : Type :=
|
||||
(to_fun_ob : C → D)
|
||||
(to_fun_hom : Π {a b : C}, hom a b → hom (to_fun_ob a) (to_fun_ob b))
|
||||
(respect_id : Π (a : C), to_fun_hom (ID a) = ID (to_fun_ob a))
|
||||
(respect_comp : Π {a b c : C} (g : hom b c) (f : hom a b),
|
||||
to_fun_hom (g ∘ f) = to_fun_hom g ∘ to_fun_hom f)
|
||||
|
||||
namespace functor
|
||||
|
||||
infixl ` ⇒ `:55 := functor
|
||||
variables {A B C D E : Precategory}
|
||||
|
||||
attribute to_fun_ob [coercion]
|
||||
attribute to_fun_hom [coercion]
|
||||
|
||||
-- The following lemmas will later be used to prove that the type of
|
||||
-- precategories forms a precategory itself
|
||||
protected definition compose [reducible] [constructor] (G : functor D E) (F : functor C D)
|
||||
: functor C E :=
|
||||
functor.mk
|
||||
(λ x, G (F x))
|
||||
(λ a b f, G (F f))
|
||||
(λ a, abstract calc
|
||||
G (F (ID a)) = G (ID (F a)) : by rewrite respect_id
|
||||
... = ID (G (F a)) : by rewrite respect_id end)
|
||||
(λ a b c g f, abstract calc
|
||||
G (F (g ∘ f)) = G (F g ∘ F f) : by rewrite respect_comp
|
||||
... = G (F g) ∘ G (F f) : by rewrite respect_comp end)
|
||||
|
||||
infixr ` ∘f `:75 := functor.compose
|
||||
|
||||
protected definition id [reducible] [constructor] {C : Precategory} : functor C C :=
|
||||
mk (λa, a) (λ a b f, f) (λ a, idp) (λ a b c f g, idp)
|
||||
|
||||
protected definition ID [reducible] [constructor] (C : Precategory) : functor C C := @functor.id C
|
||||
notation 1 := functor.id
|
||||
|
||||
definition constant_functor [constructor] (C : Precategory) {D : Precategory} (d : D) : C ⇒ D :=
|
||||
functor.mk (λc, d)
|
||||
(λc c' f, id)
|
||||
(λc, idp)
|
||||
(λa b c g f, !id_id⁻¹)
|
||||
|
||||
/- introduction rule for equalities between functors -/
|
||||
definition functor_mk_eq' {F₁ F₂ : C → D} {H₁ : Π(a b : C), hom a b → hom (F₁ a) (F₁ b)}
|
||||
{H₂ : Π(a b : C), hom a b → hom (F₂ a) (F₂ b)} (id₁ id₂ comp₁ comp₂)
|
||||
(pF : F₁ = F₂) (pH : pF ▸ H₁ = H₂)
|
||||
: functor.mk F₁ H₁ id₁ comp₁ = functor.mk F₂ H₂ id₂ comp₂ :=
|
||||
apdt01111 functor.mk pF pH !is_prop.elim !is_prop.elim
|
||||
|
||||
definition functor_eq' {F₁ F₂ : C ⇒ D} : Π(p : to_fun_ob F₁ = to_fun_ob F₂),
|
||||
(transport (λx, Πa b f, hom (x a) (x b)) p @(to_fun_hom F₁) = @(to_fun_hom F₂)) → F₁ = F₂ :=
|
||||
by induction F₁; induction F₂; apply functor_mk_eq'
|
||||
|
||||
definition functor_mk_eq {F₁ F₂ : C → D} {H₁ : Π(a b : C), hom a b → hom (F₁ a) (F₁ b)}
|
||||
{H₂ : Π(a b : C), hom a b → hom (F₂ a) (F₂ b)} (id₁ id₂ comp₁ comp₂) (pF : F₁ ~ F₂)
|
||||
(pH : Π(a b : C) (f : hom a b), hom_of_eq (pF b) ∘ H₁ a b f ∘ inv_of_eq (pF a) = H₂ a b f)
|
||||
: functor.mk F₁ H₁ id₁ comp₁ = functor.mk F₂ H₂ id₂ comp₂ :=
|
||||
begin
|
||||
fapply functor_mk_eq',
|
||||
{ exact eq_of_homotopy pF},
|
||||
{ refine eq_of_homotopy (λc, eq_of_homotopy (λc', eq_of_homotopy (λf, _))), intros,
|
||||
rewrite [+pi_transport_constant,-pH,-transport_hom]}
|
||||
end
|
||||
|
||||
definition functor_eq {F₁ F₂ : C ⇒ D} : Π(p : to_fun_ob F₁ ~ to_fun_ob F₂),
|
||||
(Π(a b : C) (f : hom a b), hom_of_eq (p b) ∘ F₁ f ∘ inv_of_eq (p a) = F₂ f) → F₁ = F₂ :=
|
||||
by induction F₁; induction F₂; apply functor_mk_eq
|
||||
|
||||
definition functor_mk_eq_constant {F : C → D} {H₁ : Π(a b : C), hom a b → hom (F a) (F b)}
|
||||
{H₂ : Π(a b : C), hom a b → hom (F a) (F b)} (id₁ id₂ comp₁ comp₂)
|
||||
(pH : Π(a b : C) (f : hom a b), H₁ a b f = H₂ a b f)
|
||||
: functor.mk F H₁ id₁ comp₁ = functor.mk F H₂ id₂ comp₂ :=
|
||||
functor_eq (λc, idp) (λa b f, !id_leftright ⬝ !pH)
|
||||
|
||||
definition preserve_is_iso [constructor] (F : C ⇒ D) {a b : C} (f : hom a b) [H : is_iso f]
|
||||
: is_iso (F f) :=
|
||||
begin
|
||||
fapply @is_iso.mk, apply (F (f⁻¹)),
|
||||
repeat (apply concat ; symmetry ; apply (respect_comp F) ;
|
||||
apply concat ; apply (ap (λ x, to_fun_hom F x)) ;
|
||||
(apply iso.left_inverse | apply iso.right_inverse);
|
||||
apply (respect_id F) ),
|
||||
end
|
||||
|
||||
theorem respect_inv (F : C ⇒ D) {a b : C} (f : hom a b) [H : is_iso f] [H' : is_iso (F f)] :
|
||||
F (f⁻¹) = (F f)⁻¹ :=
|
||||
begin
|
||||
fapply @left_inverse_eq_right_inverse, apply (F f),
|
||||
transitivity to_fun_hom F (f⁻¹ ∘ f),
|
||||
{symmetry, apply (respect_comp F)},
|
||||
{transitivity to_fun_hom F category.id,
|
||||
{congruence, apply iso.left_inverse},
|
||||
{apply respect_id}},
|
||||
apply iso.right_inverse
|
||||
end
|
||||
|
||||
attribute preserve_is_iso [instance] [priority 100]
|
||||
|
||||
definition to_fun_iso [constructor] (F : C ⇒ D) {a b : C} (f : a ≅ b) : F a ≅ F b :=
|
||||
iso.mk (F f) _
|
||||
|
||||
theorem respect_inv' (F : C ⇒ D) {a b : C} (f : hom a b) {H : is_iso f} : F (f⁻¹) = (F f)⁻¹ :=
|
||||
respect_inv F f
|
||||
|
||||
theorem respect_refl (F : C ⇒ D) (a : C) : to_fun_iso F (iso.refl a) = iso.refl (F a) :=
|
||||
iso_eq !respect_id
|
||||
|
||||
theorem respect_symm (F : C ⇒ D) {a b : C} (f : a ≅ b)
|
||||
: to_fun_iso F f⁻¹ⁱ = (to_fun_iso F f)⁻¹ⁱ :=
|
||||
iso_eq !respect_inv
|
||||
|
||||
theorem respect_trans (F : C ⇒ D) {a b c : C} (f : a ≅ b) (g : b ≅ c)
|
||||
: to_fun_iso F (f ⬝i g) = to_fun_iso F f ⬝i to_fun_iso F g :=
|
||||
iso_eq !respect_comp
|
||||
|
||||
definition respect_iso_of_eq (F : C ⇒ D) {a b : C} (p : a = b) :
|
||||
to_fun_iso F (iso_of_eq p) = iso_of_eq (ap F p) :=
|
||||
by induction p; apply respect_refl
|
||||
|
||||
theorem respect_hom_of_eq (F : C ⇒ D) {a b : C} (p : a = b) :
|
||||
F (hom_of_eq p) = hom_of_eq (ap F p) :=
|
||||
by induction p; apply respect_id
|
||||
|
||||
definition respect_inv_of_eq (F : C ⇒ D) {a b : C} (p : a = b) :
|
||||
F (inv_of_eq p) = inv_of_eq (ap F p) :=
|
||||
by induction p; apply respect_id
|
||||
|
||||
protected definition assoc (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B) :
|
||||
H ∘f (G ∘f F) = (H ∘f G) ∘f F :=
|
||||
!functor_mk_eq_constant (λa b f, idp)
|
||||
|
||||
protected definition id_left (F : C ⇒ D) : 1 ∘f F = F :=
|
||||
functor.rec_on F (λF1 F2 F3 F4, !functor_mk_eq_constant (λa b f, idp))
|
||||
|
||||
protected definition id_right (F : C ⇒ D) : F ∘f 1 = F :=
|
||||
functor.rec_on F (λF1 F2 F3 F4, !functor_mk_eq_constant (λa b f, idp))
|
||||
|
||||
protected definition comp_id_eq_id_comp (F : C ⇒ D) : F ∘f 1 = 1 ∘f F :=
|
||||
!functor.id_right ⬝ !functor.id_left⁻¹
|
||||
|
||||
definition functor_of_eq [constructor] {C D : Precategory} (p : C = D :> Precategory) : C ⇒ D :=
|
||||
functor.mk (transport carrier p)
|
||||
(λa b f, by induction p; exact f)
|
||||
(by intro c; induction p; reflexivity)
|
||||
(by intros; induction p; reflexivity)
|
||||
|
||||
protected definition sigma_char :
|
||||
(Σ (to_fun_ob : C → D)
|
||||
(to_fun_hom : Π ⦃a b : C⦄, hom a b → hom (to_fun_ob a) (to_fun_ob b)),
|
||||
(Π (a : C), to_fun_hom (ID a) = ID (to_fun_ob a)) ×
|
||||
(Π {a b c : C} (g : hom b c) (f : hom a b),
|
||||
to_fun_hom (g ∘ f) = to_fun_hom g ∘ to_fun_hom f)) ≃ (functor C D) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{intro S, induction S with d1 S2, induction S2 with d2 P1, induction P1 with P11 P12,
|
||||
exact functor.mk d1 d2 P11 @P12},
|
||||
{intro F, induction F with d1 d2 d3 d4, exact ⟨d1, @d2, (d3, @d4)⟩},
|
||||
{intro F, induction F, reflexivity},
|
||||
{intro S, induction S with d1 S2, induction S2 with d2 P1, induction P1, reflexivity},
|
||||
end
|
||||
|
||||
definition change_fun [constructor] (F : C ⇒ D) (Fob : C → D)
|
||||
(Fhom : Π⦃c c' : C⦄ (f : c ⟶ c'), Fob c ⟶ Fob c') (p : F = Fob) (q : F =[p] Fhom) : C ⇒ D :=
|
||||
functor.mk
|
||||
Fob
|
||||
Fhom
|
||||
proof abstract λa, transporto (λFo (Fh : Π⦃c c'⦄, _), Fh (ID a) = ID (Fo a))
|
||||
q (respect_id F a) end qed
|
||||
proof abstract λa b c g f, transporto (λFo (Fh : Π⦃c c'⦄, _), Fh (g ∘ f) = Fh g ∘ Fh f)
|
||||
q (respect_comp F g f) end qed
|
||||
|
||||
section
|
||||
local attribute precategory.is_set_hom [instance] [priority 1001]
|
||||
local attribute trunctype.struct [instance] [priority 1] -- remove after #842 is closed
|
||||
protected theorem is_set_functor [instance]
|
||||
[HD : is_set D] : is_set (functor C D) :=
|
||||
by apply is_trunc_equiv_closed; apply functor.sigma_char
|
||||
end
|
||||
|
||||
/- higher equalities in the functor type -/
|
||||
definition functor_mk_eq'_idp (F : C → D) (H : Π(a b : C), hom a b → hom (F a) (F b))
|
||||
(id comp) : functor_mk_eq' id id comp comp (idpath F) (idpath H) = idp :=
|
||||
begin
|
||||
fapply apd011 (apdt01111 functor.mk idp idp),
|
||||
apply is_prop.elim,
|
||||
apply is_prop.elimo
|
||||
end
|
||||
|
||||
definition functor_eq'_idp (F : C ⇒ D) : functor_eq' idp idp = (idpath F) :=
|
||||
by (cases F; apply functor_mk_eq'_idp)
|
||||
|
||||
definition functor_eq_eta' {F₁ F₂ : C ⇒ D} (p : F₁ = F₂)
|
||||
: functor_eq' (ap to_fun_ob p) (!tr_compose⁻¹ ⬝ apdt to_fun_hom p) = p :=
|
||||
begin
|
||||
cases p, cases F₁,
|
||||
refine _ ⬝ !functor_eq'_idp,
|
||||
esimp
|
||||
end
|
||||
|
||||
theorem functor_eq2' {F₁ F₂ : C ⇒ D} {p₁ p₂ : to_fun_ob F₁ = to_fun_ob F₂} (q₁ q₂)
|
||||
(r : p₁ = p₂) : functor_eq' p₁ q₁ = functor_eq' p₂ q₂ :=
|
||||
by cases r; apply (ap (functor_eq' p₂)); apply is_prop.elim
|
||||
|
||||
theorem functor_eq2 {F₁ F₂ : C ⇒ D} (p q : F₁ = F₂) (r : ap010 to_fun_ob p ~ ap010 to_fun_ob q)
|
||||
: p = q :=
|
||||
begin
|
||||
cases F₁ with ob₁ hom₁ id₁ comp₁,
|
||||
cases F₂ with ob₂ hom₂ id₂ comp₂,
|
||||
rewrite [-functor_eq_eta' p, -functor_eq_eta' q],
|
||||
apply functor_eq2',
|
||||
apply ap_eq_ap_of_homotopy,
|
||||
exact r,
|
||||
end
|
||||
|
||||
theorem ap010_apd01111_functor {F₁ F₂ : C → D} {H₁ : Π(a b : C), hom a b → hom (F₁ a) (F₁ b)}
|
||||
{H₂ : Π(a b : C), hom a b → hom (F₂ a) (F₂ b)} {id₁ id₂ comp₁ comp₂}
|
||||
(pF : F₁ = F₂) (pH : pF ▸ H₁ = H₂) (pid : cast (apdt011 _ pF pH) id₁ = id₂)
|
||||
(pcomp : cast (apdt0111 _ pF pH pid) comp₁ = comp₂) (c : C)
|
||||
: ap010 to_fun_ob (apdt01111 functor.mk pF pH pid pcomp) c = ap10 pF c :=
|
||||
by induction pF; induction pH; induction pid; induction pcomp; reflexivity
|
||||
|
||||
definition ap010_functor_eq {F₁ F₂ : C ⇒ D} (p : to_fun_ob F₁ ~ to_fun_ob F₂)
|
||||
(q : (λ(a b : C) (f : hom a b), hom_of_eq (p b) ∘ F₁ f ∘ inv_of_eq (p a)) ~3 @(to_fun_hom F₂))
|
||||
(c : C) : ap010 to_fun_ob (functor_eq p q) c = p c :=
|
||||
begin
|
||||
cases F₁ with F₁o F₁h F₁id F₁comp, cases F₂ with F₂o F₂h F₂id F₂comp,
|
||||
esimp [functor_eq,functor_mk_eq,functor_mk_eq'],
|
||||
rewrite [ap010_apd01111_functor,↑ap10,{apd10 (eq_of_homotopy p)}right_inv apd10]
|
||||
end
|
||||
|
||||
definition ap010_functor_mk_eq_constant {F : C → D} {H₁ : Π(a b : C), hom a b → hom (F a) (F b)}
|
||||
{H₂ : Π(a b : C), hom a b → hom (F a) (F b)} {id₁ id₂ comp₁ comp₂}
|
||||
(pH : Π(a b : C) (f : hom a b), H₁ a b f = H₂ a b f) (c : C) :
|
||||
ap010 to_fun_ob (functor_mk_eq_constant id₁ id₂ comp₁ comp₂ pH) c = idp :=
|
||||
!ap010_functor_eq
|
||||
|
||||
definition ap010_assoc (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B) (a : A) :
|
||||
ap010 to_fun_ob (functor.assoc H G F) a = idp :=
|
||||
by apply ap010_functor_mk_eq_constant
|
||||
|
||||
definition compose_pentagon (K : D ⇒ E) (H : C ⇒ D) (G : B ⇒ C) (F : A ⇒ B) :
|
||||
(calc K ∘f H ∘f G ∘f F = (K ∘f H) ∘f G ∘f F : functor.assoc
|
||||
... = ((K ∘f H) ∘f G) ∘f F : functor.assoc)
|
||||
=
|
||||
(calc K ∘f H ∘f G ∘f F = K ∘f (H ∘f G) ∘f F : ap (λx, K ∘f x) !functor.assoc
|
||||
... = (K ∘f H ∘f G) ∘f F : functor.assoc
|
||||
... = ((K ∘f H) ∘f G) ∘f F : ap (λx, x ∘f F) !functor.assoc) :=
|
||||
begin
|
||||
have lem1 : Π{F₁ F₂ : A ⇒ D} (p : F₁ = F₂) (a : A),
|
||||
ap010 to_fun_ob (ap (λx, K ∘f x) p) a = ap (to_fun_ob K) (ap010 to_fun_ob p a),
|
||||
by intros; cases p; esimp,
|
||||
have lem2 : Π{F₁ F₂ : B ⇒ E} (p : F₁ = F₂) (a : A),
|
||||
ap010 to_fun_ob (ap (λx, x ∘f F) p) a = ap010 to_fun_ob p (F a),
|
||||
by intros; cases p; esimp,
|
||||
apply functor_eq2,
|
||||
intro a, esimp,
|
||||
rewrite [+ap010_con,lem1,lem2,
|
||||
ap010_assoc K H (G ∘f F) a,
|
||||
ap010_assoc (K ∘f H) G F a,
|
||||
ap010_assoc H G F a,
|
||||
ap010_assoc K H G (F a),
|
||||
ap010_assoc K (H ∘f G) F a],
|
||||
end
|
||||
|
||||
definition hom_pathover_functor {c₁ c₂ : C} {p : c₁ = c₂} (F G : C ⇒ D)
|
||||
{f₁ : F c₁ ⟶ G c₁} {f₂ : F c₂ ⟶ G c₂}
|
||||
(q : to_fun_hom G (hom_of_eq p) ∘ f₁ = f₂ ∘ to_fun_hom F (hom_of_eq p)) : f₁ =[p] f₂ :=
|
||||
hom_pathover (hom_whisker_right _ (respect_hom_of_eq G _)⁻¹ ⬝ q ⬝
|
||||
hom_whisker_left _ (respect_hom_of_eq F _))
|
||||
|
||||
definition hom_pathover_constant_left_functor_right {c₁ c₂ : C} {p : c₁ = c₂} {d : D} (F : C ⇒ D)
|
||||
{f₁ : d ⟶ F c₁} {f₂ : d ⟶ F c₂} (q : to_fun_hom F (hom_of_eq p) ∘ f₁ = f₂) : f₁ =[p] f₂ :=
|
||||
hom_pathover_constant_left (hom_whisker_right _ (respect_hom_of_eq F _)⁻¹ ⬝ q)
|
||||
|
||||
definition hom_pathover_functor_left_constant_right {c₁ c₂ : C} {p : c₁ = c₂} {d : D} (F : C ⇒ D)
|
||||
{f₁ : F c₁ ⟶ d} {f₂ : F c₂ ⟶ d} (q : f₁ = f₂ ∘ to_fun_hom F (hom_of_eq p)) : f₁ =[p] f₂ :=
|
||||
hom_pathover_constant_right (q ⬝ hom_whisker_left _ (respect_hom_of_eq F _))
|
||||
|
||||
definition hom_pathover_id_left_functor_right {c₁ c₂ : C} {p : c₁ = c₂} (F : C ⇒ C)
|
||||
{f₁ : c₁ ⟶ F c₁} {f₂ : c₂ ⟶ F c₂} (q : to_fun_hom F (hom_of_eq p) ∘ f₁ = f₂ ∘ hom_of_eq p) :
|
||||
f₁ =[p] f₂ :=
|
||||
hom_pathover_id_left (hom_whisker_right _ (respect_hom_of_eq F _)⁻¹ ⬝ q)
|
||||
|
||||
definition hom_pathover_functor_left_id_right {c₁ c₂ : C} {p : c₁ = c₂} (F : C ⇒ C)
|
||||
{f₁ : F c₁ ⟶ c₁} {f₂ : F c₂ ⟶ c₂} (q : hom_of_eq p ∘ f₁ = f₂ ∘ to_fun_hom F (hom_of_eq p)) :
|
||||
f₁ =[p] f₂ :=
|
||||
hom_pathover_id_right (q ⬝ hom_whisker_left _ (respect_hom_of_eq F _))
|
||||
|
||||
|
||||
end functor
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import .exponential_laws
|
||||
|
|
@ -1,490 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Functors which are equivalences or isomorphisms
|
||||
-/
|
||||
|
||||
import .adjoint
|
||||
|
||||
open eq functor iso prod nat_trans is_equiv equiv is_trunc sigma.ops
|
||||
|
||||
namespace category
|
||||
variables {C D : Precategory} {F : C ⇒ D} {G : D ⇒ C}
|
||||
|
||||
structure is_equivalence [class] (F : C ⇒ D) extends is_left_adjoint F :=
|
||||
mk' ::
|
||||
(is_iso_unit : is_iso η)
|
||||
(is_iso_counit : is_iso ε)
|
||||
|
||||
abbreviation inverse := @is_equivalence.G
|
||||
postfix ⁻¹ := inverse
|
||||
--a second notation for the inverse, which is not overloaded (there is no unicode superscript F)
|
||||
postfix [parsing_only] `⁻¹ᴱ`:std.prec.max_plus := inverse
|
||||
|
||||
definition is_isomorphism [class] (F : C ⇒ D) := fully_faithful F × is_equiv (to_fun_ob F)
|
||||
|
||||
structure equivalence (C D : Precategory) :=
|
||||
(to_functor : C ⇒ D)
|
||||
(struct : is_equivalence to_functor)
|
||||
|
||||
structure isomorphism (C D : Precategory) :=
|
||||
(to_functor : C ⇒ D)
|
||||
(struct : is_isomorphism to_functor)
|
||||
|
||||
structure weak_equivalence (C D : Precategory) :=
|
||||
mk' :: (intermediate : Precategory)
|
||||
(left_functor : intermediate ⇒ C)
|
||||
(right_functor : intermediate ⇒ D)
|
||||
[structl : is_weak_equivalence left_functor]
|
||||
[structr : is_weak_equivalence right_functor]
|
||||
|
||||
infix ` ≃c `:25 := equivalence
|
||||
infix ` ≅c `:25 := isomorphism
|
||||
infix ` ≃w `:25 := weak_equivalence
|
||||
|
||||
attribute equivalence.struct isomorphism.struct [instance] [priority 1500]
|
||||
attribute equivalence.to_functor isomorphism.to_functor [coercion]
|
||||
|
||||
definition is_iso_unit [instance] (F : C ⇒ D) [H : is_equivalence F] : is_iso (unit F) :=
|
||||
!is_equivalence.is_iso_unit
|
||||
|
||||
definition is_iso_counit [instance] (F : C ⇒ D) [H : is_equivalence F] : is_iso (counit F) :=
|
||||
!is_equivalence.is_iso_counit
|
||||
|
||||
definition iso_unit (F : C ⇒ D) [H : is_equivalence F] : F⁻¹ᴱ ∘f F ≅ 1 :=
|
||||
(@(iso.mk _) !is_iso_unit)⁻¹ⁱ
|
||||
|
||||
definition iso_counit (F : C ⇒ D) [H : is_equivalence F] : F ∘f F⁻¹ᴱ ≅ 1 :=
|
||||
@(iso.mk _) !is_iso_counit
|
||||
|
||||
definition split_essentially_surjective_of_is_equivalence [instance] (F : C ⇒ D)
|
||||
[is_equivalence F] : split_essentially_surjective F :=
|
||||
begin
|
||||
intro d, fconstructor,
|
||||
{ exact F⁻¹ d},
|
||||
{ exact componentwise_iso (@(iso.mk (counit F)) !is_iso_counit) d}
|
||||
end
|
||||
|
||||
end category
|
||||
|
||||
namespace category
|
||||
section
|
||||
parameters {C D : Precategory} {F : C ⇒ D} {G : D ⇒ C} (η : G ∘f F ≅ 1) (ε : F ∘f G ≅ 1)
|
||||
|
||||
private definition ηn : 1 ⟹ G ∘f F := to_inv η
|
||||
private definition εn : F ∘f G ⟹ 1 := to_hom ε
|
||||
|
||||
private definition ηi (c : C) : G (F c) ≅ c := componentwise_iso η c
|
||||
private definition εi (d : D) : F (G d) ≅ d := componentwise_iso ε d
|
||||
|
||||
private definition ηi' (c : C) : G (F c) ≅ c :=
|
||||
to_fun_iso G (to_fun_iso F (ηi c)⁻¹ⁱ) ⬝i to_fun_iso G (εi (F c)) ⬝i ηi c
|
||||
|
||||
local attribute ηn εn ηi εi ηi' [reducible]
|
||||
|
||||
private theorem adj_η_natural {c c' : C} (f : hom c c')
|
||||
: G (F f) ∘ to_inv (ηi' c) = to_inv (ηi' c') ∘ f :=
|
||||
let ηi'_nat : G ∘f F ⟹ 1 :=
|
||||
calc
|
||||
G ∘f F ⟹ (G ∘f F) ∘f 1 : id_right_natural_rev (G ∘f F)
|
||||
... ⟹ (G ∘f F) ∘f (G ∘f F) : (G ∘f F) ∘fn ηn
|
||||
... ⟹ ((G ∘f F) ∘f G) ∘f F : assoc_natural (G ∘f F) G F
|
||||
... ⟹ (G ∘f (F ∘f G)) ∘f F : assoc_natural_rev G F G ∘nf F
|
||||
... ⟹ (G ∘f 1) ∘f F : (G ∘fn εn) ∘nf F
|
||||
... ⟹ G ∘f F : id_right_natural G ∘nf F
|
||||
... ⟹ 1 : to_hom η
|
||||
in
|
||||
begin
|
||||
refine is_natural_inverse' (G ∘f F) functor.id ηi' ηi'_nat _ f,
|
||||
intro c, esimp, rewrite [+id_left,id_right]
|
||||
end
|
||||
|
||||
private theorem adjointify_adjH (c : C) :
|
||||
to_hom (εi (F c)) ∘ F (to_hom (ηi' c))⁻¹ = id :=
|
||||
begin
|
||||
rewrite [respect_inv], apply comp_inverse_eq_of_eq_comp,
|
||||
rewrite [id_left,↑ηi',+respect_comp,+respect_inv',assoc], apply eq_comp_inverse_of_comp_eq,
|
||||
rewrite [↑εi,-naturality_iso_id ε (F c)],
|
||||
symmetry, exact naturality εn (F (to_hom (ηi c)))
|
||||
end
|
||||
|
||||
private theorem adjointify_adjK (d : D) :
|
||||
G (to_hom (εi d)) ∘ to_hom (ηi' (G d))⁻¹ⁱ = id :=
|
||||
begin
|
||||
apply comp_inverse_eq_of_eq_comp,
|
||||
rewrite [id_left,↑ηi',+respect_inv',assoc], apply eq_comp_inverse_of_comp_eq,
|
||||
rewrite [↑ηi,-naturality_iso_id η (G d),↑εi,naturality_iso_id ε d],
|
||||
exact naturality (to_hom η) (G (to_hom (εi d))),
|
||||
end
|
||||
|
||||
parameter (G)
|
||||
include η ε
|
||||
definition is_equivalence.mk : is_equivalence F :=
|
||||
begin
|
||||
fapply is_equivalence.mk',
|
||||
{ exact G},
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro c, exact to_inv (ηi' c)},
|
||||
{ intro c c' f, exact adj_η_natural f}},
|
||||
{ exact εn},
|
||||
{ exact adjointify_adjH},
|
||||
{ exact adjointify_adjK},
|
||||
{ exact @(is_natural_iso _) (λc, !is_iso_inverse)},
|
||||
{ unfold εn, apply iso.struct, },
|
||||
end
|
||||
|
||||
definition equivalence.MK : C ≃c D :=
|
||||
equivalence.mk F is_equivalence.mk
|
||||
end
|
||||
|
||||
section
|
||||
parameters {C D : Precategory} (F : C ⇒ D)
|
||||
[H₁ : fully_faithful F] [H₂ : split_essentially_surjective F]
|
||||
|
||||
include H₁ H₂
|
||||
definition inverse_of_fully_faithful_of_split_essentially_surjective [constructor] : D ⇒ C :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ exact λd, (H₂ d).1},
|
||||
{ intro d d' g, apply (to_fun_hom F)⁻¹ᶠ, refine to_inv (H₂ d').2 ∘ g ∘ to_hom (H₂ d).2},
|
||||
{ intro d, apply inv_eq_of_eq, rewrite [id_left, respect_id, to_left_inverse]},
|
||||
{ intros d₁ d₂ d₃ g f, apply inv_eq_of_eq,
|
||||
rewrite [respect_comp, +right_inv (to_fun_hom F), +assoc', comp_inverse_cancel_left]}
|
||||
end
|
||||
|
||||
definition is_equivalence_of_fully_faithful_of_split_essentially_surjective [constructor]
|
||||
: is_equivalence F :=
|
||||
begin
|
||||
fapply is_equivalence.mk,
|
||||
{ exact inverse_of_fully_faithful_of_split_essentially_surjective},
|
||||
{ fapply natural_iso.mk',
|
||||
{ intro c, esimp, apply reflect_iso F, exact (H₂ (F c)).2},
|
||||
intro c c' f, esimp, apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
rewrite [+respect_comp, +right_inv (to_fun_hom F), comp_inverse_cancel_left]},
|
||||
{ fapply natural_iso.mk',
|
||||
{ intro c, esimp, exact (H₂ c).2},
|
||||
intro c c' f, esimp, rewrite [right_inv (to_fun_hom F), comp_inverse_cancel_left]}
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
variables {C D E : Precategory} {F : C ⇒ D}
|
||||
|
||||
--TODO: add variants
|
||||
definition unit_eq_counit_inv (F : C ⇒ D) [H : is_equivalence F] (c : C) :
|
||||
to_fun_hom F (natural_map (unit F) c) =
|
||||
@(is_iso.inverse (counit F (F c))) (@(componentwise_is_iso (counit F)) !is_iso_counit (F c)) :=
|
||||
begin
|
||||
apply eq_inverse_of_comp_eq_id, apply counit_unit_eq
|
||||
end
|
||||
|
||||
definition fully_faithful_of_is_equivalence [instance] [constructor] (F : C ⇒ D)
|
||||
[H : is_equivalence F] : fully_faithful F :=
|
||||
begin
|
||||
intro c c',
|
||||
fapply adjointify,
|
||||
{ intro g, exact natural_map (@(iso.inverse (unit F)) !is_iso_unit) c' ∘ F⁻¹ g ∘ unit F c},
|
||||
{ intro g, rewrite [+respect_comp,▸*],
|
||||
xrewrite [natural_map_inverse (unit F) c', respect_inv'],
|
||||
apply inverse_comp_eq_of_eq_comp,
|
||||
rewrite [+unit_eq_counit_inv],
|
||||
esimp, exact naturality (counit F)⁻¹ _},
|
||||
{ intro f, xrewrite [▸*,natural_map_inverse (unit F) c'], apply inverse_comp_eq_of_eq_comp,
|
||||
apply naturality (unit F)},
|
||||
end
|
||||
|
||||
definition is_isomorphism.mk [constructor] {F : C ⇒ D} (G : D ⇒ C)
|
||||
(p : G ∘f F = 1) (q : F ∘f G = 1) : is_isomorphism F :=
|
||||
begin
|
||||
constructor,
|
||||
{ apply fully_faithful_of_is_equivalence, fapply is_equivalence.mk,
|
||||
{ exact G},
|
||||
{ apply iso_of_eq p},
|
||||
{ apply iso_of_eq q}},
|
||||
{ fapply adjointify,
|
||||
{ exact G},
|
||||
{ exact ap010 to_fun_ob q},
|
||||
{ exact ap010 to_fun_ob p}}
|
||||
end
|
||||
|
||||
definition isomorphism.MK [constructor] (F : C ⇒ D) (G : D ⇒ C)
|
||||
(p : G ∘f F = 1) (q : F ∘f G = 1) : C ≅c D :=
|
||||
isomorphism.mk F (is_isomorphism.mk G p q)
|
||||
|
||||
definition is_equiv_ob_of_is_isomorphism [instance] [unfold 4] (F : C ⇒ D)
|
||||
[H : is_isomorphism F] : is_equiv (to_fun_ob F) :=
|
||||
pr2 H
|
||||
|
||||
definition fully_faithful_of_is_isomorphism [unfold 4] (F : C ⇒ D)
|
||||
[H : is_isomorphism F] : fully_faithful F :=
|
||||
pr1 H
|
||||
|
||||
section
|
||||
local attribute fully_faithful_of_is_isomorphism [instance]
|
||||
|
||||
definition strict_inverse [constructor] (F : C ⇒ D) [H : is_isomorphism F] : D ⇒ C :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ intro d, exact (to_fun_ob F)⁻¹ᶠ d},
|
||||
{ intro d d' g, exact (to_fun_hom F)⁻¹ᶠ (inv_of_eq !right_inv ∘ g ∘ hom_of_eq !right_inv)},
|
||||
{ intro d, apply inv_eq_of_eq, rewrite [respect_id,id_left], apply left_inverse},
|
||||
{ intro d₁ d₂ d₃ g₂ g₁, apply inv_eq_of_eq, rewrite [respect_comp F,+right_inv (to_fun_hom F)],
|
||||
rewrite [+assoc], esimp, /-apply ap (λx, (x ∘ _) ∘ _), FAILS-/ refine ap (λx, (x ∘ _) ∘ _) _,
|
||||
refine !id_right⁻¹ ⬝ _, rewrite [▸*,-+assoc], refine ap (λx, _ ∘ _ ∘ x) _,
|
||||
exact !right_inverse⁻¹},
|
||||
end
|
||||
|
||||
postfix /-[parsing-only]-/ `⁻¹ˢ`:std.prec.max_plus := strict_inverse
|
||||
|
||||
definition strict_right_inverse (F : C ⇒ D) [H : is_isomorphism F] : F ∘f F⁻¹ˢ = 1 :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{ intro d, esimp, apply right_inv},
|
||||
{ intro d d' g,
|
||||
rewrite [▸*, right_inv (to_fun_hom F), +assoc],
|
||||
rewrite [↑[hom_of_eq,inv_of_eq,iso.to_inv], right_inverse],
|
||||
rewrite [id_left], apply comp_inverse_cancel_right},
|
||||
end
|
||||
|
||||
definition strict_left_inverse (F : C ⇒ D) [H : is_isomorphism F] : F⁻¹ˢ ∘f F = 1 :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{ intro d, esimp, apply left_inv},
|
||||
{ intro d d' g, esimp, apply comp_eq_of_eq_inverse_comp, apply comp_inverse_eq_of_eq_comp,
|
||||
apply inv_eq_of_eq, rewrite [+respect_comp,-assoc], apply ap011 (λx y, x ∘ F g ∘ y),
|
||||
{ rewrite [adj], rewrite [▸*,respect_inv_of_eq F]},
|
||||
{ rewrite [adj,▸*,respect_hom_of_eq F]}},
|
||||
end
|
||||
end
|
||||
|
||||
definition is_equivalence_of_is_isomorphism [instance] [constructor] (F : C ⇒ D)
|
||||
[is_isomorphism F] : is_equivalence F :=
|
||||
begin
|
||||
fapply is_equivalence.mk,
|
||||
{ apply F⁻¹ˢ},
|
||||
{ apply iso_of_eq !strict_left_inverse},
|
||||
{ apply iso_of_eq !strict_right_inverse},
|
||||
end
|
||||
|
||||
definition equivalence_of_isomorphism [constructor] (F : C ≅c D) : C ≃c D :=
|
||||
equivalence.mk F _
|
||||
|
||||
theorem is_prop_is_equivalence [instance] {C : Category} {D : Precategory} (F : C ⇒ D)
|
||||
: is_prop (is_equivalence F) :=
|
||||
begin
|
||||
have f : is_equivalence F ≃ Σ(H : is_left_adjoint F), is_iso (unit F) × is_iso (counit F),
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro H, induction H, fconstructor: constructor, repeat (esimp;assumption) },
|
||||
{ intro H, induction H with H1 H2, induction H1, induction H2, constructor,
|
||||
repeat (esimp at *;assumption)},
|
||||
{ intro H, induction H with H1 H2, induction H1, induction H2, reflexivity},
|
||||
{ intro H, induction H, reflexivity}
|
||||
end,
|
||||
apply is_trunc_equiv_closed_rev, exact f,
|
||||
end
|
||||
|
||||
theorem is_prop_is_isomorphism [instance] (F : C ⇒ D) : is_prop (is_isomorphism F) :=
|
||||
by unfold is_isomorphism; exact _
|
||||
|
||||
/- closure properties -/
|
||||
|
||||
definition is_isomorphism_id [instance] [constructor] (C : Precategory)
|
||||
: is_isomorphism (1 : C ⇒ C) :=
|
||||
is_isomorphism.mk 1 !functor.id_right !functor.id_right
|
||||
|
||||
definition is_isomorphism_strict_inverse [constructor] (F : C ⇒ D) [K : is_isomorphism F]
|
||||
: is_isomorphism F⁻¹ˢ :=
|
||||
is_isomorphism.mk F !strict_right_inverse !strict_left_inverse
|
||||
|
||||
definition is_isomorphism_compose [constructor] (G : D ⇒ E) (F : C ⇒ D)
|
||||
[H : is_isomorphism G] [K : is_isomorphism F] : is_isomorphism (G ∘f F) :=
|
||||
is_isomorphism.mk
|
||||
(F⁻¹ˢ ∘f G⁻¹ˢ)
|
||||
abstract begin
|
||||
rewrite [functor.assoc,-functor.assoc F⁻¹ˢ,strict_left_inverse,functor.id_right,
|
||||
strict_left_inverse]
|
||||
end end
|
||||
abstract begin
|
||||
rewrite [functor.assoc,-functor.assoc G,strict_right_inverse,functor.id_right,
|
||||
strict_right_inverse]
|
||||
end end
|
||||
|
||||
definition is_equivalence_id [constructor] (C : Precategory) : is_equivalence (1 : C ⇒ C) := _
|
||||
|
||||
definition is_equivalence_inverse [constructor] (F : C ⇒ D) [K : is_equivalence F]
|
||||
: is_equivalence F⁻¹ᴱ :=
|
||||
is_equivalence.mk F (iso_counit F) (iso_unit F)
|
||||
|
||||
definition is_equivalence_compose [constructor] (G : D ⇒ E) (F : C ⇒ D)
|
||||
[H : is_equivalence G] [K : is_equivalence F] : is_equivalence (G ∘f F) :=
|
||||
is_equivalence.mk
|
||||
(F⁻¹ᴱ ∘f G⁻¹ᴱ)
|
||||
abstract begin
|
||||
rewrite [functor.assoc,-functor.assoc F⁻¹ᴱ],
|
||||
refine ((_ ∘fi !iso_unit) ∘if _) ⬝i _,
|
||||
refine (iso_of_eq !functor.id_right ∘if _) ⬝i _,
|
||||
apply iso_unit
|
||||
end end
|
||||
abstract begin
|
||||
rewrite [functor.assoc,-functor.assoc G],
|
||||
refine ((_ ∘fi !iso_counit) ∘if _) ⬝i _,
|
||||
refine (iso_of_eq !functor.id_right ∘if _) ⬝i _,
|
||||
apply iso_counit
|
||||
end end
|
||||
|
||||
variable (C)
|
||||
definition equivalence.refl [refl] [constructor] : C ≃c C :=
|
||||
equivalence.mk _ !is_equivalence_id
|
||||
|
||||
definition isomorphism.refl [refl] [constructor] : C ≅c C :=
|
||||
isomorphism.mk _ !is_isomorphism_id
|
||||
|
||||
variable {C}
|
||||
|
||||
definition equivalence.symm [symm] [constructor] (H : C ≃c D) : D ≃c C :=
|
||||
equivalence.mk _ (is_equivalence_inverse H)
|
||||
|
||||
definition isomorphism.symm [symm] [constructor] (H : C ≅c D) : D ≅c C :=
|
||||
isomorphism.mk _ (is_isomorphism_strict_inverse H)
|
||||
|
||||
definition equivalence.trans [trans] [constructor] (H : C ≃c D) (K : D ≃c E) : C ≃c E :=
|
||||
equivalence.mk _ (is_equivalence_compose K H)
|
||||
|
||||
definition isomorphism.trans [trans] [constructor] (H : C ≅c D) (K : D ≅c E) : C ≅c E :=
|
||||
isomorphism.mk _ (is_isomorphism_compose K H)
|
||||
|
||||
definition equivalence.to_strict_inverse [unfold 3] (H : C ≃c D) : D ⇒ C :=
|
||||
H⁻¹ᴱ
|
||||
|
||||
definition isomorphism.to_strict_inverse [unfold 3] (H : C ≅c D) : D ⇒ C :=
|
||||
H⁻¹ˢ
|
||||
|
||||
definition is_isomorphism_of_is_equivalence [constructor] {C D : Category} (F : C ⇒ D)
|
||||
[H : is_equivalence F] : is_isomorphism F :=
|
||||
begin
|
||||
fapply is_isomorphism.mk,
|
||||
{ exact F⁻¹ᴱ},
|
||||
{ apply eq_of_iso, apply iso_unit},
|
||||
{ apply eq_of_iso, apply iso_counit},
|
||||
end
|
||||
|
||||
definition isomorphism_of_equivalence [constructor] {C D : Category} (F : C ≃c D) : C ≅c D :=
|
||||
isomorphism.mk F !is_isomorphism_of_is_equivalence
|
||||
|
||||
definition equivalence_eq {C : Category} {D : Precategory} {F F' : C ≃c D}
|
||||
(p : equivalence.to_functor F = equivalence.to_functor F') : F = F' :=
|
||||
begin
|
||||
induction F, induction F', exact apd011 equivalence.mk p !is_prop.elimo
|
||||
end
|
||||
|
||||
definition isomorphism_eq {F F' : C ≅c D}
|
||||
(p : isomorphism.to_functor F = isomorphism.to_functor F') : F = F' :=
|
||||
begin
|
||||
induction F, induction F', exact apd011 isomorphism.mk p !is_prop.elimo
|
||||
end
|
||||
|
||||
definition is_equiv_isomorphism_of_equivalence [constructor] (C D : Category)
|
||||
: is_equiv (@equivalence_of_isomorphism C D) :=
|
||||
begin
|
||||
fapply adjointify,
|
||||
{ exact isomorphism_of_equivalence},
|
||||
{ intro F, apply equivalence_eq, reflexivity},
|
||||
{ intro F, apply isomorphism_eq, reflexivity},
|
||||
end
|
||||
|
||||
definition isomorphism_equiv_equivalence [constructor] (C D : Category)
|
||||
: (C ≅c D) ≃ (C ≃c D) :=
|
||||
equiv.mk _ !is_equiv_isomorphism_of_equivalence
|
||||
|
||||
definition isomorphism_of_eq [constructor] {C D : Precategory} (p : C = D) : C ≅c D :=
|
||||
isomorphism.MK (functor_of_eq p)
|
||||
(functor_of_eq p⁻¹)
|
||||
(by induction p; reflexivity)
|
||||
(by induction p; reflexivity)
|
||||
|
||||
definition equiv_ob_of_isomorphism [constructor] {C D : Precategory} (H : C ≅c D) : C ≃ D :=
|
||||
equiv.mk H _
|
||||
|
||||
definition equiv_hom_of_isomorphism [constructor] {C D : Precategory} (H : C ≅c D) (c c' : C)
|
||||
: c ⟶ c' ≃ H c ⟶ H c' :=
|
||||
equiv.mk (to_fun_hom (isomorphism.to_functor H)) _
|
||||
|
||||
/- weak equivalences -/
|
||||
|
||||
theorem is_prop_is_weak_equivalence [instance] (F : C ⇒ D) : is_prop (is_weak_equivalence F) :=
|
||||
by unfold is_weak_equivalence; exact _
|
||||
|
||||
definition is_weak_equivalence_of_is_equivalence [instance] (F : C ⇒ D) [is_equivalence F]
|
||||
: is_weak_equivalence F :=
|
||||
(_, _)
|
||||
|
||||
definition fully_faithful_of_is_weak_equivalence.mk [instance] (F : C ⇒ D)
|
||||
[H : is_weak_equivalence F] : fully_faithful F :=
|
||||
pr1 H
|
||||
|
||||
definition essentially_surjective_of_is_weak_equivalence.mk [instance] (F : C ⇒ D)
|
||||
[H : is_weak_equivalence F] : essentially_surjective F :=
|
||||
pr2 H
|
||||
|
||||
definition is_weak_equivalence_compose (G : D ⇒ E) (F : C ⇒ D)
|
||||
[H : is_weak_equivalence G] [K : is_weak_equivalence F] : is_weak_equivalence (G ∘f F) :=
|
||||
(fully_faithful_compose G F, essentially_surjective_compose G F)
|
||||
|
||||
definition weak_equivalence.mk [constructor] (F : C ⇒ D) (H : is_weak_equivalence F) : C ≃w D :=
|
||||
weak_equivalence.mk' C 1 F
|
||||
|
||||
definition weak_equivalence.symm [unfold 3] : C ≃w D → D ≃w C
|
||||
| (@weak_equivalence.mk' _ _ X F₁ F₂ H₁ H₂) := weak_equivalence.mk' X F₂ F₁
|
||||
|
||||
/- TODO
|
||||
definition is_equiv_isomorphism_of_eq [constructor] (C D : Precategory)
|
||||
: is_equiv (@isomorphism_of_eq C D) :=
|
||||
begin
|
||||
fapply adjointify,
|
||||
{ intro H, fapply Precategory_eq_of_equiv,
|
||||
{ apply equiv_ob_of_isomorphism H},
|
||||
{ exact equiv_hom_of_isomorphism H},
|
||||
{ /-exact sorry FAILS-/ intros, esimp, apply respect_comp}},
|
||||
{ intro H, apply isomorphism_eq, esimp, fapply functor_eq: esimp,
|
||||
{ intro c, exact sorry},
|
||||
{ exact sorry}},
|
||||
{ intro p, induction p, esimp, exact sorry},
|
||||
end
|
||||
|
||||
definition eq_equiv_isomorphism [constructor] (C D : Precategory)
|
||||
: (C = D) ≃ (C ≅c D) :=
|
||||
equiv.mk _ !is_equiv_isomorphism_of_eq
|
||||
|
||||
definition equivalence_of_eq [unfold 3] [reducible] {C D : Precategory} (p : C = D) : C ≃c D :=
|
||||
equivalence_of_isomorphism (isomorphism_of_eq p)
|
||||
|
||||
definition eq_equiv_equivalence [constructor] (C D : Category) : (C = D) ≃ (C ≃c D) :=
|
||||
!eq_equiv_isomorphism ⬝e !isomorphism_equiv_equivalence
|
||||
|
||||
definition is_equivalence_equiv [constructor] (F : C ⇒ D)
|
||||
: is_equivalence F ≃ (fully_faithful F × split_essentially_surjective F) :=
|
||||
sorry
|
||||
|
||||
definition is_equivalence_equiv_is_weak_equivalence [constructor] {C D : Category}
|
||||
(F : C ⇒ D) : is_equivalence F ≃ is_weak_equivalence F :=
|
||||
sorry
|
||||
|
||||
-- weak_equivalence.trans
|
||||
-/
|
||||
|
||||
|
||||
/- TODO?
|
||||
definition is_isomorphism_equiv1 (F : C ⇒ D) : is_equivalence F
|
||||
≃ Σ(G : D ⇒ C) (η : 1 = G ∘f F) (ε : F ∘f G = 1),
|
||||
sorry ⬝ ap (λ(H : C ⇒ C), F ∘f H) η ⬝ sorry = ap (λ(H : D ⇒ D), H ∘f F) ε⁻¹ :=
|
||||
sorry
|
||||
|
||||
definition is_isomorphism_equiv2 (F : C ⇒ D) : is_equivalence F
|
||||
≃ ∃(G : D ⇒ C), 1 = G ∘f F × F ∘f G = 1 :=
|
||||
sorry
|
||||
-/
|
||||
|
||||
end category
|
||||
|
|
@ -1,237 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Definition of functors involving at least two different constructions of categories
|
||||
-/
|
||||
|
||||
import ..constructions.functor ..constructions.product ..constructions.opposite
|
||||
..constructions.set
|
||||
|
||||
open category nat_trans eq prod prod.ops
|
||||
|
||||
namespace functor
|
||||
|
||||
section
|
||||
open iso equiv
|
||||
variables {C D E : Precategory} (F F' : C ×c D ⇒ E) (G G' : C ⇒ E ^c D)
|
||||
/- currying a functor -/
|
||||
definition functor_curry_ob [reducible] [constructor] (c : C) : D ⇒ E :=
|
||||
F ∘f (constant_functor D c ×f 1)
|
||||
|
||||
definition functor_curry_hom [constructor] ⦃c c' : C⦄ (f : c ⟶ c')
|
||||
: functor_curry_ob F c ⟹ functor_curry_ob F c' :=
|
||||
F ∘fn (constant_nat_trans D f ×n 1)
|
||||
|
||||
local abbreviation Fhom [constructor] := @functor_curry_hom
|
||||
|
||||
theorem functor_curry_id (c : C) : Fhom F (ID c) = 1 :=
|
||||
nat_trans_eq (λd, respect_id F (c, d))
|
||||
|
||||
theorem functor_curry_comp ⦃c c' c'' : C⦄ (f' : c' ⟶ c'') (f : c ⟶ c')
|
||||
: Fhom F (f' ∘ f) = Fhom F f' ∘n Fhom F f :=
|
||||
begin
|
||||
apply nat_trans_eq,
|
||||
intro d, calc
|
||||
natural_map (Fhom F (f' ∘ f)) d = F (f' ∘ f, id) : by esimp
|
||||
... = F (f' ∘ f, category.id ∘ category.id) : by rewrite id_id
|
||||
... = F ((f',id) ∘ (f, id)) : by esimp
|
||||
... = F (f',id) ∘ F (f, id) : by rewrite [respect_comp F]
|
||||
... = natural_map ((Fhom F f') ∘ (Fhom F f)) d : by esimp
|
||||
end
|
||||
|
||||
definition functor_curry [constructor] : C ⇒ E ^c D :=
|
||||
functor.mk (functor_curry_ob F)
|
||||
(functor_curry_hom F)
|
||||
(functor_curry_id F)
|
||||
(functor_curry_comp F)
|
||||
|
||||
/- currying a functor, flipping the arguments -/
|
||||
definition functor_curry_rev_ob [reducible] [constructor] (d : D) : C ⇒ E :=
|
||||
F ∘f (1 ×f constant_functor C d)
|
||||
|
||||
definition functor_curry_rev_hom [constructor] ⦃d d' : D⦄ (g : d ⟶ d')
|
||||
: functor_curry_rev_ob F d ⟹ functor_curry_rev_ob F d' :=
|
||||
F ∘fn (1 ×n constant_nat_trans C g)
|
||||
|
||||
local abbreviation Fhomr [constructor] := @functor_curry_rev_hom
|
||||
theorem functor_curry_rev_id (d : D) : Fhomr F (ID d) = nat_trans.id :=
|
||||
nat_trans_eq (λc, respect_id F (c, d))
|
||||
|
||||
theorem functor_curry_rev_comp ⦃d d' d'' : D⦄ (g' : d' ⟶ d'') (g : d ⟶ d')
|
||||
: Fhomr F (g' ∘ g) = Fhomr F g' ∘n Fhomr F g :=
|
||||
begin
|
||||
apply nat_trans_eq, esimp, intro c, rewrite [-id_id at {1}], apply respect_comp F
|
||||
end
|
||||
|
||||
definition functor_curry_rev [constructor] : D ⇒ E ^c C :=
|
||||
functor.mk (functor_curry_rev_ob F)
|
||||
(functor_curry_rev_hom F)
|
||||
(functor_curry_rev_id F)
|
||||
(functor_curry_rev_comp F)
|
||||
|
||||
/- uncurrying a functor -/
|
||||
|
||||
definition functor_uncurry_ob [reducible] (p : C ×c D) : E :=
|
||||
to_fun_ob (G p.1) p.2
|
||||
|
||||
definition functor_uncurry_hom ⦃p p' : C ×c D⦄ (f : hom p p')
|
||||
: functor_uncurry_ob G p ⟶ functor_uncurry_ob G p' :=
|
||||
to_fun_hom (to_fun_ob G p'.1) f.2 ∘ natural_map (to_fun_hom G f.1) p.2
|
||||
local abbreviation Ghom := @functor_uncurry_hom
|
||||
|
||||
theorem functor_uncurry_id (p : C ×c D) : Ghom G (ID p) = id :=
|
||||
calc
|
||||
Ghom G (ID p) = to_fun_hom (to_fun_ob G p.1) id ∘ natural_map (to_fun_hom G id) p.2 : by esimp
|
||||
... = id ∘ natural_map (to_fun_hom G id) p.2 : by rewrite respect_id
|
||||
... = id ∘ natural_map nat_trans.id p.2 : by rewrite respect_id
|
||||
... = id : id_id
|
||||
|
||||
theorem functor_uncurry_comp ⦃p p' p'' : C ×c D⦄ (f' : p' ⟶ p'') (f : p ⟶ p')
|
||||
: Ghom G (f' ∘ f) = Ghom G f' ∘ Ghom G f :=
|
||||
calc
|
||||
Ghom G (f' ∘ f)
|
||||
= to_fun_hom (to_fun_ob G p''.1) (f'.2 ∘ f.2) ∘ natural_map (to_fun_hom G (f'.1 ∘ f.1)) p.2 : by esimp
|
||||
... = (to_fun_hom (to_fun_ob G p''.1) f'.2 ∘ to_fun_hom (to_fun_ob G p''.1) f.2)
|
||||
∘ natural_map (to_fun_hom G (f'.1 ∘ f.1)) p.2 : by rewrite respect_comp
|
||||
... = (to_fun_hom (to_fun_ob G p''.1) f'.2 ∘ to_fun_hom (to_fun_ob G p''.1) f.2)
|
||||
∘ natural_map (to_fun_hom G f'.1 ∘ to_fun_hom G f.1) p.2 : by rewrite respect_comp
|
||||
... = (to_fun_hom (to_fun_ob G p''.1) f'.2 ∘ to_fun_hom (to_fun_ob G p''.1) f.2)
|
||||
∘ (natural_map (to_fun_hom G f'.1) p.2 ∘ natural_map (to_fun_hom G f.1) p.2) : by esimp
|
||||
... = (to_fun_hom (to_fun_ob G p''.1) f'.2 ∘ natural_map (to_fun_hom G f'.1) p'.2)
|
||||
∘ (to_fun_hom (to_fun_ob G p'.1) f.2 ∘ natural_map (to_fun_hom G f.1) p.2) :
|
||||
by rewrite [square_prepostcompose (!naturality⁻¹ᵖ) _ _]
|
||||
... = Ghom G f' ∘ Ghom G f : by esimp
|
||||
|
||||
definition functor_uncurry [constructor] : C ×c D ⇒ E :=
|
||||
functor.mk (functor_uncurry_ob G)
|
||||
(functor_uncurry_hom G)
|
||||
(functor_uncurry_id G)
|
||||
(functor_uncurry_comp G)
|
||||
|
||||
definition functor_uncurry_functor_curry : functor_uncurry (functor_curry F) = F :=
|
||||
functor_eq (λp, ap (to_fun_ob F) !prod.eta)
|
||||
begin
|
||||
intro cd cd' fg,
|
||||
cases cd with c d, cases cd' with c' d', cases fg with f g,
|
||||
transitivity to_fun_hom (functor_uncurry (functor_curry F)) (f, g),
|
||||
apply id_leftright,
|
||||
show (functor_uncurry (functor_curry F)) (f, g) = F (f,g),
|
||||
from calc
|
||||
(functor_uncurry (functor_curry F)) (f, g)
|
||||
= to_fun_hom F (id, g) ∘ to_fun_hom F (f, id) : by esimp
|
||||
... = F (category.id ∘ f, g ∘ category.id) : (respect_comp F (id,g) (f,id))⁻¹
|
||||
... = F (f, g ∘ category.id) : by rewrite id_left
|
||||
... = F (f,g) : by rewrite id_right,
|
||||
end
|
||||
|
||||
definition functor_curry_functor_uncurry_ob (c : C)
|
||||
: functor_curry (functor_uncurry G) c = G c :=
|
||||
begin
|
||||
fapply functor_eq,
|
||||
{ intro d, reflexivity},
|
||||
{ intro d d' g, refine !id_leftright ⬝ _, esimp,
|
||||
rewrite [▸*, ↑functor_uncurry_hom, respect_id, ▸*, id_right]}
|
||||
end
|
||||
|
||||
definition functor_curry_functor_uncurry : functor_curry (functor_uncurry G) = G :=
|
||||
begin
|
||||
fapply functor_eq, exact (functor_curry_functor_uncurry_ob G),
|
||||
intro c c' f,
|
||||
fapply nat_trans_eq,
|
||||
intro d,
|
||||
apply concat,
|
||||
{apply (ap (λx, x ∘ _)),
|
||||
apply concat, apply natural_map_hom_of_eq, apply (ap hom_of_eq), apply ap010_functor_eq},
|
||||
apply concat,
|
||||
{apply (ap (λx, _ ∘ x)), apply (ap (λx, _ ∘ x)),
|
||||
apply concat, apply natural_map_inv_of_eq,
|
||||
apply (ap (λx, hom_of_eq x⁻¹)), apply ap010_functor_eq},
|
||||
apply concat, apply id_leftright,
|
||||
apply concat, apply (ap (λx, x ∘ _)), apply respect_id,
|
||||
apply id_left
|
||||
end
|
||||
|
||||
/-
|
||||
This only states that the carriers of (C ^ D) ^ E and C ^ (E × D) are equivalent.
|
||||
In [exponential laws] we prove that these are in fact isomorphic categories
|
||||
-/
|
||||
definition prod_functor_equiv_functor_functor [constructor] (C D E : Precategory)
|
||||
: (C ×c D ⇒ E) ≃ (C ⇒ E ^c D) :=
|
||||
equiv.MK functor_curry
|
||||
functor_uncurry
|
||||
functor_curry_functor_uncurry
|
||||
functor_uncurry_functor_curry
|
||||
|
||||
variables {F F' G G'}
|
||||
definition nat_trans_curry_nat [constructor] (η : F ⟹ F') (c : C)
|
||||
: functor_curry_ob F c ⟹ functor_curry_ob F' c :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro d, exact η (c, d)},
|
||||
{ intro d d' f, apply naturality}
|
||||
end
|
||||
|
||||
definition nat_trans_curry [constructor] (η : F ⟹ F')
|
||||
: functor_curry F ⟹ functor_curry F' :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ exact nat_trans_curry_nat η},
|
||||
{ intro c c' f, apply nat_trans_eq, intro d, esimp, apply naturality}
|
||||
end
|
||||
|
||||
definition nat_trans_uncurry [constructor] (η : G ⟹ G')
|
||||
: functor_uncurry G ⟹ functor_uncurry G' :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro v, unfold functor_uncurry_ob, exact (η v.1) v.2},
|
||||
{ intro v w f, unfold functor_uncurry_hom,
|
||||
rewrite [-assoc, ap010 natural_map (naturality η f.1) v.2, assoc, naturality, -assoc]}
|
||||
end
|
||||
end
|
||||
|
||||
section
|
||||
open is_trunc
|
||||
|
||||
/- hom-functors -/
|
||||
|
||||
definition hom_functor_assoc {C : Precategory} {a1 a2 a3 a4 a5 a6 : C}
|
||||
(f1 : hom a5 a6) (f2 : hom a4 a5) (f3 : hom a3 a4) (f4 : hom a2 a3) (f5 : hom a1 a2)
|
||||
: (f1 ∘ f2) ∘ f3 ∘ (f4 ∘ f5) = f1 ∘ (f2 ∘ f3 ∘ f4) ∘ f5 :=
|
||||
calc
|
||||
_ = f1 ∘ f2 ∘ f3 ∘ f4 ∘ f5 : by rewrite -assoc
|
||||
... = f1 ∘ (f2 ∘ f3) ∘ f4 ∘ f5 : by rewrite -assoc
|
||||
... = f1 ∘ ((f2 ∘ f3) ∘ f4) ∘ f5 : by rewrite -(assoc (f2 ∘ f3) _ _)
|
||||
... = _ : by rewrite (assoc f2 f3 f4)
|
||||
|
||||
-- the functor hom(-,-)
|
||||
definition hom_functor.{u v} [constructor] (C : Precategory.{u v}) : Cᵒᵖ ×c C ⇒ set.{v} :=
|
||||
functor.mk
|
||||
(λ (x : Cᵒᵖ ×c C), @homset (Cᵒᵖ) C x.1 x.2)
|
||||
(λ (x y : Cᵒᵖ ×c C) (f : @category.precategory.hom (Cᵒᵖ ×c C) (Cᵒᵖ ×c C) x y)
|
||||
(h : @homset (Cᵒᵖ) C x.1 x.2), f.2 ∘[C] (h ∘[C] f.1))
|
||||
(λ x, abstract @eq_of_homotopy _ _ _ (ID (@homset Cᵒᵖ C x.1 x.2))
|
||||
(λ h, concat (by apply @id_left) (by apply @id_right)) end)
|
||||
(λ x y z g f, abstract eq_of_homotopy (by intros; apply @hom_functor_assoc) end)
|
||||
|
||||
-- the functor hom(-, c)
|
||||
definition hom_functor_left.{u v} [constructor] {C : Precategory.{u v}} (c : C)
|
||||
: Cᵒᵖ ⇒ set.{v} :=
|
||||
functor_curry_rev_ob !hom_functor c
|
||||
|
||||
-- the functor hom(c, -)
|
||||
definition hom_functor_right.{u v} [constructor] {C : Precategory.{u v}} (c : C)
|
||||
: C ⇒ set.{v} :=
|
||||
functor_curry_ob !hom_functor c
|
||||
|
||||
definition nat_trans_hom_functor_left [constructor] {C : Precategory}
|
||||
⦃c c' : C⦄ (f : c ⟶ c') : hom_functor_left c ⟹ hom_functor_left c' :=
|
||||
functor_curry_rev_hom !hom_functor f
|
||||
|
||||
-- the yoneda embedding itself is defined in [yoneda].
|
||||
end
|
||||
|
||||
|
||||
|
||||
end functor
|
||||
|
|
@ -1,284 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015-2016 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Exponential laws
|
||||
-/
|
||||
|
||||
import types.unit .equivalence .examples
|
||||
..constructions.terminal ..constructions.initial ..constructions.product ..constructions.sum
|
||||
..constructions.discrete
|
||||
|
||||
open eq category functor is_trunc nat_trans iso unit prod sum prod.ops bool
|
||||
|
||||
namespace category
|
||||
|
||||
/- C ^ 0 ≅ 1 -/
|
||||
|
||||
definition functor_zero_iso_one [constructor] (C : Precategory) : C ^c 0 ≅c 1 :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ apply terminal_functor},
|
||||
{ apply point, apply initial_functor},
|
||||
{ fapply functor_eq: intros; esimp at *,
|
||||
{ apply eq_of_is_contr},
|
||||
{ apply nat_trans_eq, intro u, induction u}},
|
||||
{ fapply functor_eq: intros; esimp at *,
|
||||
{ induction x, reflexivity},
|
||||
{ induction f, reflexivity}},
|
||||
end
|
||||
|
||||
/- 0 ^ C ≅ 0 if C is inhabited -/
|
||||
|
||||
definition zero_functor_functor_zero [constructor] (C : Precategory) (c : C) : 0 ^c C ⇒ 0 :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro F, exact F c},
|
||||
{ intro F, eapply empty.elim (F c)},
|
||||
{ intro F, eapply empty.elim (F c)},
|
||||
{ intro F, eapply empty.elim (F c)},
|
||||
end
|
||||
|
||||
definition zero_functor_iso_zero [constructor] (C : Precategory) (c : C) : 0 ^c C ≅c 0 :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ exact zero_functor_functor_zero C c},
|
||||
{ apply initial_functor},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro F, apply empty.elim (F c)},
|
||||
{ intro F, apply empty.elim (F c)}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro u, apply empty.elim u},
|
||||
{ apply empty.elim}},
|
||||
end
|
||||
|
||||
/- C ^ 1 ≅ C -/
|
||||
|
||||
definition functor_one_iso [constructor] (C : Precategory) : C ^c 1 ≅c C :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ exact !eval_functor star},
|
||||
{ apply functor_curry, apply pr1_functor},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro F, fapply functor_eq: esimp,
|
||||
{ intro u, induction u, reflexivity},
|
||||
{ intro u v f, induction u, induction v, induction f, esimp, rewrite [+id_id,-respect_id]}},
|
||||
{ intro F G η, apply nat_trans_eq, intro u, esimp,
|
||||
rewrite [natural_map_hom_of_eq _ u, natural_map_inv_of_eq _ u,▸*,+ap010_functor_eq _ _ u],
|
||||
induction u, rewrite [▸*, id_leftright]}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro c d f, rewrite [▸*, id_leftright]}},
|
||||
end
|
||||
|
||||
/- 1 ^ C ≅ 1 -/
|
||||
|
||||
definition one_functor_iso_one [constructor] (C : Precategory) : 1 ^c C ≅c 1 :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ apply terminal_functor},
|
||||
{ apply functor_curry, apply pr1_functor},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro F, fapply functor_eq: esimp,
|
||||
{ intro c, apply unit.eta},
|
||||
{ intro c d f, apply unit.eta}},
|
||||
{ intro F G η, fapply nat_trans_eq, esimp, intro c, apply unit.eta}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro u, apply unit.eta},
|
||||
{ intro u v f, apply unit.eta}},
|
||||
end
|
||||
|
||||
/- C ^ 2 ≅ C × C -/
|
||||
|
||||
definition functor_two_right [constructor] (C : Precategory)
|
||||
: C ^c c2 ⇒ C ×c C :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro F, exact (F ff, F tt)},
|
||||
{ intro F G η, esimp, exact (η ff, η tt)},
|
||||
{ intro F, reflexivity},
|
||||
{ intro F G H η θ, reflexivity}
|
||||
end
|
||||
|
||||
definition functor_two_left [constructor] (C : Precategory)
|
||||
: C ×c C ⇒ C ^c c2 :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro v, exact c2_functor C v.1 v.2},
|
||||
{ intro v w f, exact c2_nat_trans f.1 f.2},
|
||||
{ intro v, apply nat_trans_eq, esimp, intro b, induction b: reflexivity},
|
||||
{ intro u v w g f, apply nat_trans_eq, esimp, intro b, induction b: reflexivity}
|
||||
end
|
||||
|
||||
definition functor_two_iso [constructor] (C : Precategory)
|
||||
: C ^c c2 ≅c C ×c C :=
|
||||
begin
|
||||
fapply isomorphism.MK: esimp,
|
||||
{ apply functor_two_right},
|
||||
{ apply functor_two_left},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro F, apply c2_functor_eta},
|
||||
{ intro F G η, fapply nat_trans_eq, intro b, esimp,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G, @natural_map_inv_of_eq _ _ _ F,
|
||||
↑c2_functor_eta, +@ap010_functor_eq c2 C, ▸*],
|
||||
induction b: esimp; apply id_leftright}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro v, apply prod.eta},
|
||||
{ intro v w f, induction v, induction w, esimp, apply prod_eq: apply id_leftright}},
|
||||
end
|
||||
|
||||
/- Cᵒᵖ ^ Dᵒᵖ ≅ (C ^ D)ᵒᵖ -/
|
||||
|
||||
definition opposite_functor_opposite_iso [constructor] (C D : Precategory)
|
||||
: Cᵒᵖ ^c Dᵒᵖ ≅c (C ^c D)ᵒᵖ :=
|
||||
begin
|
||||
fapply isomorphism.MK: esimp,
|
||||
{ apply opposite_functor_opposite_right},
|
||||
{ apply opposite_functor_opposite_left},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ exact opposite_rev_opposite_functor},
|
||||
{ intro F G η, fapply nat_trans_eq, esimp, intro d,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G, @natural_map_inv_of_eq _ _ _ F,
|
||||
↑opposite_rev_opposite_functor, +@ap010_functor_eq Dᵒᵖ Cᵒᵖ, ▸*],
|
||||
exact !id_right ⬝ !id_left}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ exact opposite_opposite_rev_functor},
|
||||
{ intro F G η, fapply nat_trans_eq, esimp, intro d,
|
||||
rewrite [opposite_hom_of_eq, opposite_inv_of_eq, @natural_map_hom_of_eq _ _ _ F,
|
||||
@natural_map_inv_of_eq _ _ _ G, ↑opposite_opposite_rev_functor, +@ap010_functor_eq, ▸*],
|
||||
exact !id_right ⬝ !id_left}},
|
||||
end
|
||||
|
||||
/- C ^ (D + E) ≅ C ^ D × C ^ E -/
|
||||
|
||||
definition functor_sum_right [constructor] (C D E : Precategory)
|
||||
: C ^c (D +c E) ⇒ C ^c D ×c C ^c E :=
|
||||
begin
|
||||
apply functor_prod,
|
||||
{ apply precomposition_functor, apply inl_functor},
|
||||
{ apply precomposition_functor, apply inr_functor}
|
||||
end
|
||||
|
||||
definition functor_sum_left [constructor] (C D E : Precategory)
|
||||
: C ^c D ×c C ^c E ⇒ C ^c (D +c E) :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro V, exact V.1 +f V.2},
|
||||
{ intro V W ν, apply sum_nat_trans, exact ν.1, exact ν.2},
|
||||
{ intro V, apply nat_trans_eq, intro a, induction a: reflexivity},
|
||||
{ intro U V W ν μ, apply nat_trans_eq, intro a, induction a: reflexivity}
|
||||
-- REPORT: cannot abstract
|
||||
end
|
||||
|
||||
definition functor_sum_iso [constructor] (C D E : Precategory)
|
||||
: C ^c (D +c E) ≅c C ^c D ×c C ^c E :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ apply functor_sum_right},
|
||||
{ apply functor_sum_left},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ exact sum_functor_eta},
|
||||
{ intro F G η, fapply nat_trans_eq, intro a, esimp,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G _ a, @natural_map_inv_of_eq _ _ _ F _ a,
|
||||
↑sum_functor_eta,+ap010_functor_eq _ _ a],
|
||||
induction a: esimp: apply id_leftright}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro V, induction V with F G, apply prod_eq: esimp,
|
||||
apply sum_functor_inl, apply sum_functor_inr},
|
||||
{ intro V W ν, induction V with F G, induction W with F' G', induction ν with η θ,
|
||||
apply prod_eq: apply nat_trans_eq,
|
||||
{ intro d, rewrite [▸*,@pr1_hom_of_eq (C ^c D) (C ^c E), @pr1_inv_of_eq (C ^c D) (C ^c E),
|
||||
@natural_map_hom_of_eq _ _ _ F' _ d, @natural_map_inv_of_eq _ _ _ F _ d,
|
||||
↑sum_functor_inl,+ap010_functor_eq _ _ d, ▸*], apply id_leftright},
|
||||
{ intro e, rewrite [▸*,@pr2_hom_of_eq (C ^c D) (C ^c E), @pr2_inv_of_eq (C ^c D) (C ^c E),
|
||||
@natural_map_hom_of_eq _ _ _ G' _ e, @natural_map_inv_of_eq _ _ _ G _ e,
|
||||
↑sum_functor_inr,+ap010_functor_eq _ _ e, ▸*], apply id_leftright}}},
|
||||
end
|
||||
|
||||
/- (C × D) ^ E ≅ C ^ E × D ^ E -/
|
||||
|
||||
definition prod_functor_right [constructor] (C D E : Precategory)
|
||||
: (C ×c D) ^c E ⇒ C ^c E ×c D ^c E :=
|
||||
begin
|
||||
apply functor_prod,
|
||||
{ apply postcomposition_functor, apply pr1_functor},
|
||||
{ apply postcomposition_functor, apply pr2_functor}
|
||||
end
|
||||
|
||||
definition prod_functor_left [constructor] (C D E : Precategory)
|
||||
: C ^c E ×c D ^c E ⇒ (C ×c D) ^c E :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro V, exact V.1 ×f V.2},
|
||||
{ intro V W ν, exact prod_nat_trans ν.1 ν.2},
|
||||
{ intro V, apply nat_trans_eq, intro e, reflexivity},
|
||||
{ intro U V W ν μ, apply nat_trans_eq, intro e, reflexivity}
|
||||
end
|
||||
|
||||
definition prod_functor_iso [constructor] (C D E : Precategory)
|
||||
: (C ×c D) ^c E ≅c C ^c E ×c D ^c E :=
|
||||
begin
|
||||
fapply isomorphism.MK,
|
||||
{ apply prod_functor_right},
|
||||
{ apply prod_functor_left},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ exact prod_functor_eta},
|
||||
{ intro F G η, fapply nat_trans_eq, intro e, esimp,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G, @natural_map_inv_of_eq _ _ _ F,↑prod_functor_eta,
|
||||
+ap010_functor_eq, +hom_of_eq_inv, ▸*, pr1_hom_of_eq, pr2_hom_of_eq,
|
||||
pr1_inv_of_eq, pr2_inv_of_eq, ▸*, +id_leftright, prod.eta]}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro V, apply prod_eq: esimp, apply pr1_functor_prod, apply pr2_functor_prod},
|
||||
{ intro V W ν, rewrite [@pr1_hom_of_eq (C ^c E) (D ^c E), @pr2_hom_of_eq (C ^c E) (D ^c E),
|
||||
@pr1_inv_of_eq (C ^c E) (D ^c E), @pr2_inv_of_eq (C ^c E) (D ^c E)],
|
||||
apply prod_eq: apply nat_trans_eq; intro v: esimp,
|
||||
{ rewrite [@natural_map_hom_of_eq _ _ _ W.1, @natural_map_inv_of_eq _ _ _ V.1, ▸*,
|
||||
↑pr1_functor_prod,+ap010_functor_eq, ▸*, id_leftright]},
|
||||
{ rewrite [@natural_map_hom_of_eq _ _ _ W.2, @natural_map_inv_of_eq _ _ _ V.2, ▸*,
|
||||
↑pr2_functor_prod,+ap010_functor_eq, ▸*, id_leftright]}}},
|
||||
end
|
||||
|
||||
/- (C ^ D) ^ E ≅ C ^ (E × D) -/
|
||||
|
||||
definition functor_functor_right [constructor] (C D E : Precategory)
|
||||
: (C ^c D) ^c E ⇒ C ^c (E ×c D) :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ exact functor_uncurry},
|
||||
{ apply @nat_trans_uncurry},
|
||||
{ intro F, apply nat_trans_eq, intro e, reflexivity},
|
||||
{ intro F G H η θ, apply nat_trans_eq, intro e, reflexivity}
|
||||
end
|
||||
|
||||
definition functor_functor_left [constructor] (C D E : Precategory)
|
||||
: C ^c (E ×c D) ⇒ (C ^c D) ^c E :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ exact functor_curry},
|
||||
{ apply @nat_trans_curry},
|
||||
{ intro F, apply nat_trans_eq, intro e, reflexivity},
|
||||
{ intro F G H η θ, apply nat_trans_eq, intro e, reflexivity}
|
||||
end
|
||||
|
||||
definition functor_functor_iso [constructor] (C D E : Precategory)
|
||||
: (C ^c D) ^c E ≅c C ^c (E ×c D) :=
|
||||
begin
|
||||
fapply isomorphism.MK: esimp,
|
||||
{ apply functor_functor_right},
|
||||
{ apply functor_functor_left},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ exact functor_curry_functor_uncurry},
|
||||
{ intro F G η, fapply nat_trans_eq, intro e, esimp,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G, @natural_map_inv_of_eq _ _ _ F,
|
||||
↑functor_curry_functor_uncurry, +@ap010_functor_eq E (C ^c D)],
|
||||
apply nat_trans_eq, intro d, rewrite [▸*, hom_of_eq_inv,
|
||||
@natural_map_hom_of_eq _ _ _ (G e), @natural_map_inv_of_eq _ _ _ (F e),
|
||||
↑functor_curry_functor_uncurry_ob, +@ap010_functor_eq D C, ▸*, id_leftright]}},
|
||||
{ fapply functor_eq: esimp,
|
||||
{ intro F, apply functor_uncurry_functor_curry},
|
||||
{ intro F G η, fapply nat_trans_eq, esimp, intro v, induction v with c d,
|
||||
rewrite [@natural_map_hom_of_eq _ _ _ G, @natural_map_inv_of_eq _ _ _ F,
|
||||
↑functor_uncurry_functor_curry, +@ap010_functor_eq, ▸*], apply id_leftright}},
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
algebra.category.functor
|
||||
========================
|
||||
|
||||
Functors, functor attributes, equivalences, isomorphism, adjointness.
|
||||
|
||||
* [basic](basic.hlean) : Definition and basic properties of functors
|
||||
* [examples](examples.hlean) : Constructions of functors between categories, involving more than one category in the [constructions](../constructions/constructions.md) folder (functors which only depend on one constructions are in the corresponding file). This includes the currying and uncurrying of functors
|
||||
* [attributes](attributes.hlean): Attributes of functors (full, faithful, split essentially surjective, ...)
|
||||
* [adjoint](adjoint.hlean) : Adjoint functors and equivalences
|
||||
* [equivalence](equivalence.hlean) : Equivalences and Isomorphisms
|
||||
* [exponential_laws](exponential_laws.hlean)
|
||||
* [yoneda](yoneda.hlean) : the Yoneda Embedding
|
||||
|
||||
Note: the functor category is defined in [constructions.functor](../constructions/functor.hlean). Functors preserving limits is in [limits.functor_preserve](../limits/functor_preserve.hlean).
|
||||
|
|
@ -1,171 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Yoneda embedding and Yoneda lemma
|
||||
-/
|
||||
|
||||
import .examples .attributes
|
||||
|
||||
open category eq functor prod.ops is_trunc iso is_equiv category.set nat_trans lift
|
||||
|
||||
namespace yoneda
|
||||
|
||||
universe variables u v
|
||||
variable {C : Precategory.{u v}}
|
||||
/-
|
||||
These attributes make sure that the fields of the category "set" reduce to the right things
|
||||
However, we don't want to have them globally, because that will unfold the composition g ∘ f
|
||||
in a Category to category.category.comp g f
|
||||
-/
|
||||
local attribute category.to_precategory [constructor]
|
||||
|
||||
-- should this be defined as "yoneda_embedding Cᵒᵖ"?
|
||||
definition contravariant_yoneda_embedding [constructor] [reducible]
|
||||
(C : Precategory) : Cᵒᵖ ⇒ cset ^c C :=
|
||||
functor_curry !hom_functor
|
||||
|
||||
/-
|
||||
we use (change_fun) to make sure that (to_fun_ob (yoneda_embedding C) c) will reduce to
|
||||
(hom_functor_left c) instead of (functor_curry_rev_ob (hom_functor C) c)
|
||||
-/
|
||||
definition yoneda_embedding [constructor] (C : Precategory.{u v}) : C ⇒ cset ^c Cᵒᵖ :=
|
||||
--(functor_curry_rev !hom_functor)
|
||||
change_fun
|
||||
(functor_curry_rev !hom_functor)
|
||||
hom_functor_left
|
||||
nat_trans_hom_functor_left
|
||||
idp
|
||||
idpo
|
||||
|
||||
notation `ɏ` := yoneda_embedding _
|
||||
|
||||
definition yoneda_lemma_hom_fun [unfold_full] (c : C) (F : Cᵒᵖ ⇒ cset)
|
||||
(x : trunctype.carrier (F c)) (c' : Cᵒᵖ) : to_fun_ob (ɏ c) c' ⟶ F c' :=
|
||||
begin
|
||||
esimp [yoneda_embedding], intro f, exact F f x
|
||||
end
|
||||
|
||||
definition yoneda_lemma_hom_nat (c : C) (F : Cᵒᵖ ⇒ cset)
|
||||
(x : trunctype.carrier (F c)) {c₁ c₂ : Cᵒᵖ} (f : c₁ ⟶ c₂)
|
||||
: F f ∘ yoneda_lemma_hom_fun c F x c₁ = yoneda_lemma_hom_fun c F x c₂ ∘ to_fun_hom (ɏ c) f :=
|
||||
begin
|
||||
esimp [yoneda_embedding], apply eq_of_homotopy, intro f',
|
||||
refine _ ⬝ ap (λy, to_fun_hom F y x) !(@id_left _ C)⁻¹,
|
||||
exact ap10 !(@respect_comp Cᵒᵖ cset)⁻¹ x
|
||||
end
|
||||
|
||||
definition yoneda_lemma_hom [constructor] (c : C) (F : Cᵒᵖ ⇒ cset)
|
||||
(x : trunctype.carrier (F c)) : ɏ c ⟹ F :=
|
||||
begin
|
||||
fapply nat_trans.mk,
|
||||
{ exact yoneda_lemma_hom_fun c F x},
|
||||
{ intro c₁ c₂ f, exact yoneda_lemma_hom_nat c F x f}
|
||||
end
|
||||
|
||||
definition yoneda_lemma_equiv [constructor] (c : C)
|
||||
(F : Cᵒᵖ ⇒ cset) : hom (ɏ c) F ≃ lift (trunctype.carrier (to_fun_ob F c)) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro η, exact up (η c id)},
|
||||
{ intro x, induction x with x, exact yoneda_lemma_hom c F x},
|
||||
{ exact abstract begin intro x, induction x with x, esimp, apply ap up,
|
||||
exact ap10 !respect_id x end end},
|
||||
{ exact abstract begin intro η, esimp, apply nat_trans_eq,
|
||||
intro c', esimp, apply eq_of_homotopy,
|
||||
intro f,
|
||||
transitivity (F f ∘ η c) id, reflexivity,
|
||||
rewrite naturality, esimp [yoneda_embedding], rewrite [id_left], apply ap _ !id_left end end},
|
||||
end
|
||||
|
||||
definition yoneda_lemma (c : C) (F : Cᵒᵖ ⇒ cset) :
|
||||
homset (ɏ c) F ≅ functor_lift (F c) :=
|
||||
begin
|
||||
apply iso_of_equiv, esimp, apply yoneda_lemma_equiv,
|
||||
end
|
||||
|
||||
theorem yoneda_lemma_natural_ob (F : Cᵒᵖ ⇒ cset) {c c' : C} (f : c' ⟶ c)
|
||||
(η : ɏ c ⟹ F) :
|
||||
to_fun_hom (functor_lift ∘f F) f (to_hom (yoneda_lemma c F) η) =
|
||||
to_hom (yoneda_lemma c' F) (η ∘n to_fun_hom ɏ f) :=
|
||||
begin
|
||||
esimp [yoneda_lemma,yoneda_embedding], apply ap up,
|
||||
transitivity (F f ∘ η c) id, reflexivity,
|
||||
rewrite naturality,
|
||||
esimp [yoneda_embedding],
|
||||
apply ap (η c'),
|
||||
esimp [yoneda_embedding, Opposite],
|
||||
rewrite [+id_left,+id_right],
|
||||
end
|
||||
|
||||
-- TODO: Investigate what is the bottleneck to type check the next theorem
|
||||
|
||||
-- attribute yoneda_lemma functor_lift Precategory_Set precategory_Set homset
|
||||
-- yoneda_embedding nat_trans.compose functor_nat_trans_compose [reducible]
|
||||
-- attribute tlift functor.compose [reducible]
|
||||
theorem yoneda_lemma_natural_functor (c : C) (F F' : Cᵒᵖ ⇒ cset)
|
||||
(θ : F ⟹ F') (η : to_fun_ob ɏ c ⟹ F) :
|
||||
(functor_lift.{v u} ∘fn θ) c (to_hom (yoneda_lemma c F) η) =
|
||||
proof to_hom (yoneda_lemma c F') (θ ∘n η) qed :=
|
||||
by reflexivity
|
||||
|
||||
-- theorem xx.{u v} {C : Precategory.{u v}} (c : C) (F F' : Cᵒᵖ ⇒ set)
|
||||
-- (θ : F ⟹ F') (η : to_fun_ob ɏ c ⟹ F) :
|
||||
-- proof _ qed =
|
||||
-- to_hom (yoneda_lemma c F') (θ ∘n η) :=
|
||||
-- by reflexivity
|
||||
|
||||
-- theorem yy.{u v} {C : Precategory.{u v}} (c : C) (F F' : Cᵒᵖ ⇒ set)
|
||||
-- (θ : F ⟹ F') (η : to_fun_ob ɏ c ⟹ F) :
|
||||
-- (functor_lift.{v u} ∘fn θ) c (to_hom (yoneda_lemma c F) η) =
|
||||
-- proof _ qed :=
|
||||
-- by reflexivity
|
||||
|
||||
open equiv
|
||||
definition fully_faithful_yoneda_embedding [instance] (C : Precategory.{u v}) :
|
||||
fully_faithful (ɏ : C ⇒ cset ^c Cᵒᵖ) :=
|
||||
begin
|
||||
intro c c',
|
||||
fapply is_equiv_of_equiv_of_homotopy,
|
||||
{ symmetry, transitivity _, apply @equiv_of_iso (homset _ _),
|
||||
exact @yoneda_lemma C c (ɏ c'), esimp [yoneda_embedding], exact !equiv_lift⁻¹ᵉ},
|
||||
{ intro f, apply nat_trans_eq, intro c, apply eq_of_homotopy, intro f',
|
||||
esimp [equiv.symm,equiv.trans],
|
||||
esimp [yoneda_lemma,yoneda_embedding,Opposite],
|
||||
rewrite [id_left,id_right]}
|
||||
end
|
||||
|
||||
definition is_embedding_yoneda_embedding (C : Category.{u v}) :
|
||||
is_embedding (ɏ : C → Cᵒᵖ ⇒ cset) :=
|
||||
begin
|
||||
intro c c', fapply is_equiv_of_equiv_of_homotopy,
|
||||
{ exact !eq_equiv_iso ⬝e !iso_equiv_F_iso_F ⬝e !eq_equiv_iso⁻¹ᵉ},
|
||||
{ intro p, induction p, esimp [equiv.trans, equiv.symm, to_fun_iso], -- to_fun_iso not unfolded
|
||||
esimp [to_fun_iso],
|
||||
rewrite -eq_of_iso_refl,
|
||||
apply ap eq_of_iso, apply iso_eq, esimp,
|
||||
apply nat_trans_eq, intro c',
|
||||
apply eq_of_homotopy, intro f,
|
||||
rewrite [▸*, category.category.id_left], apply id_right}
|
||||
end
|
||||
|
||||
definition is_representable (F : Cᵒᵖ ⇒ cset) := Σ(c : C), ɏ c ≅ F
|
||||
|
||||
section
|
||||
set_option apply.class_instance false
|
||||
open functor.ops
|
||||
definition is_prop_representable {C : Category.{u v}} (F : Cᵒᵖ ⇒ cset)
|
||||
: is_prop (is_representable F) :=
|
||||
begin
|
||||
fapply is_trunc_equiv_closed,
|
||||
{ unfold [is_representable],
|
||||
rexact fiber.sigma_char ɏ F ⬝e sigma.sigma_equiv_sigma_right
|
||||
(λc, @eq_equiv_iso (cset ^c2 Cᵒᵖ) _ (hom_functor_left c) F)},
|
||||
{ apply function.is_prop_fiber_of_is_embedding, apply is_embedding_yoneda_embedding}
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
|
||||
end yoneda
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jakob von Raumer, Floris van Doorn
|
||||
|
||||
Ported from Coq HoTT
|
||||
-/
|
||||
|
||||
import .iso algebra.bundled
|
||||
|
||||
open eq is_trunc iso category algebra nat unit
|
||||
|
||||
namespace category
|
||||
|
||||
structure groupoid [class] (ob : Type) extends parent : precategory ob :=
|
||||
mk' :: (all_iso : Π ⦃a b : ob⦄ (f : hom a b), @is_iso ob parent a b f)
|
||||
|
||||
abbreviation all_iso := @groupoid.all_iso
|
||||
attribute groupoid.all_iso [instance] [priority 3000]
|
||||
attribute groupoid.to_precategory [unfold 2]
|
||||
definition groupoid.mk [reducible] [constructor] {ob : Type} (C : precategory ob)
|
||||
(H : Π (a b : ob) (f : a ⟶ b), is_iso f) : groupoid ob :=
|
||||
precategory.rec_on C groupoid.mk' H
|
||||
|
||||
definition groupoid_of_group.{l} [constructor] (A : Type.{l}) [G : group A] :
|
||||
groupoid.{0 l} unit :=
|
||||
begin
|
||||
fapply groupoid.mk; fapply precategory.mk: intros,
|
||||
{ exact A},
|
||||
{ exact _},
|
||||
{ exact a_2 * a_1},
|
||||
{ exact 1},
|
||||
{ apply mul.assoc},
|
||||
{ apply mul_one},
|
||||
{ apply one_mul},
|
||||
{ esimp [precategory.mk],
|
||||
fapply is_iso.mk,
|
||||
{ exact f⁻¹},
|
||||
{ apply mul.right_inv},
|
||||
{ apply mul.left_inv}},
|
||||
end
|
||||
|
||||
definition hom_group [constructor] {A : Type} [G : groupoid A] (a : A) : group (hom a a) :=
|
||||
begin
|
||||
fapply group.mk,
|
||||
apply is_set_hom,
|
||||
intro f g, apply (comp f g),
|
||||
intros f g h, apply (assoc f g h)⁻¹,
|
||||
apply (ID a),
|
||||
intro f, apply id_left,
|
||||
intro f, apply id_right,
|
||||
intro f, exact (iso.inverse f),
|
||||
intro f, exact (iso.left_inverse f),
|
||||
end
|
||||
|
||||
definition group_of_is_contr_groupoid {ob : Type} [H : is_contr ob]
|
||||
[G : groupoid ob] : group (hom (center ob) (center ob)) := !hom_group
|
||||
definition group_of_groupoid_unit [G : groupoid unit] : group (hom ⋆ ⋆) := !hom_group
|
||||
|
||||
-- Bundled version of categories
|
||||
-- we don't use Groupoid.carrier explicitly, but rather use Groupoid.carrier (to_Precategory C)
|
||||
structure Groupoid : Type :=
|
||||
(carrier : Type)
|
||||
(struct : groupoid carrier)
|
||||
|
||||
attribute Groupoid.struct [instance] [coercion]
|
||||
|
||||
definition Groupoid.to_Precategory [coercion] [reducible] [unfold 1] (C : Groupoid)
|
||||
: Precategory :=
|
||||
Precategory.mk (Groupoid.carrier C) _
|
||||
|
||||
attribute Groupoid._trans_of_to_Precategory_1 [unfold 1]
|
||||
|
||||
definition groupoid.Mk [reducible] [constructor] := Groupoid.mk
|
||||
definition groupoid.MK [reducible] [constructor] (C : Precategory)
|
||||
(H : Π (a b : C) (f : a ⟶ b), is_iso f) : Groupoid :=
|
||||
Groupoid.mk C (groupoid.mk C H)
|
||||
|
||||
definition Groupoid.eta [unfold 1] (C : Groupoid) : Groupoid.mk C C = C :=
|
||||
Groupoid.rec (λob c, idp) C
|
||||
|
||||
definition Groupoid_of_Group [constructor] (G : Group) : Groupoid :=
|
||||
Groupoid.mk unit (groupoid_of_group G)
|
||||
|
||||
end category
|
||||
|
|
@ -1,469 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn, Jakob von Raumer
|
||||
-/
|
||||
|
||||
import .precategory types.sigma arity
|
||||
|
||||
open eq category prod equiv is_equiv sigma sigma.ops is_trunc
|
||||
|
||||
namespace iso
|
||||
structure split_mono [class] {ob : Type} [C : precategory ob] {a b : ob} (f : a ⟶ b) :=
|
||||
{retraction_of : b ⟶ a}
|
||||
(retraction_comp : retraction_of ∘ f = id)
|
||||
structure split_epi [class] {ob : Type} [C : precategory ob] {a b : ob} (f : a ⟶ b) :=
|
||||
{section_of : b ⟶ a}
|
||||
(comp_section : f ∘ section_of = id)
|
||||
structure is_iso [class] {ob : Type} [C : precategory ob] {a b : ob} (f : a ⟶ b) :=
|
||||
(inverse : b ⟶ a)
|
||||
(left_inverse : inverse ∘ f = id)
|
||||
(right_inverse : f ∘ inverse = id)
|
||||
|
||||
attribute is_iso.inverse [reducible]
|
||||
|
||||
open split_mono split_epi is_iso
|
||||
abbreviation retraction_of [unfold 6] := @split_mono.retraction_of
|
||||
abbreviation retraction_comp [unfold 6] := @split_mono.retraction_comp
|
||||
abbreviation section_of [unfold 6] := @split_epi.section_of
|
||||
abbreviation comp_section [unfold 6] := @split_epi.comp_section
|
||||
abbreviation inverse [unfold 6] := @is_iso.inverse
|
||||
abbreviation left_inverse [unfold 6] := @is_iso.left_inverse
|
||||
abbreviation right_inverse [unfold 6] := @is_iso.right_inverse
|
||||
postfix ⁻¹ := inverse
|
||||
--a second notation for the inverse, which is not overloaded
|
||||
postfix [parsing_only] `⁻¹ʰ`:std.prec.max_plus := inverse -- input using \-1h
|
||||
|
||||
variables {ob : Type} [C : precategory ob]
|
||||
variables {a b c : ob} {g : b ⟶ c} {f : a ⟶ b} {h : b ⟶ a}
|
||||
include C
|
||||
|
||||
definition split_mono_of_is_iso [constructor] [instance] [priority 300]
|
||||
(f : a ⟶ b) [H : is_iso f] : split_mono f :=
|
||||
split_mono.mk !left_inverse
|
||||
|
||||
definition split_epi_of_is_iso [constructor] [instance] [priority 300]
|
||||
(f : a ⟶ b) [H : is_iso f] : split_epi f :=
|
||||
split_epi.mk !right_inverse
|
||||
|
||||
definition is_iso_id [constructor] [instance] [priority 500] (a : ob) : is_iso (ID a) :=
|
||||
is_iso.mk _ !id_id !id_id
|
||||
|
||||
definition is_iso_inverse [constructor] [instance] [priority 200] (f : a ⟶ b) {H : is_iso f}
|
||||
: is_iso f⁻¹ :=
|
||||
is_iso.mk _ !right_inverse !left_inverse
|
||||
|
||||
theorem left_inverse_eq_right_inverse {f : a ⟶ b} {g g' : hom b a}
|
||||
(Hl : g ∘ f = id) (Hr : f ∘ g' = id) : g = g' :=
|
||||
by rewrite [-(id_right g), -Hr, assoc, Hl, id_left]
|
||||
|
||||
theorem retraction_eq [H : split_mono f] (H2 : f ∘ h = id) : retraction_of f = h :=
|
||||
left_inverse_eq_right_inverse !retraction_comp H2
|
||||
|
||||
theorem section_eq [H : split_epi f] (H2 : h ∘ f = id) : section_of f = h :=
|
||||
(left_inverse_eq_right_inverse H2 !comp_section)⁻¹
|
||||
|
||||
theorem inverse_eq_right [H : is_iso f] (H2 : f ∘ h = id) : f⁻¹ = h :=
|
||||
left_inverse_eq_right_inverse !left_inverse H2
|
||||
|
||||
theorem inverse_eq_left [H : is_iso f] (H2 : h ∘ f = id) : f⁻¹ = h :=
|
||||
(left_inverse_eq_right_inverse H2 !right_inverse)⁻¹
|
||||
|
||||
theorem retraction_eq_section (f : a ⟶ b) [Hl : split_mono f] [Hr : split_epi f] :
|
||||
retraction_of f = section_of f :=
|
||||
retraction_eq !comp_section
|
||||
|
||||
definition is_iso_of_split_epi_of_split_mono [constructor] (f : a ⟶ b)
|
||||
[Hl : split_mono f] [Hr : split_epi f] : is_iso f :=
|
||||
is_iso.mk _ ((retraction_eq_section f) ▸ (retraction_comp f)) (comp_section f)
|
||||
|
||||
theorem inverse_unique (H H' : is_iso f) : @inverse _ _ _ _ f H = @inverse _ _ _ _ f H' :=
|
||||
@inverse_eq_left _ _ _ _ _ _ H !left_inverse
|
||||
|
||||
theorem inverse_involutive (f : a ⟶ b) [H : is_iso f] [H : is_iso (f⁻¹)]
|
||||
: (f⁻¹)⁻¹ = f :=
|
||||
inverse_eq_right !left_inverse
|
||||
|
||||
theorem inverse_eq_inverse {f g : a ⟶ b} [H : is_iso f] [H : is_iso g] (p : f = g)
|
||||
: f⁻¹ = g⁻¹ :=
|
||||
by cases p;apply inverse_unique
|
||||
|
||||
theorem retraction_id (a : ob) : retraction_of (ID a) = id :=
|
||||
retraction_eq !id_id
|
||||
|
||||
theorem section_id (a : ob) : section_of (ID a) = id :=
|
||||
section_eq !id_id
|
||||
|
||||
theorem id_inverse (a : ob) [H : is_iso (ID a)] : (ID a)⁻¹ = id :=
|
||||
inverse_eq_left !id_id
|
||||
|
||||
definition split_mono_comp [constructor] [instance] [priority 150] (g : b ⟶ c) (f : a ⟶ b)
|
||||
[Hf : split_mono f] [Hg : split_mono g] : split_mono (g ∘ f) :=
|
||||
split_mono.mk
|
||||
(show (retraction_of f ∘ retraction_of g) ∘ g ∘ f = id,
|
||||
by rewrite [-assoc, assoc _ g f, retraction_comp, id_left, retraction_comp])
|
||||
|
||||
definition split_epi_comp [constructor] [instance] [priority 150] (g : b ⟶ c) (f : a ⟶ b)
|
||||
[Hf : split_epi f] [Hg : split_epi g] : split_epi (g ∘ f) :=
|
||||
split_epi.mk
|
||||
(show (g ∘ f) ∘ section_of f ∘ section_of g = id,
|
||||
by rewrite [-assoc, {f ∘ _}assoc, comp_section, id_left, comp_section])
|
||||
|
||||
definition is_iso_comp [constructor] [instance] [priority 150] (g : b ⟶ c) (f : a ⟶ b)
|
||||
[Hf : is_iso f] [Hg : is_iso g] : is_iso (g ∘ f) :=
|
||||
!is_iso_of_split_epi_of_split_mono
|
||||
|
||||
theorem is_prop_is_iso [instance] (f : hom a b) : is_prop (is_iso f) :=
|
||||
begin
|
||||
apply is_prop.mk, intro H H',
|
||||
cases H with g li ri, cases H' with g' li' ri',
|
||||
fapply (apd0111 (@is_iso.mk ob C a b f)),
|
||||
apply left_inverse_eq_right_inverse,
|
||||
apply li,
|
||||
apply ri',
|
||||
apply is_prop.elimo,
|
||||
apply is_prop.elimo,
|
||||
end
|
||||
end iso open iso
|
||||
|
||||
/- isomorphic objects -/
|
||||
structure iso {ob : Type} [C : precategory ob] (a b : ob) :=
|
||||
(to_hom : hom a b)
|
||||
(struct : is_iso to_hom)
|
||||
|
||||
infix ` ≅ `:50 := iso
|
||||
notation c ` ≅[`:50 C:0 `] `:0 c':50 := @iso C _ c c'
|
||||
attribute iso.struct [instance] [priority 2000]
|
||||
|
||||
namespace iso
|
||||
variables {ob : Type} [C : precategory ob]
|
||||
variables {a b c : ob} {g : b ⟶ c} {f : a ⟶ b} {h : b ⟶ a}
|
||||
include C
|
||||
|
||||
attribute to_hom [coercion]
|
||||
|
||||
protected definition MK [constructor] (f : a ⟶ b) (g : b ⟶ a)
|
||||
(H1 : g ∘ f = id) (H2 : f ∘ g = id) :=
|
||||
@(mk f) (is_iso.mk _ H1 H2)
|
||||
|
||||
variable {C}
|
||||
definition to_inv [reducible] [unfold 5] (f : a ≅ b) : b ⟶ a := (to_hom f)⁻¹
|
||||
definition to_left_inverse [unfold 5] (f : a ≅ b) : (to_hom f)⁻¹ ∘ (to_hom f) = id :=
|
||||
left_inverse (to_hom f)
|
||||
definition to_right_inverse [unfold 5] (f : a ≅ b) : (to_hom f) ∘ (to_hom f)⁻¹ = id :=
|
||||
right_inverse (to_hom f)
|
||||
|
||||
variable [C]
|
||||
protected definition refl [constructor] (a : ob) : a ≅ a :=
|
||||
mk (ID a) _
|
||||
|
||||
protected definition symm [constructor] ⦃a b : ob⦄ (H : a ≅ b) : b ≅ a :=
|
||||
mk (to_hom H)⁻¹ _
|
||||
|
||||
protected definition trans [constructor] ⦃a b c : ob⦄ (H1 : a ≅ b) (H2 : b ≅ c) : a ≅ c :=
|
||||
mk (to_hom H2 ∘ to_hom H1) _
|
||||
|
||||
infixl ` ⬝i `:75 := iso.trans
|
||||
postfix `⁻¹ⁱ`:(max + 1) := iso.symm
|
||||
|
||||
definition change_hom [constructor] (H : a ≅ b) (f : a ⟶ b) (p : to_hom H = f) : a ≅ b :=
|
||||
iso.MK f (to_inv H) (p ▸ to_left_inverse H) (p ▸ to_right_inverse H)
|
||||
|
||||
definition change_inv [constructor] (H : a ≅ b) (g : b ⟶ a) (p : to_inv H = g) : a ≅ b :=
|
||||
iso.MK (to_hom H) g (p ▸ to_left_inverse H) (p ▸ to_right_inverse H)
|
||||
|
||||
definition iso_mk_eq {f f' : a ⟶ b} [H : is_iso f] [H' : is_iso f'] (p : f = f')
|
||||
: iso.mk f _ = iso.mk f' _ :=
|
||||
apd011 iso.mk p !is_prop.elimo
|
||||
|
||||
variable {C}
|
||||
definition iso_eq {f f' : a ≅ b} (p : to_hom f = to_hom f') : f = f' :=
|
||||
by (cases f; cases f'; apply (iso_mk_eq p))
|
||||
|
||||
definition iso_pathover {X : Type} {x₁ x₂ : X} {p : x₁ = x₂} {a : X → ob} {b : X → ob}
|
||||
{f₁ : a x₁ ≅ b x₁} {f₂ : a x₂ ≅ b x₂} (q : to_hom f₁ =[p] to_hom f₂) : f₁ =[p] f₂ :=
|
||||
begin
|
||||
cases f₁, cases f₂, esimp at q, induction q, apply pathover_idp_of_eq,
|
||||
exact ap (iso.mk _) !is_prop.elim
|
||||
end
|
||||
variable [C]
|
||||
|
||||
-- The structure for isomorphism can be characterized up to equivalence by a sigma type.
|
||||
protected definition sigma_char ⦃a b : ob⦄ : (Σ (f : hom a b), is_iso f) ≃ (a ≅ b) :=
|
||||
begin
|
||||
fapply (equiv.mk),
|
||||
{intro S, apply iso.mk, apply (S.2)},
|
||||
{fapply adjointify,
|
||||
{intro p, cases p with f H, exact sigma.mk f H},
|
||||
{intro p, cases p, apply idp},
|
||||
{intro S, cases S, apply idp}},
|
||||
end
|
||||
|
||||
-- The type of isomorphisms between two objects is a set
|
||||
definition is_set_iso [instance] : is_set (a ≅ b) :=
|
||||
begin
|
||||
apply is_trunc_is_equiv_closed,
|
||||
apply equiv.to_is_equiv (!iso.sigma_char),
|
||||
end
|
||||
|
||||
definition iso_of_eq [unfold 5] (p : a = b) : a ≅ b :=
|
||||
eq.rec_on p (iso.refl a)
|
||||
|
||||
definition hom_of_eq [reducible] [unfold 5] (p : a = b) : a ⟶ b :=
|
||||
iso.to_hom (iso_of_eq p)
|
||||
|
||||
definition inv_of_eq [reducible] [unfold 5] (p : a = b) : b ⟶ a :=
|
||||
iso.to_inv (iso_of_eq p)
|
||||
|
||||
definition iso_of_eq_inv (p : a = b) : iso_of_eq p⁻¹ = iso.symm (iso_of_eq p) :=
|
||||
eq.rec_on p idp
|
||||
|
||||
theorem hom_of_eq_inv (p : a = b) : hom_of_eq p⁻¹ = inv_of_eq p :=
|
||||
eq.rec_on p idp
|
||||
|
||||
theorem inv_of_eq_inv (p : a = b) : inv_of_eq p⁻¹ = hom_of_eq p :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition iso_of_eq_con (p : a = b) (q : b = c)
|
||||
: iso_of_eq (p ⬝ q) = iso.trans (iso_of_eq p) (iso_of_eq q) :=
|
||||
eq.rec_on q (eq.rec_on p (iso_eq !id_id⁻¹))
|
||||
|
||||
definition transport_iso_of_eq (p : a = b) :
|
||||
p ▸ !iso.refl = iso_of_eq p :=
|
||||
by cases p; reflexivity
|
||||
|
||||
definition hom_pathover {X : Type} {x₁ x₂ : X} {p : x₁ = x₂} {a b : X → ob}
|
||||
{f₁ : a x₁ ⟶ b x₁} {f₂ : a x₂ ⟶ b x₂} (q : hom_of_eq (ap b p) ∘ f₁ = f₂ ∘ hom_of_eq (ap a p)) :
|
||||
f₁ =[p] f₂ :=
|
||||
begin
|
||||
induction p, apply pathover_idp_of_eq, exact !id_left⁻¹ ⬝ q ⬝ !id_right
|
||||
end
|
||||
|
||||
definition hom_pathover_constant_left {X : Type} {x₁ x₂ : X} {p : x₁ = x₂} {a : ob} {b : X → ob}
|
||||
{f₁ : a ⟶ b x₁} {f₂ : a ⟶ b x₂} (q : hom_of_eq (ap b p) ∘ f₁ = f₂) : f₁ =[p] f₂ :=
|
||||
hom_pathover (q ⬝ !id_right⁻¹ ⬝ ap (λx, _ ∘ hom_of_eq x) !ap_constant⁻¹)
|
||||
|
||||
definition hom_pathover_constant_right {X : Type} {x₁ x₂ : X} {p : x₁ = x₂} {a : X → ob} {b : ob}
|
||||
{f₁ : a x₁ ⟶ b} {f₂ : a x₂ ⟶ b} (q : f₁ = f₂ ∘ hom_of_eq (ap a p)) : f₁ =[p] f₂ :=
|
||||
hom_pathover (ap (λx, hom_of_eq x ∘ _) !ap_constant ⬝ !id_left ⬝ q)
|
||||
|
||||
definition hom_pathover_id_left {p : a = b} {c : ob → ob} {f₁ : a ⟶ c a} {f₂ : b ⟶ c b}
|
||||
(q : hom_of_eq (ap c p) ∘ f₁ = f₂ ∘ hom_of_eq p) : f₁ =[p] f₂ :=
|
||||
hom_pathover (q ⬝ ap (λx, _ ∘ hom_of_eq x) !ap_id⁻¹)
|
||||
|
||||
definition hom_pathover_id_right {p : a = b} {c : ob → ob} {f₁ : c a ⟶ a} {f₂ : c b ⟶ b}
|
||||
(q : hom_of_eq p ∘ f₁ = f₂ ∘ hom_of_eq (ap c p)) : f₁ =[p] f₂ :=
|
||||
hom_pathover (ap (λx, hom_of_eq x ∘ _) !ap_id ⬝ q)
|
||||
|
||||
definition hom_pathover_id_left_id_right {p : a = b} {f₁ : a ⟶ a} {f₂ : b ⟶ b}
|
||||
(q : hom_of_eq p ∘ f₁ = f₂ ∘ hom_of_eq p) : f₁ =[p] f₂ :=
|
||||
hom_pathover_id_left (ap (λx, hom_of_eq x ∘ _) !ap_id ⬝ q)
|
||||
|
||||
definition hom_pathover_id_left_constant_right {p : a = b} {f₁ : a ⟶ c} {f₂ : b ⟶ c}
|
||||
(q : f₁ = f₂ ∘ hom_of_eq p) : f₁ =[p] f₂ :=
|
||||
hom_pathover_constant_right (q ⬝ ap (λx, _ ∘ hom_of_eq x) !ap_id⁻¹)
|
||||
|
||||
definition hom_pathover_constant_left_id_right {p : a = b} {f₁ : c ⟶ a} {f₂ : c ⟶ b}
|
||||
(q : hom_of_eq p ∘ f₁ = f₂) : f₁ =[p] f₂ :=
|
||||
hom_pathover_constant_left (ap (λx, hom_of_eq x ∘ _) !ap_id ⬝ q)
|
||||
|
||||
section
|
||||
open funext
|
||||
variables {X : Type} {x y : X} {F G : X → ob}
|
||||
definition transport_hom_of_eq (p : F = G) (f : hom (F x) (F y))
|
||||
: p ▸ f = hom_of_eq (apd10 p y) ∘ f ∘ inv_of_eq (apd10 p x) :=
|
||||
by induction p; exact !id_leftright⁻¹
|
||||
|
||||
definition transport_hom_of_eq_right (p : x = y) (f : hom c (F x))
|
||||
: p ▸ f = hom_of_eq (ap F p) ∘ f :=
|
||||
by induction p; exact !id_left⁻¹
|
||||
|
||||
definition transport_hom_of_eq_left (p : x = y) (f : hom (F x) c)
|
||||
: p ▸ f = f ∘ inv_of_eq (ap F p) :=
|
||||
by induction p; exact !id_right⁻¹
|
||||
|
||||
definition transport_hom (p : F ~ G) (f : hom (F x) (F y))
|
||||
: eq_of_homotopy p ▸ f = hom_of_eq (p y) ∘ f ∘ inv_of_eq (p x) :=
|
||||
calc
|
||||
eq_of_homotopy p ▸ f =
|
||||
hom_of_eq (apd10 (eq_of_homotopy p) y) ∘ f ∘ inv_of_eq (apd10 (eq_of_homotopy p) x)
|
||||
: transport_hom_of_eq
|
||||
... = hom_of_eq (p y) ∘ f ∘ inv_of_eq (p x) : {right_inv apd10 p}
|
||||
|
||||
end
|
||||
|
||||
structure mono [class] (f : a ⟶ b) :=
|
||||
(elim : ∀c (g h : hom c a), f ∘ g = f ∘ h → g = h)
|
||||
structure epi [class] (f : a ⟶ b) :=
|
||||
(elim : ∀c (g h : hom b c), g ∘ f = h ∘ f → g = h)
|
||||
|
||||
definition mono_of_split_mono [instance] (f : a ⟶ b) [H : split_mono f] : mono f :=
|
||||
mono.mk
|
||||
(λ c g h H,
|
||||
calc
|
||||
g = id ∘ g : by rewrite id_left
|
||||
... = (retraction_of f ∘ f) ∘ g : by rewrite retraction_comp
|
||||
... = (retraction_of f ∘ f) ∘ h : by rewrite [-assoc, H, -assoc]
|
||||
... = id ∘ h : by rewrite retraction_comp
|
||||
... = h : by rewrite id_left)
|
||||
|
||||
definition epi_of_split_epi [instance] (f : a ⟶ b) [H : split_epi f] : epi f :=
|
||||
epi.mk
|
||||
(λ c g h H,
|
||||
calc
|
||||
g = g ∘ id : by rewrite id_right
|
||||
... = g ∘ f ∘ section_of f : by rewrite -(comp_section f)
|
||||
... = h ∘ f ∘ section_of f : by rewrite [assoc, H, -assoc]
|
||||
... = h ∘ id : by rewrite comp_section
|
||||
... = h : by rewrite id_right)
|
||||
|
||||
definition mono_comp [instance] (g : b ⟶ c) (f : a ⟶ b) [Hf : mono f] [Hg : mono g]
|
||||
: mono (g ∘ f) :=
|
||||
mono.mk
|
||||
(λ d h₁ h₂ H,
|
||||
have H2 : g ∘ (f ∘ h₁) = g ∘ (f ∘ h₂),
|
||||
begin
|
||||
rewrite *assoc, exact H
|
||||
end,
|
||||
!mono.elim (!mono.elim H2))
|
||||
|
||||
definition epi_comp [instance] (g : b ⟶ c) (f : a ⟶ b) [Hf : epi f] [Hg : epi g]
|
||||
: epi (g ∘ f) :=
|
||||
epi.mk
|
||||
(λ d h₁ h₂ H,
|
||||
have H2 : (h₁ ∘ g) ∘ f = (h₂ ∘ g) ∘ f,
|
||||
begin
|
||||
rewrite -*assoc, exact H
|
||||
end,
|
||||
!epi.elim (!epi.elim H2))
|
||||
|
||||
end iso
|
||||
|
||||
attribute iso.refl [refl]
|
||||
attribute iso.symm [symm]
|
||||
attribute iso.trans [trans]
|
||||
|
||||
namespace iso
|
||||
/-
|
||||
rewrite lemmas for inverses, modified from
|
||||
https://github.com/JasonGross/HoTT-categories/blob/master/theories/Categories/Category/Morphisms.v
|
||||
-/
|
||||
section
|
||||
variables {ob : Type} [C : precategory ob] include C
|
||||
variables {a b c d : ob} (f : b ⟶ a)
|
||||
(r : c ⟶ d) (q : b ⟶ c) (p : a ⟶ b)
|
||||
(g : d ⟶ c)
|
||||
variable [Hq : is_iso q] include Hq
|
||||
theorem comp.right_inverse : q ∘ q⁻¹ = id := !right_inverse
|
||||
theorem comp.left_inverse : q⁻¹ ∘ q = id := !left_inverse
|
||||
|
||||
theorem inverse_comp_cancel_left : q⁻¹ ∘ (q ∘ p) = p :=
|
||||
by rewrite [assoc, left_inverse, id_left]
|
||||
theorem comp_inverse_cancel_left : q ∘ (q⁻¹ ∘ g) = g :=
|
||||
by rewrite [assoc, right_inverse, id_left]
|
||||
theorem comp_inverse_cancel_right : (r ∘ q) ∘ q⁻¹ = r :=
|
||||
by rewrite [-assoc, right_inverse, id_right]
|
||||
theorem inverse_comp_cancel_right : (f ∘ q⁻¹) ∘ q = f :=
|
||||
by rewrite [-assoc, left_inverse, id_right]
|
||||
|
||||
theorem comp_inverse [Hp : is_iso p] [Hpq : is_iso (q ∘ p)] : (q ∘ p)⁻¹ʰ = p⁻¹ʰ ∘ q⁻¹ʰ :=
|
||||
inverse_eq_left
|
||||
(show (p⁻¹ʰ ∘ q⁻¹ʰ) ∘ q ∘ p = id, from
|
||||
by rewrite [-assoc, inverse_comp_cancel_left, left_inverse])
|
||||
|
||||
theorem inverse_comp_inverse_left [H' : is_iso g] : (q⁻¹ ∘ g)⁻¹ = g⁻¹ ∘ q :=
|
||||
inverse_involutive q ▸ comp_inverse q⁻¹ g
|
||||
|
||||
theorem inverse_comp_inverse_right [H' : is_iso f] : (q ∘ f⁻¹)⁻¹ = f ∘ q⁻¹ :=
|
||||
inverse_involutive f ▸ comp_inverse q f⁻¹
|
||||
|
||||
theorem inverse_comp_inverse_inverse [H' : is_iso r] : (q⁻¹ ∘ r⁻¹)⁻¹ = r ∘ q :=
|
||||
inverse_involutive r ▸ inverse_comp_inverse_left q r⁻¹
|
||||
end
|
||||
|
||||
section
|
||||
variables {ob : Type} {C : precategory ob} include C
|
||||
variables {d c b a : ob}
|
||||
{r' : c ⟶ d} {i : b ⟶ c} {f : b ⟶ a}
|
||||
{r : c ⟶ d} {q : b ⟶ c} {p : a ⟶ b}
|
||||
{g : d ⟶ c} {h : c ⟶ b} {p' : a ⟶ b}
|
||||
{x : b ⟶ d} {z : a ⟶ c}
|
||||
{y : d ⟶ b} {w : c ⟶ a}
|
||||
variable [Hq : is_iso q] include Hq
|
||||
|
||||
theorem comp_eq_of_eq_inverse_comp (H : y = q⁻¹ ∘ g) : q ∘ y = g :=
|
||||
H⁻¹ ▸ comp_inverse_cancel_left q g
|
||||
theorem comp_eq_of_eq_comp_inverse (H : w = f ∘ q⁻¹) : w ∘ q = f :=
|
||||
H⁻¹ ▸ inverse_comp_cancel_right f q
|
||||
theorem eq_comp_of_inverse_comp_eq (H : q⁻¹ ∘ g = y) : g = q ∘ y :=
|
||||
(comp_eq_of_eq_inverse_comp H⁻¹)⁻¹
|
||||
theorem eq_comp_of_comp_inverse_eq (H : f ∘ q⁻¹ = w) : f = w ∘ q :=
|
||||
(comp_eq_of_eq_comp_inverse H⁻¹)⁻¹
|
||||
variable {Hq}
|
||||
theorem inverse_comp_eq_of_eq_comp (H : z = q ∘ p) : q⁻¹ ∘ z = p :=
|
||||
H⁻¹ ▸ inverse_comp_cancel_left q p
|
||||
theorem comp_inverse_eq_of_eq_comp (H : x = r ∘ q) : x ∘ q⁻¹ = r :=
|
||||
H⁻¹ ▸ comp_inverse_cancel_right r q
|
||||
theorem eq_inverse_comp_of_comp_eq (H : q ∘ p = z) : p = q⁻¹ ∘ z :=
|
||||
(inverse_comp_eq_of_eq_comp H⁻¹)⁻¹
|
||||
theorem eq_comp_inverse_of_comp_eq (H : r ∘ q = x) : r = x ∘ q⁻¹ :=
|
||||
(comp_inverse_eq_of_eq_comp H⁻¹)⁻¹
|
||||
|
||||
theorem eq_inverse_of_comp_eq_id' (H : h ∘ q = id) : h = q⁻¹ := (inverse_eq_left H)⁻¹
|
||||
theorem eq_inverse_of_comp_eq_id (H : q ∘ h = id) : h = q⁻¹ := (inverse_eq_right H)⁻¹
|
||||
theorem inverse_eq_of_id_eq_comp (H : id = h ∘ q) : q⁻¹ = h :=
|
||||
(eq_inverse_of_comp_eq_id' H⁻¹)⁻¹
|
||||
theorem inverse_eq_of_id_eq_comp' (H : id = q ∘ h) : q⁻¹ = h :=
|
||||
(eq_inverse_of_comp_eq_id H⁻¹)⁻¹
|
||||
variable [Hq]
|
||||
theorem eq_of_comp_inverse_eq_id (H : i ∘ q⁻¹ = id) : i = q :=
|
||||
eq_inverse_of_comp_eq_id' H ⬝ inverse_involutive q
|
||||
theorem eq_of_inverse_comp_eq_id (H : q⁻¹ ∘ i = id) : i = q :=
|
||||
eq_inverse_of_comp_eq_id H ⬝ inverse_involutive q
|
||||
theorem eq_of_id_eq_comp_inverse (H : id = i ∘ q⁻¹) : q = i := (eq_of_comp_inverse_eq_id H⁻¹)⁻¹
|
||||
theorem eq_of_id_eq_inverse_comp (H : id = q⁻¹ ∘ i) : q = i := (eq_of_inverse_comp_eq_id H⁻¹)⁻¹
|
||||
|
||||
theorem inverse_comp_id_comp : q⁻¹ ∘ id ∘ q = id :=
|
||||
ap (λ x, _ ∘ x) !id_left ⬝ !comp.left_inverse
|
||||
theorem comp_id_comp_inverse : q ∘ id ∘ q⁻¹ = id :=
|
||||
ap (λ x, _ ∘ x) !id_left ⬝ !comp.right_inverse
|
||||
|
||||
variables (q)
|
||||
theorem comp.cancel_left (H : q ∘ p = q ∘ p') : p = p' :=
|
||||
by rewrite [-inverse_comp_cancel_left q p, H, inverse_comp_cancel_left q]
|
||||
theorem comp.cancel_right (H : r ∘ q = r' ∘ q) : r = r' :=
|
||||
by rewrite [-comp_inverse_cancel_right r q, H, comp_inverse_cancel_right _ q]
|
||||
end
|
||||
end iso
|
||||
|
||||
namespace iso
|
||||
|
||||
/- precomposition and postcomposition by an iso is an equivalence -/
|
||||
|
||||
definition is_equiv_postcompose [constructor] {ob : Type} [precategory ob] {a b c : ob}
|
||||
(g : b ⟶ c) [is_iso g] : is_equiv (λ(f : a ⟶ b), g ∘ f) :=
|
||||
begin
|
||||
fapply adjointify,
|
||||
{ exact λf', g⁻¹ ∘ f'},
|
||||
{ intro f', apply comp_inverse_cancel_left},
|
||||
{ intro f, apply inverse_comp_cancel_left}
|
||||
end
|
||||
|
||||
definition equiv_postcompose [constructor] {ob : Type} [precategory ob] {a b c : ob}
|
||||
(g : b ⟶ c) [is_iso g] : (a ⟶ b) ≃ (a ⟶ c) :=
|
||||
equiv.mk (λ(f : a ⟶ b), g ∘ f) (is_equiv_postcompose g)
|
||||
|
||||
definition is_equiv_precompose [constructor] {ob : Type} [precategory ob] {a b c : ob}
|
||||
(f : a ⟶ b) [is_iso f] : is_equiv (λ(g : b ⟶ c), g ∘ f) :=
|
||||
begin
|
||||
fapply adjointify,
|
||||
{ exact λg', g' ∘ f⁻¹},
|
||||
{ intro g', apply comp_inverse_cancel_right},
|
||||
{ intro g, apply inverse_comp_cancel_right}
|
||||
end
|
||||
|
||||
definition equiv_precompose [constructor] {ob : Type} [precategory ob] {a b c : ob}
|
||||
(f : a ⟶ b) [is_iso f] : (b ⟶ c) ≃ (a ⟶ c) :=
|
||||
equiv.mk (λ(g : b ⟶ c), g ∘ f) (is_equiv_precompose f)
|
||||
|
||||
end iso
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
colimit_functor ⊣ Δ ⊣ limit_functor
|
||||
-/
|
||||
|
||||
import .colimits ..functor.adjoint
|
||||
|
||||
open eq functor category is_trunc prod nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
definition limit_functor_adjoint [constructor] (D I : Precategory) [H : has_limits_of_shape D I] :
|
||||
constant_diagram D I ⊣ limit_functor D I :=
|
||||
adjoint.mk'
|
||||
begin
|
||||
fapply natural_iso.MK,
|
||||
{ intro dF η, induction dF with d F, esimp at *,
|
||||
fapply hom_limit,
|
||||
{ exact natural_map η},
|
||||
{ intro i j f, exact !naturality ⬝ !id_right}},
|
||||
{ esimp, intro dF dF' fθ, induction dF with d F, induction dF' with d' F',
|
||||
induction fθ with f θ, esimp at *, apply eq_of_homotopy, intro η,
|
||||
apply eq_hom_limit, intro i,
|
||||
rewrite [assoc, limit_hom_limit_commute,
|
||||
-assoc, assoc (limit_morphism F i), hom_limit_commute]},
|
||||
{ esimp, intro dF f, induction dF with d F, esimp at *,
|
||||
refine !limit_nat_trans ∘n constant_nat_trans I f},
|
||||
{ esimp, intro dF, induction dF with d F, esimp, apply eq_of_homotopy, intro η,
|
||||
apply nat_trans_eq, intro i, esimp, apply hom_limit_commute},
|
||||
{ esimp, intro dF, induction dF with d F, esimp, apply eq_of_homotopy, intro f,
|
||||
symmetry, apply eq_hom_limit, intro i, reflexivity}
|
||||
end
|
||||
|
||||
/-
|
||||
definition adjoint_colimit_functor [constructor] (D I : Precategory)
|
||||
[H : has_colimits_of_shape D I] : colimit_functor D I ⊣ constant_diagram D I :=
|
||||
have H : colimit_functor D I ⊣ (constant_diagram Dᵒᵖ Iᵒᵖ)ᵒᵖ', from _,
|
||||
_
|
||||
-/
|
||||
|
||||
end category
|
||||
|
|
@ -1,332 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Colimits in a category
|
||||
-/
|
||||
|
||||
import .limits ..constructions.opposite
|
||||
|
||||
open is_trunc functor nat_trans eq
|
||||
|
||||
-- we define colimits to be the dual of a limit
|
||||
|
||||
namespace category
|
||||
|
||||
variables {ob : Type} [C : precategory ob] {c c' : ob} (D I : Precategory)
|
||||
include C
|
||||
|
||||
definition is_initial [reducible] (c : ob) := @is_terminal _ (opposite C) c
|
||||
|
||||
definition is_contr_of_is_initial (c d : ob) [H : is_initial d]
|
||||
: is_contr (d ⟶ c) :=
|
||||
H c
|
||||
|
||||
local attribute is_contr_of_is_initial [instance]
|
||||
|
||||
definition initial_morphism (c c' : ob) [H : is_initial c'] : c' ⟶ c :=
|
||||
!center
|
||||
|
||||
definition hom_initial_eq [H : is_initial c'] (f f' : c' ⟶ c) : f = f' :=
|
||||
!is_prop.elim
|
||||
|
||||
definition eq_initial_morphism [H : is_initial c'] (f : c' ⟶ c) : f = initial_morphism c c' :=
|
||||
!is_prop.elim
|
||||
|
||||
definition initial_iso_initial {c c' : ob} (H : is_initial c) (K : is_initial c') : c ≅ c' :=
|
||||
iso_of_opposite_iso (@terminal_iso_terminal _ (opposite C) _ _ H K)
|
||||
|
||||
theorem is_prop_is_initial [instance] : is_prop (is_initial c) := _
|
||||
|
||||
omit C
|
||||
|
||||
definition has_initial_object [reducible] : Type := has_terminal_object Dᵒᵖ
|
||||
|
||||
definition initial_object [unfold 2] [reducible] [H : has_initial_object D] : D :=
|
||||
has_terminal_object.d Dᵒᵖ
|
||||
|
||||
definition has_initial_object.is_initial [H : has_initial_object D]
|
||||
: is_initial (initial_object D) :=
|
||||
@has_terminal_object.is_terminal (Opposite D) H
|
||||
|
||||
variable {D}
|
||||
definition initial_object_iso_initial_object (H₁ H₂ : has_initial_object D)
|
||||
: @initial_object D H₁ ≅ @initial_object D H₂ :=
|
||||
initial_iso_initial (@has_initial_object.is_initial D H₁) (@has_initial_object.is_initial D H₂)
|
||||
|
||||
set_option pp.coercions true
|
||||
theorem is_prop_has_initial_object [instance] (D : Category)
|
||||
: is_prop (has_initial_object D) :=
|
||||
is_prop_has_terminal_object (Category_opposite D)
|
||||
|
||||
variable (D)
|
||||
abbreviation has_colimits_of_shape := has_limits_of_shape Dᵒᵖ Iᵒᵖ
|
||||
|
||||
/-
|
||||
The next definitions states that a category is cocomplete with respect to diagrams
|
||||
in a certain universe. "is_cocomplete.{o₁ h₁ o₂ h₂}" means that D is cocomplete
|
||||
with respect to diagrams of type Precategory.{o₂ h₂}
|
||||
-/
|
||||
|
||||
abbreviation is_cocomplete (D : Precategory) := is_complete Dᵒᵖ
|
||||
|
||||
definition has_colimits_of_shape_of_is_cocomplete [instance] [H : is_cocomplete D]
|
||||
(I : Precategory) : has_colimits_of_shape D I := H Iᵒᵖ
|
||||
|
||||
section
|
||||
open pi
|
||||
theorem is_prop_has_colimits_of_shape [instance] (D : Category) (I : Precategory)
|
||||
: is_prop (has_colimits_of_shape D I) :=
|
||||
is_prop_has_limits_of_shape (Category_opposite D) _
|
||||
|
||||
theorem is_prop_is_cocomplete [instance] (D : Category) : is_prop (is_cocomplete D) :=
|
||||
is_prop_is_complete (Category_opposite D)
|
||||
end
|
||||
|
||||
variables {D I} (F : I ⇒ D) [H : has_colimits_of_shape D I] {i j : I}
|
||||
include H
|
||||
|
||||
abbreviation cocone := (cone Fᵒᵖᶠ)ᵒᵖ
|
||||
|
||||
definition has_initial_object_cocone [H : has_colimits_of_shape D I]
|
||||
(F : I ⇒ D) : has_initial_object (cocone F) :=
|
||||
begin
|
||||
unfold [has_colimits_of_shape,has_limits_of_shape] at H,
|
||||
exact H Fᵒᵖᶠ
|
||||
end
|
||||
local attribute has_initial_object_cocone [instance]
|
||||
|
||||
definition colimit_cocone : cocone F := limit_cone Fᵒᵖᶠ
|
||||
|
||||
definition is_initial_colimit_cocone [instance] : is_initial (colimit_cocone F) :=
|
||||
is_terminal_limit_cone Fᵒᵖᶠ
|
||||
|
||||
definition colimit_object : D :=
|
||||
limit_object Fᵒᵖᶠ
|
||||
|
||||
definition colimit_nat_trans : constant_functor Iᵒᵖ (colimit_object F) ⟹ Fᵒᵖᶠ :=
|
||||
limit_nat_trans Fᵒᵖᶠ
|
||||
|
||||
definition colimit_morphism (i : I) : F i ⟶ colimit_object F :=
|
||||
limit_morphism Fᵒᵖᶠ i
|
||||
|
||||
variable {H}
|
||||
theorem colimit_commute {i j : I} (f : i ⟶ j)
|
||||
: colimit_morphism F j ∘ to_fun_hom F f = colimit_morphism F i :=
|
||||
by rexact limit_commute Fᵒᵖᶠ f
|
||||
|
||||
variable [H]
|
||||
definition colimit_cone_obj [constructor] {d : D} {η : Πi, F i ⟶ d}
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i) : cone_obj Fᵒᵖᶠ :=
|
||||
limit_cone_obj Fᵒᵖᶠ proof p qed
|
||||
|
||||
variable {H}
|
||||
definition colimit_hom {d : D} (η : Πi, F i ⟶ d)
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i) : colimit_object F ⟶ d :=
|
||||
hom_limit Fᵒᵖᶠ η proof p qed
|
||||
|
||||
theorem colimit_hom_commute {d : D} (η : Πi, F i ⟶ d)
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i) (i : I)
|
||||
: colimit_hom F η p ∘ colimit_morphism F i = η i :=
|
||||
by rexact hom_limit_commute Fᵒᵖᶠ η proof p qed i
|
||||
|
||||
definition colimit_cone_hom [constructor] {d : D} {η : Πi, F i ⟶ d}
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i) {h : colimit_object F ⟶ d}
|
||||
(q : Πi, h ∘ colimit_morphism F i = η i)
|
||||
: cone_hom (colimit_cone_obj F p) (colimit_cocone F) :=
|
||||
by rexact limit_cone_hom Fᵒᵖᶠ proof p qed proof q qed
|
||||
|
||||
variable {F}
|
||||
theorem eq_colimit_hom {d : D} {η : Πi, F i ⟶ d}
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i) {h : colimit_object F ⟶ d}
|
||||
(q : Πi, h ∘ colimit_morphism F i = η i) : h = colimit_hom F η p :=
|
||||
by rexact @eq_hom_limit _ _ Fᵒᵖᶠ _ _ _ proof p qed _ proof q qed
|
||||
|
||||
theorem colimit_cocone_unique {d : D} {η : Πi, F i ⟶ d}
|
||||
(p : Π⦃j i : I⦄ (f : i ⟶ j), η j ∘ to_fun_hom F f = η i)
|
||||
{h₁ : colimit_object F ⟶ d} (q₁ : Πi, h₁ ∘ colimit_morphism F i = η i)
|
||||
{h₂ : colimit_object F ⟶ d} (q₂ : Πi, h₂ ∘ colimit_morphism F i = η i) : h₁ = h₂ :=
|
||||
@limit_cone_unique _ _ Fᵒᵖᶠ _ _ _ proof p qed _ proof q₁ qed _ proof q₂ qed
|
||||
|
||||
definition colimit_hom_colimit [reducible] {F G : I ⇒ D} (η : F ⟹ G)
|
||||
: colimit_object F ⟶ colimit_object G :=
|
||||
colimit_hom _ (λi, colimit_morphism G i ∘ η i)
|
||||
abstract by intro i j f; rewrite [-assoc,-naturality,assoc,colimit_commute] end
|
||||
|
||||
omit H
|
||||
|
||||
variable (F)
|
||||
definition colimit_object_iso_colimit_object [constructor] (H₁ H₂ : has_colimits_of_shape D I) :
|
||||
@(colimit_object F) H₁ ≅ @(colimit_object F) H₂ :=
|
||||
iso_of_opposite_iso (limit_object_iso_limit_object Fᵒᵖᶠ H₁ H₂)
|
||||
|
||||
definition colimit_functor [constructor] (D I : Precategory) [H : has_colimits_of_shape D I]
|
||||
: D ^c I ⇒ D :=
|
||||
(limit_functor Dᵒᵖ Iᵒᵖ ∘f opposite_functor_opposite_left D I)ᵒᵖ'
|
||||
|
||||
section bin_coproducts
|
||||
open bool prod.ops
|
||||
definition has_binary_coproducts [reducible] (D : Precategory) := has_colimits_of_shape D c2
|
||||
variables [K : has_binary_coproducts D] (d d' : D)
|
||||
include K
|
||||
|
||||
definition coproduct_object : D :=
|
||||
colimit_object (c2_functor D d d')
|
||||
|
||||
infixr `+l`:27 := coproduct_object
|
||||
local infixr + := coproduct_object
|
||||
|
||||
definition inl : d ⟶ d + d' :=
|
||||
colimit_morphism (c2_functor D d d') ff
|
||||
|
||||
definition inr : d' ⟶ d + d' :=
|
||||
colimit_morphism (c2_functor D d d') tt
|
||||
|
||||
variables {d d'}
|
||||
definition coproduct_hom {x : D} (f : d ⟶ x) (g : d' ⟶ x) : d + d' ⟶ x :=
|
||||
colimit_hom (c2_functor D d d') (bool.rec f g)
|
||||
(by intro b₁ b₂ f; induction b₁: induction b₂: esimp at *; try contradiction: apply id_right)
|
||||
|
||||
theorem coproduct_hom_inl {x : D} (f : d ⟶ x) (g : d' ⟶ x) : coproduct_hom f g ∘ !inl = f :=
|
||||
colimit_hom_commute (c2_functor D d d') (bool.rec f g) _ ff
|
||||
|
||||
theorem coproduct_hom_inr {x : D} (f : d ⟶ x) (g : d' ⟶ x) : coproduct_hom f g ∘ !inr = g :=
|
||||
colimit_hom_commute (c2_functor D d d') (bool.rec f g) _ tt
|
||||
|
||||
theorem eq_coproduct_hom {x : D} {f : d ⟶ x} {g : d' ⟶ x} {h : d + d' ⟶ x}
|
||||
(p : h ∘ !inl = f) (q : h ∘ !inr = g) : h = coproduct_hom f g :=
|
||||
eq_colimit_hom _ (bool.rec p q)
|
||||
|
||||
theorem coproduct_cocone_unique {x : D} {f : d ⟶ x} {g : d' ⟶ x}
|
||||
{h₁ : d + d' ⟶ x} (p₁ : h₁ ∘ !inl = f) (q₁ : h₁ ∘ !inr = g)
|
||||
{h₂ : d + d' ⟶ x} (p₂ : h₂ ∘ !inl = f) (q₂ : h₂ ∘ !inr = g) : h₁ = h₂ :=
|
||||
eq_coproduct_hom p₁ q₁ ⬝ (eq_coproduct_hom p₂ q₂)⁻¹
|
||||
|
||||
variable (D)
|
||||
-- TODO: define this in terms of colimit_functor and functor_two_left (in exponential_laws)
|
||||
definition coproduct_functor [constructor] : D ×c D ⇒ D :=
|
||||
functor.mk
|
||||
(λx, coproduct_object x.1 x.2)
|
||||
(λx y f, coproduct_hom (!inl ∘ f.1) (!inr ∘ f.2))
|
||||
abstract begin intro x, symmetry, apply eq_coproduct_hom: apply id_comp_eq_comp_id end end
|
||||
abstract begin intro x y z g f, symmetry, apply eq_coproduct_hom,
|
||||
rewrite [-assoc,coproduct_hom_inl,assoc,coproduct_hom_inl,-assoc],
|
||||
rewrite [-assoc,coproduct_hom_inr,assoc,coproduct_hom_inr,-assoc] end end
|
||||
omit K
|
||||
variables {D} (d d')
|
||||
|
||||
definition coproduct_object_iso_coproduct_object [constructor] (H₁ H₂ : has_binary_coproducts D) :
|
||||
@coproduct_object D H₁ d d' ≅ @coproduct_object D H₂ d d' :=
|
||||
colimit_object_iso_colimit_object _ H₁ H₂
|
||||
|
||||
end bin_coproducts
|
||||
|
||||
/-
|
||||
intentionally we define coproducts in terms of colimits,
|
||||
but coequalizers in terms of equalizers, to see which characterization is more useful
|
||||
-/
|
||||
|
||||
section coequalizers
|
||||
open bool prod.ops sum equalizer_category_hom
|
||||
|
||||
definition has_coequalizers [reducible] (D : Precategory) := has_equalizers Dᵒᵖ
|
||||
variables [K : has_coequalizers D]
|
||||
include K
|
||||
|
||||
variables {d d' x : D} (f g : d ⟶ d')
|
||||
definition coequalizer_object : D :=
|
||||
!(@equalizer_object Dᵒᵖ) f g
|
||||
|
||||
definition coequalizer : d' ⟶ coequalizer_object f g :=
|
||||
!(@equalizer Dᵒᵖ)
|
||||
|
||||
theorem coequalizes : coequalizer f g ∘ f = coequalizer f g ∘ g :=
|
||||
by rexact !(@equalizes Dᵒᵖ)
|
||||
|
||||
variables {f g}
|
||||
definition coequalizer_hom (h : d' ⟶ x) (p : h ∘ f = h ∘ g) : coequalizer_object f g ⟶ x :=
|
||||
!(@hom_equalizer Dᵒᵖ) proof p qed
|
||||
|
||||
theorem coequalizer_hom_coequalizer (h : d' ⟶ x) (p : h ∘ f = h ∘ g)
|
||||
: coequalizer_hom h p ∘ coequalizer f g = h :=
|
||||
by rexact !(@equalizer_hom_equalizer Dᵒᵖ)
|
||||
|
||||
theorem eq_coequalizer_hom {h : d' ⟶ x} (p : h ∘ f = h ∘ g) {i : coequalizer_object f g ⟶ x}
|
||||
(q : i ∘ coequalizer f g = h) : i = coequalizer_hom h p :=
|
||||
by rexact !(@eq_hom_equalizer Dᵒᵖ) proof q qed
|
||||
|
||||
theorem coequalizer_cocone_unique {h : d' ⟶ x} (p : h ∘ f = h ∘ g)
|
||||
{i₁ : coequalizer_object f g ⟶ x} (q₁ : i₁ ∘ coequalizer f g = h)
|
||||
{i₂ : coequalizer_object f g ⟶ x} (q₂ : i₂ ∘ coequalizer f g = h) : i₁ = i₂ :=
|
||||
!(@equalizer_cone_unique Dᵒᵖ) proof p qed proof q₁ qed proof q₂ qed
|
||||
|
||||
omit K
|
||||
variables (f g)
|
||||
definition coequalizer_object_iso_coequalizer_object [constructor] (H₁ H₂ : has_coequalizers D) :
|
||||
@coequalizer_object D H₁ _ _ f g ≅ @coequalizer_object D H₂ _ _ f g :=
|
||||
iso_of_opposite_iso !(@equalizer_object_iso_equalizer_object Dᵒᵖ)
|
||||
|
||||
end coequalizers
|
||||
|
||||
section pushouts
|
||||
open bool prod.ops sum pullback_category_hom
|
||||
|
||||
definition has_pushouts [reducible] (D : Precategory) := has_pullbacks Dᵒᵖ
|
||||
variables [K : has_pushouts D]
|
||||
include K
|
||||
|
||||
variables {d₁ d₂ d₃ x : D} (f : d₁ ⟶ d₂) (g : d₁ ⟶ d₃)
|
||||
definition pushout_object : D :=
|
||||
!(@pullback_object Dᵒᵖ) f g
|
||||
|
||||
definition pushout : d₃ ⟶ pushout_object f g :=
|
||||
!(@pullback Dᵒᵖ)
|
||||
|
||||
definition pushout_rev : d₂ ⟶ pushout_object f g :=
|
||||
!(@pullback_rev Dᵒᵖ)
|
||||
|
||||
theorem pushout_commutes : pushout_rev f g ∘ f = pushout f g ∘ g :=
|
||||
by rexact !(@pullback_commutes Dᵒᵖ)
|
||||
|
||||
variables {f g}
|
||||
definition pushout_hom (h₁ : d₂ ⟶ x) (h₂ : d₃ ⟶ x) (p : h₁ ∘ f = h₂ ∘ g)
|
||||
: pushout_object f g ⟶ x :=
|
||||
!(@hom_pullback Dᵒᵖ) proof p qed
|
||||
|
||||
theorem pushout_hom_pushout (h₁ : d₂ ⟶ x) (h₂ : d₃ ⟶ x) (p : h₁ ∘ f = h₂ ∘ g)
|
||||
: pushout_hom h₁ h₂ p ∘ pushout f g = h₂ :=
|
||||
by rexact !(@pullback_hom_pullback Dᵒᵖ)
|
||||
|
||||
theorem pushout_hom_pushout_rev (h₁ : d₂ ⟶ x) (h₂ : d₃ ⟶ x) (p : h₁ ∘ f = h₂ ∘ g)
|
||||
: pushout_hom h₁ h₂ p ∘ pushout_rev f g = h₁ :=
|
||||
by rexact !(@pullback_rev_hom_pullback Dᵒᵖ)
|
||||
|
||||
theorem eq_pushout_hom {h₁ : d₂ ⟶ x} {h₂ : d₃ ⟶ x} (p : h₁ ∘ f = h₂ ∘ g)
|
||||
{i : pushout_object f g ⟶ x} (q : i ∘ pushout f g = h₂) (r : i ∘ pushout_rev f g = h₁)
|
||||
: i = pushout_hom h₁ h₂ p :=
|
||||
by rexact !(@eq_hom_pullback Dᵒᵖ) proof q qed proof r qed
|
||||
|
||||
theorem pushout_cocone_unique {h₁ : d₂ ⟶ x} {h₂ : d₃ ⟶ x} (p : h₁ ∘ f = h₂ ∘ g)
|
||||
{i₁ : pushout_object f g ⟶ x} (q₁ : i₁ ∘ pushout f g = h₂) (r₁ : i₁ ∘ pushout_rev f g = h₁)
|
||||
{i₂ : pushout_object f g ⟶ x} (q₂ : i₂ ∘ pushout f g = h₂) (r₂ : i₂ ∘ pushout_rev f g = h₁)
|
||||
: i₁ = i₂ :=
|
||||
!(@pullback_cone_unique Dᵒᵖ) proof p qed proof q₁ qed proof r₁ qed proof q₂ qed proof r₂ qed
|
||||
|
||||
omit K
|
||||
variables (f g)
|
||||
definition pushout_object_iso_pushout_object [constructor] (H₁ H₂ : has_pushouts D) :
|
||||
@pushout_object D H₁ _ _ _ f g ≅ @pushout_object D H₂ _ _ _ f g :=
|
||||
iso_of_opposite_iso !(@pullback_object_iso_pullback_object (Opposite D))
|
||||
|
||||
end pushouts
|
||||
|
||||
definition has_limits_of_shape_op_op [H : has_limits_of_shape D Iᵒᵖᵒᵖ]
|
||||
: has_limits_of_shape D I :=
|
||||
by induction I with I Is; induction Is; exact H
|
||||
|
||||
namespace ops
|
||||
infixr + := coproduct_object
|
||||
end ops
|
||||
|
||||
end category
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import .set .functor .adjoint .functor_preserve
|
||||
|
|
@ -1,148 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Functor category has (co)limits if the codomain has them
|
||||
-/
|
||||
|
||||
import .colimits
|
||||
|
||||
open functor nat_trans eq is_trunc
|
||||
|
||||
namespace category
|
||||
|
||||
-- preservation of limits
|
||||
variables {D C I : Precategory}
|
||||
|
||||
definition functor_limit_object [constructor]
|
||||
[H : has_limits_of_shape D I] (F : I ⇒ D ^c C) : C ⇒ D :=
|
||||
begin
|
||||
have lem : Π(c d : carrier C) (f : hom c d) ⦃i j : carrier I⦄ (k : i ⟶ j),
|
||||
(constant2_functor F d) k ∘ to_fun_hom (F i) f ∘ limit_morphism (constant2_functor F c) i =
|
||||
to_fun_hom (F j) f ∘ limit_morphism (constant2_functor F c) j,
|
||||
begin intro c d f i j k, rewrite [-limit_commute _ k,▸*,+assoc,▸*,-naturality (F k) f] end,
|
||||
|
||||
fapply functor.mk,
|
||||
{ intro c, exact limit_object (constant2_functor F c)},
|
||||
{ intro c d f, fapply hom_limit,
|
||||
{ intro i, refine to_fun_hom (F i) f ∘ !limit_morphism},
|
||||
{ apply lem}},
|
||||
{ exact abstract begin intro c, symmetry, apply eq_hom_limit, intro i,
|
||||
rewrite [id_right,respect_id,▸*,id_left] end end},
|
||||
{ intro a b c g f, symmetry, apply eq_hom_limit, intro i, -- report: adding abstract fails here
|
||||
rewrite [respect_comp,assoc,hom_limit_commute,-assoc,hom_limit_commute,assoc]}
|
||||
end
|
||||
|
||||
definition functor_limit_cone [constructor]
|
||||
[H : has_limits_of_shape D I] (F : I ⇒ D ^c C) : cone_obj F :=
|
||||
begin
|
||||
fapply cone_obj.mk,
|
||||
{ exact functor_limit_object F},
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro i, esimp, fapply nat_trans.mk,
|
||||
{ intro c, esimp, apply limit_morphism},
|
||||
{ intro c d f, rewrite [▸*,hom_limit_commute (constant2_functor F d)]}},
|
||||
{ intro i j k, apply nat_trans_eq, intro c,
|
||||
rewrite [▸*,id_right,limit_commute (constant2_functor F c)]}}
|
||||
end
|
||||
|
||||
variables (D C I)
|
||||
definition has_limits_of_shape_functor [instance] [H : has_limits_of_shape D I]
|
||||
: has_limits_of_shape (D ^c C) I :=
|
||||
begin
|
||||
intro F, fapply has_terminal_object.mk,
|
||||
{ exact functor_limit_cone F},
|
||||
{ intro c, esimp at *, induction c with G η, induction η with η p, esimp at *,
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro c, esimp, fapply hom_limit,
|
||||
{ intro i, esimp, exact η i c},
|
||||
{ intro i j k, esimp, exact ap010 natural_map (p k) c ⬝ !id_right}},
|
||||
{ intro c d f, esimp, fapply @limit_cone_unique,
|
||||
{ intro i, esimp, exact to_fun_hom (F i) f ∘ η i c},
|
||||
{ intro i j k, rewrite [▸*,assoc,-naturality,-assoc,-compose_def,p k,▸*,id_right]},
|
||||
{ intro i, rewrite [assoc, hom_limit_commute (constant2_functor F d),▸*,-assoc,
|
||||
hom_limit_commute]},
|
||||
{ intro i, rewrite [assoc, hom_limit_commute (constant2_functor F d),naturality]}}},
|
||||
{ intro i, apply nat_trans_eq, intro c,
|
||||
rewrite [▸*,hom_limit_commute (constant2_functor F c)]}},
|
||||
{ intro h, induction h with f q, apply cone_hom_eq,
|
||||
apply nat_trans_eq, intro c, esimp at *, symmetry,
|
||||
apply eq_hom_limit, intro i, exact ap010 natural_map (q i) c}}
|
||||
end
|
||||
|
||||
definition is_complete_functor [instance] [H : is_complete D] : is_complete (D ^c C) :=
|
||||
λI, _
|
||||
|
||||
variables {D C I}
|
||||
-- preservation of colimits
|
||||
|
||||
-- definition constant2_functor_op [constructor] (F : I ⇒ (D ^c C)ᵒᵖ) (c : C) : I ⇒ D :=
|
||||
-- proof
|
||||
-- functor.mk (λi, to_fun_ob (F i) c)
|
||||
-- (λi j f, natural_map (F f) c)
|
||||
-- abstract (λi, ap010 natural_map !respect_id c ⬝ proof idp qed) end
|
||||
-- abstract (λi j k g f, ap010 natural_map !respect_comp c) end
|
||||
-- qed
|
||||
|
||||
definition functor_colimit_object [constructor]
|
||||
[H : has_colimits_of_shape D I] (F : Iᵒᵖ ⇒ (D ^c C)ᵒᵖ) : C ⇒ D :=
|
||||
begin
|
||||
fapply functor.mk,
|
||||
{ intro c, exact colimit_object (constant2_functor Fᵒᵖ' c)},
|
||||
{ intro c d f, apply colimit_hom_colimit, apply constant2_functor_natural _ f},
|
||||
{ exact abstract begin intro c, symmetry, apply eq_colimit_hom, intro i,
|
||||
rewrite [id_left,▸*,respect_id,id_right] end end},
|
||||
{ intro a b c g f, symmetry, apply eq_colimit_hom, intro i, -- report: adding abstract fails here
|
||||
rewrite [▸*,respect_comp,-assoc,colimit_hom_commute,assoc,colimit_hom_commute,-assoc]}
|
||||
end
|
||||
|
||||
definition functor_colimit_cone [constructor]
|
||||
[H : has_colimits_of_shape D I] (F : Iᵒᵖ ⇒ (D ^c C)ᵒᵖ) : cone_obj F :=
|
||||
begin
|
||||
fapply cone_obj.mk,
|
||||
{ exact functor_colimit_object F},
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro i, esimp, fapply nat_trans.mk,
|
||||
{ intro c, esimp, apply colimit_morphism},
|
||||
{ intro c d f, apply colimit_hom_commute (constant2_functor Fᵒᵖ' c)}},
|
||||
{ intro i j k, apply nat_trans_eq, intro c,
|
||||
rewrite [▸*,id_left], apply colimit_commute (constant2_functor Fᵒᵖ' c)}}
|
||||
end
|
||||
|
||||
variables (D C I)
|
||||
definition has_colimits_of_shape_functor [instance] [H : has_colimits_of_shape D I]
|
||||
: has_colimits_of_shape (D ^c C) I :=
|
||||
begin
|
||||
intro F, fapply has_terminal_object.mk,
|
||||
{ exact functor_colimit_cone F},
|
||||
{ intro c, esimp at *, induction c with G η, induction η with η p, esimp at *,
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro c, esimp, fapply colimit_hom,
|
||||
{ intro i, esimp, exact η i c},
|
||||
{ intro i j k, esimp, exact ap010 natural_map (p k) c ⬝ !id_left}},
|
||||
{ intro c d f, esimp, fapply @colimit_cocone_unique,
|
||||
{ intro i, esimp, exact η i d ∘ to_fun_hom (F i) f},
|
||||
{ intro i j k, rewrite [▸*,-assoc,naturality,assoc,-compose_def,p k,▸*,id_left]},
|
||||
{ intro i, rewrite [-assoc, colimit_hom_commute (constant2_functor Fᵒᵖ' c),
|
||||
▸*, naturality]},
|
||||
{ intro i, rewrite [-assoc, colimit_hom_commute (constant2_functor Fᵒᵖ' c),▸*,assoc,
|
||||
colimit_hom_commute (constant2_functor Fᵒᵖ' d)]}}},
|
||||
{ intro i, apply nat_trans_eq, intro c,
|
||||
rewrite [▸*,colimit_hom_commute (constant2_functor Fᵒᵖ' c)]}},
|
||||
{ intro h, induction h with f q, apply cone_hom_eq,
|
||||
apply nat_trans_eq, intro c, esimp at *, symmetry,
|
||||
apply eq_colimit_hom, intro i, exact ap010 natural_map (q i) c}}
|
||||
end
|
||||
|
||||
local attribute has_limits_of_shape_op_op [instance] [priority 1]
|
||||
universe variables u v
|
||||
definition is_cocomplete_functor [instance] [H : is_cocomplete.{_ _ u v} D]
|
||||
: is_cocomplete.{_ _ u v} (D ^c C) :=
|
||||
λI, _
|
||||
|
||||
end category
|
||||
|
|
@ -1,125 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Functors preserving limits
|
||||
-/
|
||||
|
||||
import .colimits ..functor.yoneda ..functor.adjoint
|
||||
|
||||
open eq functor yoneda is_trunc nat_trans
|
||||
|
||||
namespace category
|
||||
|
||||
variables {I C D : Precategory} {F : I ⇒ C} {G : C ⇒ D}
|
||||
|
||||
/- notions of preservation of limits -/
|
||||
definition preserves_limits_of_shape [class] (G : C ⇒ D) (I : Precategory)
|
||||
[H : has_limits_of_shape C I] :=
|
||||
Π(F : I ⇒ C), is_terminal (cone_obj_compose G (limit_cone F))
|
||||
|
||||
definition preserves_existing_limits_of_shape [class] (G : C ⇒ D) (I : Precategory) :=
|
||||
Π(F : I ⇒ C) [H : has_terminal_object (cone F)],
|
||||
is_terminal (cone_obj_compose G (terminal_object (cone F)))
|
||||
|
||||
definition preserves_existing_limits [class] (G : C ⇒ D) :=
|
||||
Π(I : Precategory) (F : I ⇒ C) [H : has_terminal_object (cone F)],
|
||||
is_terminal (cone_obj_compose G (terminal_object (cone F)))
|
||||
|
||||
definition preserves_limits [class] (G : C ⇒ D) [H : is_complete C] :=
|
||||
Π(I : Precategory) [H : has_limits_of_shape C I] (F : I ⇒ C),
|
||||
is_terminal (cone_obj_compose G (limit_cone F))
|
||||
|
||||
definition preserves_chosen_limits_of_shape [class] (G : C ⇒ D) (I : Precategory)
|
||||
[H : has_limits_of_shape C I] [H : has_limits_of_shape D I] :=
|
||||
Π(F : I ⇒ C), cone_obj_compose G (limit_cone F) = limit_cone (G ∘f F)
|
||||
|
||||
definition preserves_chosen_limits [class] (G : C ⇒ D)
|
||||
[H : is_complete C] [H : is_complete D] :=
|
||||
Π(I : Precategory) (F : I ⇒ C), cone_obj_compose G (limit_cone F) = limit_cone (G ∘f F)
|
||||
|
||||
/- basic instances -/
|
||||
definition preserves_limits_of_shape_of_preserves_limits [instance] (G : C ⇒ D)
|
||||
(I : Precategory) [H : is_complete C] [H : preserves_limits G]
|
||||
: preserves_limits_of_shape G I := H I
|
||||
|
||||
definition preserves_chosen_limits_of_shape_of_preserves_chosen_limits [instance] (G : C ⇒ D)
|
||||
(I : Precategory) [H : is_complete C] [H : is_complete D] [K : preserves_chosen_limits G]
|
||||
: preserves_chosen_limits_of_shape G I := K I
|
||||
|
||||
/- yoneda preserves existing limits -/
|
||||
|
||||
local attribute category.to_precategory [constructor]
|
||||
|
||||
definition preserves_existing_limits_yoneda_embedding_lemma [constructor]
|
||||
(y : cone_obj F)
|
||||
[H : is_terminal y] {G : Cᵒᵖ ⇒ cset} (η : constant_functor I G ⟹ ɏ ∘f F) :
|
||||
G ⟹ hom_functor_left (cone_to_obj y) :=
|
||||
begin
|
||||
fapply nat_trans.mk: esimp,
|
||||
{ intro c x, fapply to_hom_limit,
|
||||
{ intro i, exact η i c x},
|
||||
{ exact abstract begin
|
||||
intro i j k,
|
||||
exact !id_right⁻¹ ⬝ !assoc⁻¹ ⬝ ap0100 natural_map (naturality η k) c x end end
|
||||
}},
|
||||
-- [BUG] abstracting here creates multiple lemmas proving this fact
|
||||
{ intro c c' f, apply eq_of_homotopy, intro x,
|
||||
rewrite [id_left], apply to_eq_hom_limit, intro i,
|
||||
refine !assoc ⬝ _, rewrite to_hom_limit_commute,
|
||||
refine _ ⬝ ap10 (naturality (η i) f) x, rewrite [▸*, id_left]}
|
||||
-- abstracting here fails
|
||||
end
|
||||
|
||||
theorem preserves_existing_limits_yoneda_embedding (C : Precategory)
|
||||
: preserves_existing_limits (yoneda_embedding C) :=
|
||||
begin
|
||||
intro I F H Gη, induction H with y H, induction Gη with G η, esimp at *,
|
||||
have lem : Π(i : carrier I),
|
||||
nat_trans_hom_functor_left (natural_map (cone_to_nat y) i)
|
||||
∘n @preserves_existing_limits_yoneda_embedding_lemma I C F y H G η = natural_map η i,
|
||||
begin
|
||||
intro i, apply nat_trans_eq, intro c, apply eq_of_homotopy, intro x,
|
||||
esimp, refine !assoc ⬝ !id_right ⬝ !to_hom_limit_commute
|
||||
end,
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ exact preserves_existing_limits_yoneda_embedding_lemma y η},
|
||||
{ exact lem}},
|
||||
{ intro v, apply cone_hom_eq, esimp, apply nat_trans_eq, esimp, intro c,
|
||||
apply eq_of_homotopy, intro x, refine (to_eq_hom_limit _ _)⁻¹,
|
||||
intro i, refine !id_right⁻¹ ⬝ !assoc⁻¹ ⬝ _,
|
||||
exact ap0100 natural_map (cone_to_eq v i) c x}
|
||||
end
|
||||
|
||||
/- left adjoint functors preserve limits -/
|
||||
|
||||
/- definition preserves_existing_limits_left_adjoint_lemma {C D : Precategory} (F : C ⇒ D)
|
||||
[H : is_left_adjoint F] {I : Precategory} {G : I ⇒ C} (y : cone_obj G) [K : is_terminal y]
|
||||
{d : carrier D} (η : constant_functor I d ⟹ F ∘f G) : d ⟶ to_fun_ob F (cone_to_obj y) :=
|
||||
begin
|
||||
let η := unit F, let θ := counit F, exact sorry
|
||||
end
|
||||
|
||||
theorem preserves_existing_limits_left_adjoint {C D : Precategory} (F : C ⇒ D)
|
||||
[H : is_left_adjoint F] : preserves_existing_limits F :=
|
||||
begin
|
||||
intro I G K dη, induction K with y K, induction dη with d η, esimp at *,
|
||||
-- have lem : Π (i : carrier I),
|
||||
-- nat_trans_hom_functor_left (natural_map (cone_to_nat y) i)
|
||||
-- ∘n preserves_existing_limits_yoneda_embedding_lemma y η = natural_map η i,
|
||||
-- { intro i, apply nat_trans_eq, intro c, apply eq_of_homotopy, intro x,
|
||||
-- esimp, refine !assoc ⬝ !id_right ⬝ !to_hom_limit_commute},
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ esimp, exact sorry},
|
||||
{ exact lem}},
|
||||
{ intro v, apply cone_hom_eq, esimp, apply nat_trans_eq, esimp, intro c,
|
||||
apply eq_of_homotopy, intro x, refine (to_eq_hom_limit _ _)⁻¹,
|
||||
intro i, refine !id_right⁻¹ ⬝ !assoc⁻¹ ⬝ _,
|
||||
exact ap0100 natural_map (cone_to_eq v i) c x}
|
||||
end-/
|
||||
|
||||
|
||||
end category
|
||||
|
|
@ -1,417 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Limits in a category
|
||||
-/
|
||||
|
||||
import ..constructions.cone ..constructions.discrete ..constructions.product
|
||||
..constructions.finite_cats ..category ..constructions.functor
|
||||
|
||||
open is_trunc functor nat_trans eq
|
||||
|
||||
namespace category
|
||||
|
||||
variables {ob : Type} [C : precategory ob] {c c' : ob} (D I : Precategory)
|
||||
include C
|
||||
|
||||
definition is_terminal [class] (c : ob) := Πd, is_contr (d ⟶ c)
|
||||
definition is_contr_of_is_terminal (c d : ob) [H : is_terminal d] : is_contr (c ⟶ d) :=
|
||||
H c
|
||||
|
||||
local attribute is_contr_of_is_terminal [instance]
|
||||
|
||||
definition terminal_morphism (c c' : ob) [H : is_terminal c'] : c ⟶ c' :=
|
||||
!center
|
||||
|
||||
definition hom_terminal_eq [H : is_terminal c'] (f f' : c ⟶ c') : f = f' :=
|
||||
!is_prop.elim
|
||||
|
||||
definition eq_terminal_morphism [H : is_terminal c'] (f : c ⟶ c') : f = terminal_morphism c c' :=
|
||||
!is_prop.elim
|
||||
|
||||
definition terminal_iso_terminal (c c' : ob) [H : is_terminal c] [K : is_terminal c']
|
||||
: c ≅ c' :=
|
||||
iso.MK !terminal_morphism !terminal_morphism !hom_terminal_eq !hom_terminal_eq
|
||||
|
||||
local attribute is_terminal [reducible]
|
||||
theorem is_prop_is_terminal [instance] : is_prop (is_terminal c) :=
|
||||
_
|
||||
|
||||
omit C
|
||||
|
||||
structure has_terminal_object [class] (D : Precategory) :=
|
||||
(d : D)
|
||||
(is_terminal : is_terminal d)
|
||||
|
||||
definition terminal_object [reducible] [unfold 2] := @has_terminal_object.d
|
||||
attribute has_terminal_object.is_terminal [instance]
|
||||
|
||||
variable {D}
|
||||
definition terminal_object_iso_terminal_object (H₁ H₂ : has_terminal_object D)
|
||||
: @terminal_object D H₁ ≅ @terminal_object D H₂ :=
|
||||
!terminal_iso_terminal
|
||||
|
||||
theorem is_prop_has_terminal_object [instance] (D : Category)
|
||||
: is_prop (has_terminal_object D) :=
|
||||
begin
|
||||
apply is_prop.mk, intro t₁ t₂, induction t₁ with d₁ H₁, induction t₂ with d₂ H₂,
|
||||
have p : d₁ = d₂,
|
||||
begin apply eq_of_iso, apply terminal_iso_terminal end,
|
||||
induction p, exact ap _ !is_prop.elim
|
||||
end
|
||||
|
||||
variable (D)
|
||||
definition has_limits_of_shape [class] := Π(F : I ⇒ D), has_terminal_object (cone F)
|
||||
|
||||
/-
|
||||
The next definitions states that a category is complete with respect to diagrams
|
||||
in a certain universe. "is_complete.{o₁ h₁ o₂ h₂}" means that D is complete
|
||||
with respect to diagrams with shape in Precategory.{o₂ h₂}
|
||||
-/
|
||||
|
||||
definition is_complete.{o₁ h₁ o₂ h₂} [class] (D : Precategory.{o₁ h₁}) :=
|
||||
Π(I : Precategory.{o₂ h₂}), has_limits_of_shape D I
|
||||
|
||||
definition has_limits_of_shape_of_is_complete [instance] [H : is_complete D] (I : Precategory)
|
||||
: has_limits_of_shape D I := H I
|
||||
|
||||
section
|
||||
open pi
|
||||
theorem is_prop_has_limits_of_shape [instance] (D : Category) (I : Precategory)
|
||||
: is_prop (has_limits_of_shape D I) :=
|
||||
by apply is_trunc_pi; intro F; exact is_prop_has_terminal_object (Category_cone F)
|
||||
|
||||
local attribute is_complete [reducible]
|
||||
theorem is_prop_is_complete [instance] (D : Category) : is_prop (is_complete D) := _
|
||||
end
|
||||
|
||||
variables {D I}
|
||||
definition has_terminal_object_cone [H : has_limits_of_shape D I]
|
||||
(F : I ⇒ D) : has_terminal_object (cone F) := H F
|
||||
local attribute has_terminal_object_cone [instance]
|
||||
|
||||
variables (F : I ⇒ D) [H : has_limits_of_shape D I] {i j : I}
|
||||
include H
|
||||
|
||||
definition limit_cone : cone F := !terminal_object
|
||||
|
||||
definition is_terminal_limit_cone [instance] : is_terminal (limit_cone F) :=
|
||||
has_terminal_object.is_terminal _
|
||||
|
||||
section specific_limit
|
||||
omit H
|
||||
variable {F}
|
||||
variables (x : cone_obj F) [K : is_terminal x]
|
||||
include K
|
||||
|
||||
definition to_limit_object : D :=
|
||||
cone_to_obj x
|
||||
|
||||
definition to_limit_nat_trans : constant_functor I (to_limit_object x) ⟹ F :=
|
||||
cone_to_nat x
|
||||
|
||||
definition to_limit_morphism (i : I) : to_limit_object x ⟶ F i :=
|
||||
to_limit_nat_trans x i
|
||||
|
||||
theorem to_limit_commute {i j : I} (f : i ⟶ j)
|
||||
: to_fun_hom F f ∘ to_limit_morphism x i = to_limit_morphism x j :=
|
||||
naturality (to_limit_nat_trans x) f ⬝ !id_right
|
||||
|
||||
definition to_limit_cone_obj [constructor] {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) : cone_obj F :=
|
||||
cone_obj.mk d (nat_trans.mk η (λa b f, p f ⬝ !id_right⁻¹))
|
||||
|
||||
definition to_hom_limit {d : D} (η : Πi, d ⟶ F i)
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) : d ⟶ to_limit_object x :=
|
||||
cone_to_hom (terminal_morphism (to_limit_cone_obj x p) x)
|
||||
|
||||
theorem to_hom_limit_commute {d : D} (η : Πi, d ⟶ F i)
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) (i : I)
|
||||
: to_limit_morphism x i ∘ to_hom_limit x η p = η i :=
|
||||
cone_to_eq (terminal_morphism (to_limit_cone_obj x p) x) i
|
||||
|
||||
definition to_limit_cone_hom [constructor] {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) {h : d ⟶ to_limit_object x}
|
||||
(q : Πi, to_limit_morphism x i ∘ h = η i)
|
||||
: cone_hom (to_limit_cone_obj x p) x :=
|
||||
cone_hom.mk h q
|
||||
|
||||
variable {x}
|
||||
theorem to_eq_hom_limit {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) {h : d ⟶ to_limit_object x}
|
||||
(q : Πi, to_limit_morphism x i ∘ h = η i) : h = to_hom_limit x η p :=
|
||||
ap cone_to_hom (eq_terminal_morphism (to_limit_cone_hom x p q))
|
||||
|
||||
theorem to_limit_cone_unique {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j)
|
||||
{h₁ : d ⟶ to_limit_object x} (q₁ : Πi, to_limit_morphism x i ∘ h₁ = η i)
|
||||
{h₂ : d ⟶ to_limit_object x} (q₂ : Πi, to_limit_morphism x i ∘ h₂ = η i): h₁ = h₂ :=
|
||||
to_eq_hom_limit p q₁ ⬝ (to_eq_hom_limit p q₂)⁻¹
|
||||
|
||||
omit K
|
||||
definition to_limit_object_iso_to_limit_object [constructor] (x y : cone_obj F)
|
||||
[K : is_terminal x] [L : is_terminal y] : to_limit_object x ≅ to_limit_object y :=
|
||||
cone_iso_pr1 !terminal_iso_terminal
|
||||
|
||||
end specific_limit
|
||||
|
||||
/-
|
||||
TODO: relate below definitions to above definitions.
|
||||
However, type class resolution seems to fail...
|
||||
-/
|
||||
|
||||
definition limit_object : D :=
|
||||
cone_to_obj (limit_cone F)
|
||||
|
||||
definition limit_nat_trans : constant_functor I (limit_object F) ⟹ F :=
|
||||
cone_to_nat (limit_cone F)
|
||||
|
||||
definition limit_morphism (i : I) : limit_object F ⟶ F i :=
|
||||
limit_nat_trans F i
|
||||
|
||||
variable {H}
|
||||
theorem limit_commute {i j : I} (f : i ⟶ j)
|
||||
: to_fun_hom F f ∘ limit_morphism F i = limit_morphism F j :=
|
||||
naturality (limit_nat_trans F) f ⬝ !id_right
|
||||
|
||||
variable [H]
|
||||
definition limit_cone_obj [constructor] {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) : cone_obj F :=
|
||||
cone_obj.mk d (nat_trans.mk η (λa b f, p f ⬝ !id_right⁻¹))
|
||||
|
||||
variable {H}
|
||||
definition hom_limit {d : D} (η : Πi, d ⟶ F i)
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) : d ⟶ limit_object F :=
|
||||
cone_to_hom (@(terminal_morphism (limit_cone_obj F p) _) (is_terminal_limit_cone _))
|
||||
|
||||
theorem hom_limit_commute {d : D} (η : Πi, d ⟶ F i)
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) (i : I)
|
||||
: limit_morphism F i ∘ hom_limit F η p = η i :=
|
||||
cone_to_eq (@(terminal_morphism (limit_cone_obj F p) _) (is_terminal_limit_cone _)) i
|
||||
|
||||
definition limit_cone_hom [constructor] {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) {h : d ⟶ limit_object F}
|
||||
(q : Πi, limit_morphism F i ∘ h = η i) : cone_hom (limit_cone_obj F p) (limit_cone F) :=
|
||||
cone_hom.mk h q
|
||||
|
||||
variable {F}
|
||||
theorem eq_hom_limit {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) {h : d ⟶ limit_object F}
|
||||
(q : Πi, limit_morphism F i ∘ h = η i) : h = hom_limit F η p :=
|
||||
ap cone_to_hom (@eq_terminal_morphism _ _ _ _ (is_terminal_limit_cone _) (limit_cone_hom F p q))
|
||||
|
||||
theorem limit_cone_unique {d : D} {η : Πi, d ⟶ F i}
|
||||
(p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j)
|
||||
{h₁ : d ⟶ limit_object F} (q₁ : Πi, limit_morphism F i ∘ h₁ = η i)
|
||||
{h₂ : d ⟶ limit_object F} (q₂ : Πi, limit_morphism F i ∘ h₂ = η i): h₁ = h₂ :=
|
||||
eq_hom_limit p q₁ ⬝ (eq_hom_limit p q₂)⁻¹
|
||||
|
||||
definition limit_hom_limit {F G : I ⇒ D} (η : F ⟹ G) : limit_object F ⟶ limit_object G :=
|
||||
hom_limit _ (λi, η i ∘ limit_morphism F i)
|
||||
abstract by intro i j f; rewrite [assoc,naturality,-assoc,limit_commute] end
|
||||
|
||||
theorem limit_hom_limit_commute {F G : I ⇒ D} (η : F ⟹ G)
|
||||
: limit_morphism G i ∘ limit_hom_limit η = η i ∘ limit_morphism F i :=
|
||||
!hom_limit_commute
|
||||
|
||||
-- theorem hom_limit_commute {d : D} (η : Πi, d ⟶ F i)
|
||||
-- (p : Π⦃i j : I⦄ (f : i ⟶ j), to_fun_hom F f ∘ η i = η j) (i : I)
|
||||
-- : limit_morphism F i ∘ hom_limit F η p = η i :=
|
||||
-- cone_to_eq (@(terminal_morphism (limit_cone_obj F p) _) (is_terminal_limit_cone _)) i
|
||||
|
||||
omit H
|
||||
|
||||
variable (F)
|
||||
definition limit_object_iso_limit_object [constructor] (H₁ H₂ : has_limits_of_shape D I) :
|
||||
@(limit_object F) H₁ ≅ @(limit_object F) H₂ :=
|
||||
cone_iso_pr1 !terminal_object_iso_terminal_object
|
||||
|
||||
definition limit_functor [constructor] (D I : Precategory) [H : has_limits_of_shape D I]
|
||||
: D ^c I ⇒ D :=
|
||||
begin
|
||||
fapply functor.mk: esimp,
|
||||
{ intro F, exact limit_object F},
|
||||
{ apply @limit_hom_limit},
|
||||
{ intro F, unfold limit_hom_limit, refine (eq_hom_limit _ _)⁻¹, intro i,
|
||||
apply comp_id_eq_id_comp},
|
||||
{ intro F G H η θ, unfold limit_hom_limit, refine (eq_hom_limit _ _)⁻¹, intro i,
|
||||
rewrite [assoc, hom_limit_commute, -assoc, hom_limit_commute, assoc]}
|
||||
end
|
||||
|
||||
section bin_products
|
||||
open bool prod.ops
|
||||
definition has_binary_products [reducible] (D : Precategory) := has_limits_of_shape D c2
|
||||
variables [K : has_binary_products D] (d d' : D)
|
||||
include K
|
||||
|
||||
definition product_object : D :=
|
||||
limit_object (c2_functor D d d')
|
||||
|
||||
infixr ` ×l `:75 := product_object
|
||||
|
||||
definition pr1 : d ×l d' ⟶ d :=
|
||||
limit_morphism (c2_functor D d d') ff
|
||||
|
||||
definition pr2 : d ×l d' ⟶ d' :=
|
||||
limit_morphism (c2_functor D d d') tt
|
||||
|
||||
variables {d d'}
|
||||
definition hom_product {x : D} (f : x ⟶ d) (g : x ⟶ d') : x ⟶ d ×l d' :=
|
||||
hom_limit (c2_functor D d d') (bool.rec f g)
|
||||
(by intro b₁ b₂ f; induction b₁: induction b₂: esimp at *; try contradiction: apply id_left)
|
||||
|
||||
theorem pr1_hom_product {x : D} (f : x ⟶ d) (g : x ⟶ d') : !pr1 ∘ hom_product f g = f :=
|
||||
hom_limit_commute (c2_functor D d d') (bool.rec f g) _ ff
|
||||
|
||||
theorem pr2_hom_product {x : D} (f : x ⟶ d) (g : x ⟶ d') : !pr2 ∘ hom_product f g = g :=
|
||||
hom_limit_commute (c2_functor D d d') (bool.rec f g) _ tt
|
||||
|
||||
theorem eq_hom_product {x : D} {f : x ⟶ d} {g : x ⟶ d'} {h : x ⟶ d ×l d'}
|
||||
(p : !pr1 ∘ h = f) (q : !pr2 ∘ h = g) : h = hom_product f g :=
|
||||
eq_hom_limit _ (bool.rec p q)
|
||||
|
||||
theorem product_cone_unique {x : D} {f : x ⟶ d} {g : x ⟶ d'}
|
||||
{h₁ : x ⟶ d ×l d'} (p₁ : !pr1 ∘ h₁ = f) (q₁ : !pr2 ∘ h₁ = g)
|
||||
{h₂ : x ⟶ d ×l d'} (p₂ : !pr1 ∘ h₂ = f) (q₂ : !pr2 ∘ h₂ = g) : h₁ = h₂ :=
|
||||
eq_hom_product p₁ q₁ ⬝ (eq_hom_product p₂ q₂)⁻¹
|
||||
|
||||
variable (D)
|
||||
-- TODO: define this in terms of limit_functor and functor_two_left (in exponential_laws)
|
||||
definition product_functor [constructor] : D ×c D ⇒ D :=
|
||||
functor.mk
|
||||
(λx, product_object x.1 x.2)
|
||||
(λx y f, hom_product (f.1 ∘ !pr1) (f.2 ∘ !pr2))
|
||||
abstract begin intro x, symmetry, apply eq_hom_product: apply comp_id_eq_id_comp end end
|
||||
abstract begin intro x y z g f, symmetry, apply eq_hom_product,
|
||||
rewrite [assoc,pr1_hom_product,-assoc,pr1_hom_product,assoc],
|
||||
rewrite [assoc,pr2_hom_product,-assoc,pr2_hom_product,assoc] end end
|
||||
omit K
|
||||
variables {D} (d d')
|
||||
|
||||
definition product_object_iso_product_object [constructor] (H₁ H₂ : has_binary_products D) :
|
||||
@product_object D H₁ d d' ≅ @product_object D H₂ d d' :=
|
||||
limit_object_iso_limit_object _ H₁ H₂
|
||||
|
||||
end bin_products
|
||||
|
||||
section equalizers
|
||||
open bool prod.ops sum equalizer_category_hom
|
||||
definition has_equalizers [reducible] (D : Precategory) := has_limits_of_shape D equalizer_category
|
||||
variables [K : has_equalizers D]
|
||||
include K
|
||||
|
||||
variables {d d' x : D} (f g : d ⟶ d')
|
||||
definition equalizer_object : D :=
|
||||
limit_object (equalizer_category_functor D f g)
|
||||
|
||||
definition equalizer : equalizer_object f g ⟶ d :=
|
||||
limit_morphism (equalizer_category_functor D f g) ff
|
||||
|
||||
theorem equalizes : f ∘ equalizer f g = g ∘ equalizer f g :=
|
||||
limit_commute (equalizer_category_functor D f g) (inl f1) ⬝
|
||||
(limit_commute (equalizer_category_functor D f g) (inl f2))⁻¹
|
||||
|
||||
variables {f g}
|
||||
definition hom_equalizer (h : x ⟶ d) (p : f ∘ h = g ∘ h) : x ⟶ equalizer_object f g :=
|
||||
hom_limit (equalizer_category_functor D f g)
|
||||
(bool.rec h (g ∘ h))
|
||||
begin
|
||||
intro b₁ b₂ i; induction i with j j: induction j,
|
||||
-- report(?) "esimp" is super slow here
|
||||
exact p, reflexivity, apply id_left
|
||||
end
|
||||
|
||||
theorem equalizer_hom_equalizer (h : x ⟶ d) (p : f ∘ h = g ∘ h)
|
||||
: equalizer f g ∘ hom_equalizer h p = h :=
|
||||
hom_limit_commute (equalizer_category_functor D f g) (bool.rec h (g ∘ h)) _ ff
|
||||
|
||||
theorem eq_hom_equalizer {h : x ⟶ d} (p : f ∘ h = g ∘ h) {i : x ⟶ equalizer_object f g}
|
||||
(q : equalizer f g ∘ i = h) : i = hom_equalizer h p :=
|
||||
eq_hom_limit _ (bool.rec q
|
||||
begin
|
||||
refine ap (λx, x ∘ i) (limit_commute (equalizer_category_functor D f g) (inl f2))⁻¹ ⬝ _,
|
||||
refine !assoc⁻¹ ⬝ _,
|
||||
exact ap (λx, _ ∘ x) q
|
||||
end)
|
||||
|
||||
theorem equalizer_cone_unique {h : x ⟶ d} (p : f ∘ h = g ∘ h)
|
||||
{i₁ : x ⟶ equalizer_object f g} (q₁ : equalizer f g ∘ i₁ = h)
|
||||
{i₂ : x ⟶ equalizer_object f g} (q₂ : equalizer f g ∘ i₂ = h) : i₁ = i₂ :=
|
||||
eq_hom_equalizer p q₁ ⬝ (eq_hom_equalizer p q₂)⁻¹
|
||||
|
||||
omit K
|
||||
variables (f g)
|
||||
definition equalizer_object_iso_equalizer_object [constructor] (H₁ H₂ : has_equalizers D) :
|
||||
@equalizer_object D H₁ _ _ f g ≅ @equalizer_object D H₂ _ _ f g :=
|
||||
limit_object_iso_limit_object _ H₁ H₂
|
||||
|
||||
end equalizers
|
||||
|
||||
section pullbacks
|
||||
open sum prod.ops pullback_category_ob pullback_category_hom
|
||||
definition has_pullbacks [reducible] (D : Precategory) := has_limits_of_shape D pullback_category
|
||||
variables [K : has_pullbacks D]
|
||||
include K
|
||||
|
||||
variables {d₁ d₂ d₃ x : D} (f : d₁ ⟶ d₃) (g : d₂ ⟶ d₃)
|
||||
definition pullback_object : D :=
|
||||
limit_object (pullback_category_functor D f g)
|
||||
|
||||
definition pullback : pullback_object f g ⟶ d₂ :=
|
||||
limit_morphism (pullback_category_functor D f g) BL
|
||||
|
||||
definition pullback_rev : pullback_object f g ⟶ d₁ :=
|
||||
limit_morphism (pullback_category_functor D f g) TR
|
||||
|
||||
theorem pullback_commutes : f ∘ pullback_rev f g = g ∘ pullback f g :=
|
||||
limit_commute (pullback_category_functor D f g) (inl f1) ⬝
|
||||
(limit_commute (pullback_category_functor D f g) (inl f2))⁻¹
|
||||
|
||||
variables {f g}
|
||||
definition hom_pullback (h₁ : x ⟶ d₁) (h₂ : x ⟶ d₂) (p : f ∘ h₁ = g ∘ h₂)
|
||||
: x ⟶ pullback_object f g :=
|
||||
hom_limit (pullback_category_functor D f g)
|
||||
(pullback_category_ob.rec h₁ h₂ (g ∘ h₂))
|
||||
begin
|
||||
intro i₁ i₂ k; induction k with j j: induction j,
|
||||
exact p, reflexivity, apply id_left
|
||||
end
|
||||
|
||||
theorem pullback_hom_pullback (h₁ : x ⟶ d₁) (h₂ : x ⟶ d₂) (p : f ∘ h₁ = g ∘ h₂)
|
||||
: pullback f g ∘ hom_pullback h₁ h₂ p = h₂ :=
|
||||
hom_limit_commute (pullback_category_functor D f g) (pullback_category_ob.rec h₁ h₂ (g ∘ h₂)) _ BL
|
||||
|
||||
theorem pullback_rev_hom_pullback (h₁ : x ⟶ d₁) (h₂ : x ⟶ d₂) (p : f ∘ h₁ = g ∘ h₂)
|
||||
: pullback_rev f g ∘ hom_pullback h₁ h₂ p = h₁ :=
|
||||
hom_limit_commute (pullback_category_functor D f g) (pullback_category_ob.rec h₁ h₂ (g ∘ h₂)) _ TR
|
||||
|
||||
theorem eq_hom_pullback {h₁ : x ⟶ d₁} {h₂ : x ⟶ d₂} (p : f ∘ h₁ = g ∘ h₂)
|
||||
{k : x ⟶ pullback_object f g} (q : pullback f g ∘ k = h₂) (r : pullback_rev f g ∘ k = h₁)
|
||||
: k = hom_pullback h₁ h₂ p :=
|
||||
eq_hom_limit _ (pullback_category_ob.rec r q
|
||||
begin
|
||||
refine ap (λx, x ∘ k) (limit_commute (pullback_category_functor D f g) (inl f2))⁻¹ ⬝ _,
|
||||
refine !assoc⁻¹ ⬝ _,
|
||||
exact ap (λx, _ ∘ x) q
|
||||
end)
|
||||
|
||||
theorem pullback_cone_unique {h₁ : x ⟶ d₁} {h₂ : x ⟶ d₂} (p : f ∘ h₁ = g ∘ h₂)
|
||||
{k₁ : x ⟶ pullback_object f g} (q₁ : pullback f g ∘ k₁ = h₂) (r₁ : pullback_rev f g ∘ k₁ = h₁)
|
||||
{k₂ : x ⟶ pullback_object f g} (q₂ : pullback f g ∘ k₂ = h₂) (r₂ : pullback_rev f g ∘ k₂ = h₁)
|
||||
: k₁ = k₂ :=
|
||||
(eq_hom_pullback p q₁ r₁) ⬝ (eq_hom_pullback p q₂ r₂)⁻¹
|
||||
|
||||
variables (f g)
|
||||
definition pullback_object_iso_pullback_object [constructor] (H₁ H₂ : has_pullbacks D) :
|
||||
@pullback_object D H₁ _ _ _ f g ≅ @pullback_object D H₂ _ _ _ f g :=
|
||||
limit_object_iso_limit_object _ H₁ H₂
|
||||
|
||||
end pullbacks
|
||||
|
||||
namespace ops
|
||||
infixr ×l := product_object
|
||||
end ops
|
||||
|
||||
end category
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
algebra.category.limits
|
||||
=======================
|
||||
|
||||
* [limits](limits.hlean) : Limits in a category, defined as terminal object in the cone category
|
||||
* [colimits](colimits.hlean) : Colimits in a category, defined as the limit of the opposite functor
|
||||
* [functor_preserve](functor_preserve.hlean) : Functors which preserve limits and colimits
|
||||
* [adjoint](adjoint.hlean) : the (co)limit functor is adjoint to the diagonal map
|
||||
* [set](set.hlean) : set is a complete and cocomplete category
|
||||
* [functor](functor.hlean) : if `D` has (co)limits of a certain shape, then so has `D ^ C`
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
The category of sets is complete and cocomplete
|
||||
-/
|
||||
|
||||
import .colimits ..constructions.set hit.set_quotient
|
||||
|
||||
open eq functor is_trunc sigma pi sigma.ops trunc set_quotient
|
||||
|
||||
namespace category
|
||||
local attribute category.to_precategory [unfold 2]
|
||||
|
||||
definition is_complete_set_cone.{u v w} [constructor]
|
||||
(I : Precategory.{v w}) (F : I ⇒ set.{max u v w}) : cone_obj F :=
|
||||
begin
|
||||
fapply cone_obj.mk,
|
||||
{ fapply trunctype.mk,
|
||||
{ exact Σ(s : Π(i : I), trunctype.carrier (F i)),
|
||||
Π{i j : I} (f : i ⟶ j), F f (s i) = (s j)},
|
||||
{ with_options [elaborator.ignore_instances true] -- TODO: fix
|
||||
( refine is_trunc_sigma _ _;
|
||||
( apply is_trunc_pi);
|
||||
( intro s;
|
||||
refine is_trunc_pi _ _; intro i;
|
||||
refine is_trunc_pi _ _; intro j;
|
||||
refine is_trunc_pi _ _; intro f;
|
||||
apply is_trunc_eq))}},
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro i x, esimp at x, exact x.1 i},
|
||||
{ intro i j f, esimp, apply eq_of_homotopy, intro x, esimp at x, induction x with s p,
|
||||
esimp, apply p}}
|
||||
end
|
||||
|
||||
definition is_complete_set.{u v w} [instance] : is_complete.{(max u v w)+1 (max u v w) v w} set :=
|
||||
begin
|
||||
intro I F, fapply has_terminal_object.mk,
|
||||
{ exact is_complete_set_cone.{u v w} I F},
|
||||
{ intro c, esimp at *, induction c with X η, induction η with η p, esimp at *,
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ intro x, esimp at *, fapply sigma.mk,
|
||||
{ intro i, exact η i x},
|
||||
{ intro i j f, exact ap10 (p f) x}},
|
||||
{ intro i, reflexivity}},
|
||||
{ esimp, intro h, induction h with f q, apply cone_hom_eq, esimp at *,
|
||||
apply eq_of_homotopy, intro x, fapply sigma_eq: esimp,
|
||||
{ apply eq_of_homotopy, intro i, exact (ap10 (q i) x)⁻¹},
|
||||
{ with_options [elaborator.ignore_instances true] -- TODO: fix
|
||||
( refine is_prop.elimo _ _ _;
|
||||
refine is_trunc_pi _ _; intro i;
|
||||
refine is_trunc_pi _ _; intro j;
|
||||
refine is_trunc_pi _ _; intro f;
|
||||
apply is_trunc_eq)}}}
|
||||
end
|
||||
|
||||
definition is_cocomplete_set_cone_rel.{u v w} [unfold 3 4]
|
||||
(I : Precategory.{v w}) (F : I ⇒ set.{max u v w}ᵒᵖ) : (Σ(i : I), trunctype.carrier (F i)) →
|
||||
(Σ(i : I), trunctype.carrier (F i)) → Prop.{max u v w} :=
|
||||
begin
|
||||
intro v w, induction v with i x, induction w with j y,
|
||||
fapply trunctype.mk,
|
||||
{ exact ∃(f : i ⟶ j), to_fun_hom F f y = x},
|
||||
{ exact _}
|
||||
end
|
||||
|
||||
|
||||
definition is_cocomplete_set_cone.{u v w} [constructor]
|
||||
(I : Precategory.{v w}) (F : I ⇒ set.{max u v w}ᵒᵖ) : cone_obj F :=
|
||||
begin
|
||||
fapply cone_obj.mk,
|
||||
{ fapply trunctype.mk,
|
||||
{ apply set_quotient (is_cocomplete_set_cone_rel.{u v w} I F)},
|
||||
{ apply is_set_set_quotient}},
|
||||
{ fapply nat_trans.mk,
|
||||
{ intro i x, esimp, apply class_of, exact ⟨i, x⟩},
|
||||
{ intro i j f, esimp, apply eq_of_homotopy, intro y, apply eq_of_rel, esimp,
|
||||
exact exists.intro f idp}}
|
||||
end
|
||||
|
||||
-- TODO: change this after induction tactic for trunc/set_quotient is implemented
|
||||
definition is_cocomplete_set.{u v w} [instance]
|
||||
: is_cocomplete.{(max u v w)+1 (max u v w) v w} set :=
|
||||
begin
|
||||
intro I F, fapply has_terminal_object.mk,
|
||||
{ exact is_cocomplete_set_cone.{u v w} I F},
|
||||
{ intro c, esimp at *, induction c with X η, induction η with η p, esimp at *,
|
||||
fapply is_contr.mk,
|
||||
{ fapply cone_hom.mk,
|
||||
{ refine set_quotient.elim _ _,
|
||||
{ intro v, induction v with i x, exact η i x},
|
||||
{ intro v w r, induction v with i x, induction w with j y, esimp at *,
|
||||
refine trunc.elim_on r _, clear r,
|
||||
intro u, induction u with f q,
|
||||
exact ap (η i) q⁻¹ ⬝ ap10 (p f) y}},
|
||||
{ intro i, reflexivity}},
|
||||
{ esimp, intro h, induction h with f q, apply cone_hom_eq, esimp at *,
|
||||
apply eq_of_homotopy, refine set_quotient.rec _ _,
|
||||
{ intro v, induction v with i x, esimp, exact (ap10 (q i) x)⁻¹},
|
||||
{ intro v w r, apply is_prop.elimo}}},
|
||||
end
|
||||
|
||||
end category
|
||||
|
|
@ -1,197 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn, Jakob von Raumer
|
||||
-/
|
||||
|
||||
import .functor.basic
|
||||
open eq category functor is_trunc equiv sigma.ops sigma is_equiv function pi funext iso
|
||||
|
||||
structure nat_trans {C : Precategory} {D : Precategory} (F G : C ⇒ D)
|
||||
: Type :=
|
||||
(natural_map : Π (a : C), hom (F a) (G a))
|
||||
(naturality : Π {a b : C} (f : hom a b), G f ∘ natural_map a = natural_map b ∘ F f)
|
||||
|
||||
namespace nat_trans
|
||||
|
||||
infixl ` ⟹ `:25 := nat_trans -- \==>
|
||||
variables {B C D E : Precategory} {F G H I : C ⇒ D} {F' G' : D ⇒ E} {F'' G'' : E ⇒ B} {J : C ⇒ C}
|
||||
|
||||
attribute natural_map [coercion]
|
||||
|
||||
protected definition compose [constructor] (η : G ⟹ H) (θ : F ⟹ G) : F ⟹ H :=
|
||||
nat_trans.mk
|
||||
(λ a, η a ∘ θ a)
|
||||
(λ a b f,
|
||||
abstract calc
|
||||
H f ∘ (η a ∘ θ a) = (H f ∘ η a) ∘ θ a : by rewrite assoc
|
||||
... = (η b ∘ G f) ∘ θ a : by rewrite naturality
|
||||
... = η b ∘ (G f ∘ θ a) : by rewrite assoc
|
||||
... = η b ∘ (θ b ∘ F f) : by rewrite naturality
|
||||
... = (η b ∘ θ b) ∘ F f : by rewrite assoc
|
||||
end)
|
||||
|
||||
infixr ` ∘n `:60 := nat_trans.compose
|
||||
|
||||
definition compose_def (η : G ⟹ H) (θ : F ⟹ G) (c : C) : (η ∘n θ) c = η c ∘ θ c := idp
|
||||
|
||||
protected definition id [reducible] [constructor] {F : C ⇒ D} : nat_trans F F :=
|
||||
mk (λa, id) (λa b f, !id_right ⬝ !id_left⁻¹)
|
||||
|
||||
protected definition ID [reducible] [constructor] (F : C ⇒ D) : nat_trans F F :=
|
||||
(@nat_trans.id C D F)
|
||||
|
||||
notation 1 := nat_trans.id
|
||||
|
||||
definition constant_nat_trans [constructor] (C : Precategory) {D : Precategory} {d d' : D}
|
||||
(g : d ⟶ d') : constant_functor C d ⟹ constant_functor C d' :=
|
||||
mk (λc, g) (λc c' f, !id_comp_eq_comp_id)
|
||||
|
||||
open iso
|
||||
definition naturality_iso_left (η : F ⟹ G) {a b : C} (f : a ≅ b) : η a = (G f)⁻¹ ∘ η b ∘ F f :=
|
||||
by apply eq_inverse_comp_of_comp_eq; apply naturality
|
||||
|
||||
definition naturality_iso_right (η : F ⟹ G) {a b : C} (f : a ≅ b) : η b = G f ∘ η a ∘ (F f)⁻¹ :=
|
||||
by refine _⁻¹ ⬝ !assoc⁻¹; apply comp_inverse_eq_of_eq_comp; apply naturality
|
||||
|
||||
definition nat_trans_mk_eq {η₁ η₂ : Π (a : C), hom (F a) (G a)}
|
||||
(nat₁ : Π (a b : C) (f : hom a b), G f ∘ η₁ a = η₁ b ∘ F f)
|
||||
(nat₂ : Π (a b : C) (f : hom a b), G f ∘ η₂ a = η₂ b ∘ F f)
|
||||
(p : η₁ ~ η₂)
|
||||
: nat_trans.mk η₁ nat₁ = nat_trans.mk η₂ nat₂ :=
|
||||
apd011 nat_trans.mk (eq_of_homotopy p) !is_prop.elimo
|
||||
|
||||
definition nat_trans_eq {η₁ η₂ : F ⟹ G} : natural_map η₁ ~ natural_map η₂ → η₁ = η₂ :=
|
||||
by induction η₁; induction η₂; apply nat_trans_mk_eq
|
||||
|
||||
protected definition assoc (η₃ : H ⟹ I) (η₂ : G ⟹ H) (η₁ : F ⟹ G) :
|
||||
η₃ ∘n (η₂ ∘n η₁) = (η₃ ∘n η₂) ∘n η₁ :=
|
||||
nat_trans_eq (λa, !assoc)
|
||||
|
||||
protected definition id_left (η : F ⟹ G) : 1 ∘n η = η :=
|
||||
nat_trans_eq (λa, !id_left)
|
||||
|
||||
protected definition id_right (η : F ⟹ G) : η ∘n 1 = η :=
|
||||
nat_trans_eq (λa, !id_right)
|
||||
|
||||
protected definition sigma_char (F G : C ⇒ D) :
|
||||
(Σ (η : Π (a : C), hom (F a) (G a)), Π (a b : C) (f : hom a b), G f ∘ η a = η b ∘ F f) ≃ (F ⟹ G) :=
|
||||
begin
|
||||
fapply equiv.mk,
|
||||
-- TODO(Leo): investigate why we need to use rexact in the following line
|
||||
{intro S, apply nat_trans.mk, rexact (S.2)},
|
||||
fapply adjointify,
|
||||
intro H,
|
||||
fapply sigma.mk,
|
||||
intro a, exact (H a),
|
||||
intro a b f, exact (naturality H f),
|
||||
intro η, apply nat_trans_eq, intro a, apply idp,
|
||||
intro S,
|
||||
fapply sigma_eq,
|
||||
{ apply eq_of_homotopy, intro a, apply idp},
|
||||
{ apply is_prop.elimo}
|
||||
end
|
||||
|
||||
definition is_set_nat_trans [instance] : is_set (F ⟹ G) :=
|
||||
by apply is_trunc_is_equiv_closed; apply (equiv.to_is_equiv !nat_trans.sigma_char)
|
||||
|
||||
definition change_natural_map [constructor] (η : F ⟹ G) (f : Π (a : C), F a ⟶ G a)
|
||||
(p : Πa, η a = f a) : F ⟹ G :=
|
||||
nat_trans.mk f (λa b g, p a ▸ p b ▸ naturality η g)
|
||||
|
||||
definition nat_trans_functor_compose [constructor] (η : G ⟹ H) (F : E ⇒ C)
|
||||
: G ∘f F ⟹ H ∘f F :=
|
||||
nat_trans.mk
|
||||
(λ a, η (F a))
|
||||
(λ a b f, naturality η (F f))
|
||||
|
||||
definition functor_nat_trans_compose [constructor] (F : D ⇒ E) (η : G ⟹ H)
|
||||
: F ∘f G ⟹ F ∘f H :=
|
||||
nat_trans.mk
|
||||
(λ a, F (η a))
|
||||
(λ a b f, calc
|
||||
F (H f) ∘ F (η a) = F (H f ∘ η a) : by rewrite respect_comp
|
||||
... = F (η b ∘ G f) : by rewrite (naturality η f)
|
||||
... = F (η b) ∘ F (G f) : by rewrite respect_comp)
|
||||
|
||||
definition nat_trans_id_functor_compose [constructor] (η : J ⟹ 1) (F : E ⇒ C)
|
||||
: J ∘f F ⟹ F :=
|
||||
nat_trans.mk
|
||||
(λ a, η (F a))
|
||||
(λ a b f, naturality η (F f))
|
||||
|
||||
definition id_nat_trans_functor_compose [constructor] (η : 1 ⟹ J) (F : E ⇒ C)
|
||||
: F ⟹ J ∘f F :=
|
||||
nat_trans.mk
|
||||
(λ a, η (F a))
|
||||
(λ a b f, naturality η (F f))
|
||||
|
||||
definition functor_nat_trans_id_compose [constructor] (F : C ⇒ D) (η : J ⟹ 1)
|
||||
: F ∘f J ⟹ F :=
|
||||
nat_trans.mk
|
||||
(λ a, F (η a))
|
||||
(λ a b f, calc
|
||||
F f ∘ F (η a) = F (f ∘ η a) : by rewrite respect_comp
|
||||
... = F (η b ∘ J f) : by rewrite (naturality η f)
|
||||
... = F (η b) ∘ F (J f) : by rewrite respect_comp)
|
||||
|
||||
definition functor_id_nat_trans_compose [constructor] (F : C ⇒ D) (η : 1 ⟹ J)
|
||||
: F ⟹ F ∘f J :=
|
||||
nat_trans.mk
|
||||
(λ a, F (η a))
|
||||
(λ a b f, calc
|
||||
F (J f) ∘ F (η a) = F (J f ∘ η a) : by rewrite respect_comp
|
||||
... = F (η b ∘ f) : by rewrite (naturality η f)
|
||||
... = F (η b) ∘ F f : by rewrite respect_comp)
|
||||
|
||||
infixr ` ∘nf ` :62 := nat_trans_functor_compose
|
||||
infixr ` ∘fn ` :62 := functor_nat_trans_compose
|
||||
infixr ` ∘n1f `:62 := nat_trans_id_functor_compose
|
||||
infixr ` ∘1nf `:62 := id_nat_trans_functor_compose
|
||||
infixr ` ∘f1n `:62 := functor_id_nat_trans_compose
|
||||
infixr ` ∘fn1 `:62 := functor_nat_trans_id_compose
|
||||
|
||||
definition nf_fn_eq_fn_nf_pt (η : F ⟹ G) (θ : F' ⟹ G') (c : C)
|
||||
: (θ (G c)) ∘ (F' (η c)) = (G' (η c)) ∘ (θ (F c)) :=
|
||||
(naturality θ (η c))⁻¹
|
||||
|
||||
variable (F')
|
||||
definition nf_fn_eq_fn_nf_pt' (η : F ⟹ G) (θ : F'' ⟹ G'') (c : C)
|
||||
: (θ (F' (G c))) ∘ (F'' (F' (η c))) = (G'' (F' (η c))) ∘ (θ (F' (F c))) :=
|
||||
(naturality θ (F' (η c)))⁻¹
|
||||
variable {F'}
|
||||
|
||||
definition nf_fn_eq_fn_nf (η : F ⟹ G) (θ : F' ⟹ G')
|
||||
: (θ ∘nf G) ∘n (F' ∘fn η) = (G' ∘fn η) ∘n (θ ∘nf F) :=
|
||||
nat_trans_eq (λ c, nf_fn_eq_fn_nf_pt η θ c)
|
||||
|
||||
definition fn_n_distrib (F' : D ⇒ E) (η : G ⟹ H) (θ : F ⟹ G)
|
||||
: F' ∘fn (η ∘n θ) = (F' ∘fn η) ∘n (F' ∘fn θ) :=
|
||||
nat_trans_eq (λc, by apply respect_comp)
|
||||
|
||||
definition n_nf_distrib (η : G ⟹ H) (θ : F ⟹ G) (F' : B ⇒ C)
|
||||
: (η ∘n θ) ∘nf F' = (η ∘nf F') ∘n (θ ∘nf F') :=
|
||||
nat_trans_eq (λc, idp)
|
||||
|
||||
definition fn_id (F' : D ⇒ E) : F' ∘fn nat_trans.ID F = 1 :=
|
||||
nat_trans_eq (λc, by apply respect_id)
|
||||
|
||||
definition id_nf (F' : B ⇒ C) : nat_trans.ID F ∘nf F' = 1 :=
|
||||
nat_trans_eq (λc, idp)
|
||||
|
||||
definition id_fn (η : G ⟹ H) (c : C) : (1 ∘fn η) c = η c :=
|
||||
idp
|
||||
|
||||
definition nf_id (η : G ⟹ H) (c : C) : (η ∘nf 1) c = η c :=
|
||||
idp
|
||||
|
||||
definition nat_trans_of_eq [reducible] [constructor] (p : F = G) : F ⟹ G :=
|
||||
nat_trans.mk (λc, hom_of_eq (ap010 to_fun_ob p c))
|
||||
(λa b f, eq.rec_on p (!id_right ⬝ !id_left⁻¹))
|
||||
|
||||
definition compose_rev [unfold_full] (θ : F ⟹ G) (η : G ⟹ H) : F ⟹ H := η ∘n θ
|
||||
|
||||
end nat_trans
|
||||
|
||||
attribute nat_trans.compose_rev [trans]
|
||||
attribute nat_trans.id [refl]
|
||||
|
|
@ -1,294 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
import types.trunc types.pi arity
|
||||
|
||||
open eq is_trunc pi equiv
|
||||
|
||||
namespace category
|
||||
|
||||
/-
|
||||
Just as in Coq-HoTT we add two redundant fields to precategories: assoc' and id_id.
|
||||
The first is to make (Cᵒᵖ)ᵒᵖ = C definitionally when C is a constructor.
|
||||
The second is to ensure that the functor from the terminal category 1 ⇒ Cᵒᵖ is
|
||||
opposite to the functor 1 ⇒ C.
|
||||
-/
|
||||
|
||||
structure precategory [class] (ob : Type) : Type :=
|
||||
mk' ::
|
||||
(hom : ob → ob → Type)
|
||||
(comp : Π⦃a b c : ob⦄, hom b c → hom a b → hom a c)
|
||||
(ID : Π (a : ob), hom a a)
|
||||
(assoc : Π ⦃a b c d : ob⦄ (h : hom c d) (g : hom b c) (f : hom a b),
|
||||
comp h (comp g f) = comp (comp h g) f)
|
||||
(assoc' : Π ⦃a b c d : ob⦄ (h : hom c d) (g : hom b c) (f : hom a b),
|
||||
comp (comp h g) f = comp h (comp g f))
|
||||
(id_left : Π ⦃a b : ob⦄ (f : hom a b), comp !ID f = f)
|
||||
(id_right : Π ⦃a b : ob⦄ (f : hom a b), comp f !ID = f)
|
||||
(id_id : Π (a : ob), comp !ID !ID = ID a)
|
||||
(is_set_hom : Π(a b : ob), is_set (hom a b))
|
||||
|
||||
attribute precategory.is_set_hom [instance]
|
||||
|
||||
infixr ∘ := precategory.comp
|
||||
-- input ⟶ using \--> (this is a different arrow than \-> (→))
|
||||
infixl [parsing_only] ` ⟶ `:60 := precategory.hom
|
||||
namespace hom
|
||||
infixl ` ⟶ `:60 := precategory.hom -- if you open this namespace, hom a b is printed as a ⟶ b
|
||||
end hom
|
||||
|
||||
abbreviation hom [unfold 2] := @precategory.hom
|
||||
abbreviation comp [unfold 2] := @precategory.comp
|
||||
abbreviation ID [unfold 2] := @precategory.ID
|
||||
abbreviation assoc [unfold 2] := @precategory.assoc
|
||||
abbreviation assoc' [unfold 2] := @precategory.assoc'
|
||||
abbreviation id_left [unfold 2] := @precategory.id_left
|
||||
abbreviation id_right [unfold 2] := @precategory.id_right
|
||||
abbreviation id_id [unfold 2] := @precategory.id_id
|
||||
abbreviation is_set_hom [unfold 2] := @precategory.is_set_hom
|
||||
|
||||
definition is_prop_hom_eq {ob : Type} [C : precategory ob] {x y : ob} (f g : x ⟶ y)
|
||||
: is_prop (f = g) :=
|
||||
_
|
||||
|
||||
-- the constructor you want to use in practice
|
||||
protected definition precategory.mk [constructor] {ob : Type} (hom : ob → ob → Type)
|
||||
[set : Π (a b : ob), is_set (hom a b)]
|
||||
(comp : Π ⦃a b c : ob⦄, hom b c → hom a b → hom a c) (ID : Π (a : ob), hom a a)
|
||||
(ass : Π ⦃a b c d : ob⦄ (h : hom c d) (g : hom b c) (f : hom a b),
|
||||
comp h (comp g f) = comp (comp h g) f)
|
||||
(idl : Π ⦃a b : ob⦄ (f : hom a b), comp (ID b) f = f)
|
||||
(idr : Π ⦃a b : ob⦄ (f : hom a b), comp f (ID a) = f) : precategory ob :=
|
||||
precategory.mk' hom comp ID ass (λa b c d h g f, !ass⁻¹) idl idr (λa, !idl) set
|
||||
|
||||
section basic_lemmas
|
||||
variables {ob : Type} [C : precategory ob]
|
||||
variables {a b c d : ob} {h : c ⟶ d} {g : hom b c} {f f' : hom a b} {i : a ⟶ a}
|
||||
include C
|
||||
|
||||
definition id [reducible] [unfold 2] := ID a
|
||||
|
||||
definition id_leftright (f : hom a b) : id ∘ f ∘ id = f := !id_left ⬝ !id_right
|
||||
definition comp_id_eq_id_comp (f : hom a b) : f ∘ id = id ∘ f := !id_right ⬝ !id_left⁻¹
|
||||
definition id_comp_eq_comp_id (f : hom a b) : id ∘ f = f ∘ id := !id_left ⬝ !id_right⁻¹
|
||||
|
||||
definition hom_whisker_left (g : b ⟶ c) (p : f = f') : g ∘ f = g ∘ f' :=
|
||||
ap (λx, g ∘ x) p
|
||||
|
||||
definition hom_whisker_right (g : c ⟶ a) (p : f = f') : f ∘ g = f' ∘ g :=
|
||||
ap (λx, x ∘ g) p
|
||||
|
||||
/- many variants of hom_pathover are defined in .iso and .functor.basic -/
|
||||
|
||||
definition left_id_unique (H : Π{b} {f : hom b a}, i ∘ f = f) : i = id :=
|
||||
calc i = i ∘ id : by rewrite id_right
|
||||
... = id : by rewrite H
|
||||
|
||||
definition right_id_unique (H : Π{b} {f : hom a b}, f ∘ i = f) : i = id :=
|
||||
calc i = id ∘ i : by rewrite id_left
|
||||
... = id : by rewrite H
|
||||
|
||||
definition homset [reducible] [constructor] (x y : ob) : Set :=
|
||||
Set.mk (hom x y) _
|
||||
|
||||
end basic_lemmas
|
||||
section squares
|
||||
parameters {ob : Type} [C : precategory ob]
|
||||
local infixl ` ⟶ `:25 := @precategory.hom ob C
|
||||
local infixr ∘ := @precategory.comp ob C _ _ _
|
||||
definition compose_squares {xa xb xc ya yb yc : ob}
|
||||
{xg : xb ⟶ xc} {xf : xa ⟶ xb} {yg : yb ⟶ yc} {yf : ya ⟶ yb}
|
||||
{wa : xa ⟶ ya} {wb : xb ⟶ yb} {wc : xc ⟶ yc}
|
||||
(xyab : wb ∘ xf = yf ∘ wa) (xybc : wc ∘ xg = yg ∘ wb)
|
||||
: wc ∘ (xg ∘ xf) = (yg ∘ yf) ∘ wa :=
|
||||
calc
|
||||
wc ∘ (xg ∘ xf) = (wc ∘ xg) ∘ xf : by rewrite assoc
|
||||
... = (yg ∘ wb) ∘ xf : by rewrite xybc
|
||||
... = yg ∘ (wb ∘ xf) : by rewrite assoc
|
||||
... = yg ∘ (yf ∘ wa) : by rewrite xyab
|
||||
... = (yg ∘ yf) ∘ wa : by rewrite assoc
|
||||
|
||||
definition compose_squares_2x2 {xa xb xc ya yb yc za zb zc : ob}
|
||||
{xg : xb ⟶ xc} {xf : xa ⟶ xb} {yg : yb ⟶ yc} {yf : ya ⟶ yb} {zg : zb ⟶ zc} {zf : za ⟶ zb}
|
||||
{va : ya ⟶ za} {vb : yb ⟶ zb} {vc : yc ⟶ zc} {wa : xa ⟶ ya} {wb : xb ⟶ yb} {wc : xc ⟶ yc}
|
||||
(xyab : wb ∘ xf = yf ∘ wa) (xybc : wc ∘ xg = yg ∘ wb)
|
||||
(yzab : vb ∘ yf = zf ∘ va) (yzbc : vc ∘ yg = zg ∘ vb)
|
||||
: (vc ∘ wc) ∘ (xg ∘ xf) = (zg ∘ zf) ∘ (va ∘ wa) :=
|
||||
calc
|
||||
(vc ∘ wc) ∘ (xg ∘ xf) = vc ∘ (wc ∘ (xg ∘ xf)) : by rewrite (assoc vc wc _)
|
||||
... = vc ∘ ((yg ∘ yf) ∘ wa) : by rewrite (compose_squares xyab xybc)
|
||||
... = (vc ∘ (yg ∘ yf)) ∘ wa : by rewrite assoc
|
||||
... = ((zg ∘ zf) ∘ va) ∘ wa : by rewrite (compose_squares yzab yzbc)
|
||||
... = (zg ∘ zf) ∘ (va ∘ wa) : by rewrite assoc
|
||||
|
||||
definition square_precompose {xa xb xc yb yc : ob}
|
||||
{xg : xb ⟶ xc} {yg : yb ⟶ yc} {wb : xb ⟶ yb} {wc : xc ⟶ yc}
|
||||
(H : wc ∘ xg = yg ∘ wb) (xf : xa ⟶ xb) : wc ∘ xg ∘ xf = yg ∘ wb ∘ xf :=
|
||||
calc
|
||||
wc ∘ xg ∘ xf = (wc ∘ xg) ∘ xf : by rewrite assoc
|
||||
... = (yg ∘ wb) ∘ xf : by rewrite H
|
||||
... = yg ∘ wb ∘ xf : by rewrite assoc
|
||||
|
||||
definition square_postcompose {xb xc yb yc yd : ob}
|
||||
{xg : xb ⟶ xc} {yg : yb ⟶ yc} {wb : xb ⟶ yb} {wc : xc ⟶ yc}
|
||||
(H : wc ∘ xg = yg ∘ wb) (yh : yc ⟶ yd) : (yh ∘ wc) ∘ xg = (yh ∘ yg) ∘ wb :=
|
||||
calc
|
||||
(yh ∘ wc) ∘ xg = yh ∘ wc ∘ xg : by rewrite assoc
|
||||
... = yh ∘ yg ∘ wb : by rewrite H
|
||||
... = (yh ∘ yg) ∘ wb : by rewrite assoc
|
||||
|
||||
definition square_prepostcompose {xa xb xc yb yc yd : ob}
|
||||
{xg : xb ⟶ xc} {yg : yb ⟶ yc} {wb : xb ⟶ yb} {wc : xc ⟶ yc}
|
||||
(H : wc ∘ xg = yg ∘ wb) (yh : yc ⟶ yd) (xf : xa ⟶ xb)
|
||||
: (yh ∘ wc) ∘ (xg ∘ xf) = (yh ∘ yg) ∘ (wb ∘ xf) :=
|
||||
square_precompose (square_postcompose H yh) xf
|
||||
end squares
|
||||
|
||||
structure Precategory : Type :=
|
||||
(carrier : Type)
|
||||
(struct : precategory carrier)
|
||||
|
||||
definition precategory.Mk [reducible] [constructor] {ob} (C) : Precategory := Precategory.mk ob C
|
||||
definition precategory.MK [reducible] [constructor] (a b c d e f g h) : Precategory :=
|
||||
Precategory.mk a (@precategory.mk a b c d e f g h)
|
||||
|
||||
abbreviation carrier [unfold 1] := @Precategory.carrier
|
||||
|
||||
attribute Precategory.carrier [coercion]
|
||||
attribute Precategory.struct [instance] [priority 10000] [coercion]
|
||||
-- definition precategory.carrier [coercion] [reducible] := Precategory.carrier
|
||||
-- definition precategory.struct [instance] [coercion] := Precategory.struct
|
||||
notation g ` ∘[`:60 C:0 `] `:0 f:60 :=
|
||||
@comp (Precategory.carrier C) (Precategory.struct C) _ _ _ g f
|
||||
-- TODO: make this left associative
|
||||
|
||||
definition Precategory.eta (C : Precategory) : Precategory.mk C C = C :=
|
||||
Precategory.rec (λob c, idp) C
|
||||
|
||||
/-Characterization of paths between precategories-/
|
||||
-- introduction tule for paths between precategories
|
||||
|
||||
definition precategory_eq {ob : Type}
|
||||
{C D : precategory ob}
|
||||
(p : Π{a b}, @hom ob C a b = @hom ob D a b)
|
||||
(q : Πa b c g f, cast p (@comp ob C a b c g f) = @comp ob D a b c (cast p g) (cast p f))
|
||||
: C = D :=
|
||||
begin
|
||||
induction C with hom1 comp1 ID1 a b il ir, induction D with hom2 comp2 ID2 a' b' il' ir',
|
||||
esimp at *,
|
||||
revert q, eapply homotopy2.rec_on @p, esimp, clear p, intro p q, induction p,
|
||||
esimp at *,
|
||||
have H : comp1 = comp2,
|
||||
begin apply eq_of_homotopy3, intros, apply eq_of_homotopy2, intros, apply q end,
|
||||
induction H,
|
||||
have K : ID1 = ID2,
|
||||
begin apply eq_of_homotopy, intro a, exact !ir'⁻¹ ⬝ !il end,
|
||||
induction K,
|
||||
apply ap0111111 (precategory.mk' hom1 comp1 ID1): apply is_prop.elim
|
||||
end
|
||||
|
||||
|
||||
definition precategory_eq_of_equiv {ob : Type}
|
||||
{C D : precategory ob}
|
||||
(p : Π⦃a b⦄, @hom ob C a b ≃ @hom ob D a b)
|
||||
(q : Π{a b c} g f, p (@comp ob C a b c g f) = @comp ob D a b c (p g) (p f))
|
||||
: C = D :=
|
||||
begin
|
||||
fapply precategory_eq,
|
||||
{ intro a b, exact ua !@p},
|
||||
{ intros, refine !cast_ua ⬝ !q ⬝ _, apply ap011 !@comp !cast_ua⁻¹ !cast_ua⁻¹},
|
||||
end
|
||||
|
||||
/- if we need to prove properties about precategory_eq, it might be easier with the following proof:
|
||||
begin
|
||||
induction C with hom1 comp1 ID1, induction D with hom2 comp2 ID2, esimp at *,
|
||||
have H : Σ(s : hom1 = hom2), (λa b, equiv_of_eq (apd100 s a b)) = p,
|
||||
begin
|
||||
fconstructor,
|
||||
{ apply eq_of_homotopy2, intros, apply ua, apply p},
|
||||
{ apply eq_of_homotopy2, intros, rewrite [to_right_inv !eq_equiv_homotopy2, equiv_of_eq_ua]}
|
||||
end,
|
||||
induction H with H1 H2, induction H1, esimp at H2,
|
||||
have K : (λa b, equiv.refl) = p,
|
||||
begin refine _ ⬝ H2, apply eq_of_homotopy2, intros, exact !equiv_of_eq_refl⁻¹ end,
|
||||
induction K, clear H2,
|
||||
esimp at *,
|
||||
have H : comp1 = comp2,
|
||||
begin apply eq_of_homotopy3, intros, apply eq_of_homotopy2, intros, apply q end,
|
||||
have K : ID1 = ID2,
|
||||
begin apply eq_of_homotopy, intros, apply r end,
|
||||
induction H, induction K,
|
||||
apply ap0111111 (precategory.mk' hom1 comp1 ID1): apply is_prop.elim
|
||||
end
|
||||
-/
|
||||
|
||||
definition Precategory_eq {C D : Precategory}
|
||||
(p : carrier C = carrier D)
|
||||
(q : Π{a b : C}, a ⟶ b = cast p a ⟶ cast p b)
|
||||
(r : Π{a b c : C} (g : b ⟶ c) (f : a ⟶ b), cast q (g ∘ f) = cast q g ∘ cast q f)
|
||||
: C = D :=
|
||||
begin
|
||||
induction C with X C, induction D with Y D, esimp at *, induction p,
|
||||
esimp at *,
|
||||
apply ap (Precategory.mk X),
|
||||
apply precategory_eq @q @r
|
||||
end
|
||||
|
||||
definition Precategory_eq_of_equiv {C D : Precategory}
|
||||
(p : carrier C ≃ carrier D)
|
||||
(q : Π⦃a b : C⦄, a ⟶ b ≃ p a ⟶ p b)
|
||||
(r : Π{a b c : C} (g : b ⟶ c) (f : a ⟶ b), q (g ∘ f) = q g ∘ q f)
|
||||
: C = D :=
|
||||
begin
|
||||
induction C with X C, induction D with Y D, esimp at *,
|
||||
revert q r, eapply equiv.rec_on_ua p, clear p, intro p, induction p, esimp,
|
||||
intros,
|
||||
apply ap (Precategory.mk X),
|
||||
apply precategory_eq_of_equiv @q @r
|
||||
end
|
||||
|
||||
-- elimination rules for paths between precategories.
|
||||
-- The first elimination rule is "ap carrier"
|
||||
|
||||
definition Precategory_eq_hom [unfold 3] {C D : Precategory} (p : C = D) (a b : C)
|
||||
: hom a b = hom (cast (ap carrier p) a) (cast (ap carrier p) b) :=
|
||||
by induction p; reflexivity
|
||||
--(ap10 (ap10 (apdt (λx, @hom (carrier x) (Precategory.struct x)) p⁻¹ᵖ) a) b)⁻¹ᵖ ⬝ _
|
||||
|
||||
|
||||
-- beta/eta rules
|
||||
definition ap_Precategory_eq' {C D : Precategory}
|
||||
(p : carrier C = carrier D)
|
||||
(q : Π{a b : C}, a ⟶ b = cast p a ⟶ cast p b)
|
||||
(r : Π{a b c : C} (g : b ⟶ c) (f : a ⟶ b), cast q (g ∘ f) = cast q g ∘ cast q f)
|
||||
(s : Πa, cast q (ID a) = ID (cast p a)) : ap carrier (Precategory_eq p @q @r) = p :=
|
||||
begin
|
||||
induction C with X C, induction D with Y D, esimp at *, induction p,
|
||||
rewrite [↑Precategory_eq, -ap_compose,↑function.compose,ap_constant]
|
||||
end
|
||||
|
||||
/-
|
||||
theorem Precategory_eq'_eta {C D : Precategory} (p : C = D) :
|
||||
Precategory_eq
|
||||
(ap carrier p)
|
||||
(Precategory_eq_hom p)
|
||||
(by induction p; intros; reflexivity) = p :=
|
||||
begin
|
||||
induction p, induction C with X C, unfold Precategory_eq,
|
||||
induction C, unfold precategory_eq, exact sorry
|
||||
end
|
||||
-/
|
||||
|
||||
/-
|
||||
theorem Precategory_eq2 {C D : Precategory} (p q : C = D)
|
||||
(r : ap carrier p = ap carrier q)
|
||||
(s : Precategory_eq_hom p =[r] Precategory_eq_hom q)
|
||||
: p = q :=
|
||||
begin
|
||||
|
||||
end
|
||||
-/
|
||||
|
||||
end category
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
-/
|
||||
|
||||
import .functor.basic
|
||||
|
||||
open is_trunc eq
|
||||
|
||||
namespace category
|
||||
structure strict_precategory [class] (ob : Type) extends precategory ob :=
|
||||
mk' :: (is_set_ob : is_set ob)
|
||||
|
||||
attribute strict_precategory.is_set_ob [instance]
|
||||
|
||||
definition strict_precategory.mk [reducible] {ob : Type} (C : precategory ob)
|
||||
(H : is_set ob) : strict_precategory ob :=
|
||||
precategory.rec_on C strict_precategory.mk' H
|
||||
|
||||
structure Strict_precategory : Type :=
|
||||
(carrier : Type)
|
||||
(struct : strict_precategory carrier)
|
||||
|
||||
attribute Strict_precategory.struct [instance] [coercion]
|
||||
|
||||
definition Strict_precategory.to_Precategory [coercion] [reducible]
|
||||
(C : Strict_precategory) : Precategory :=
|
||||
Precategory.mk (Strict_precategory.carrier C) _
|
||||
|
||||
open functor
|
||||
|
||||
-- TODO: move to constructions.cat?
|
||||
definition precategory_strict_precategory [constructor] : precategory Strict_precategory :=
|
||||
precategory.mk (λ A B, A ⇒ B)
|
||||
(λ A B C G F, G ∘f F)
|
||||
(λ A, 1)
|
||||
(λ A B C D, functor.assoc)
|
||||
(λ A B, functor.id_left)
|
||||
(λ A B, functor.id_right)
|
||||
|
||||
definition Precategory_strict_precategory [constructor] := precategory.Mk precategory_strict_precategory
|
||||
|
||||
namespace ops
|
||||
abbreviation Cat := Precategory_strict_precategory
|
||||
end ops
|
||||
|
||||
end category
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
|
@ -1,243 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
The "equivalence closure" of a type-valued relation.
|
||||
A more appropriate intuition is the type of words formed from the relation,
|
||||
and inverses, concatenations and reflexivity
|
||||
-/
|
||||
|
||||
import algebra.relation eq2 arity cubical.pathover2
|
||||
|
||||
open eq equiv function
|
||||
|
||||
inductive e_closure {A : Type} (R : A → A → Type) : A → A → Type :=
|
||||
| of_rel : Π{a a'} (r : R a a'), e_closure R a a'
|
||||
| of_path : Π{a a'} (pp : a = a'), e_closure R a a'
|
||||
| symm : Π{a a'} (r : e_closure R a a'), e_closure R a' a
|
||||
| trans : Π{a a' a''} (r : e_closure R a a') (r' : e_closure R a' a''), e_closure R a a''
|
||||
|
||||
namespace e_closure
|
||||
infix ` ⬝r `:75 := e_closure.trans
|
||||
postfix `⁻¹ʳ`:(max+10) := e_closure.symm
|
||||
notation `[`:max a `]`:0 := e_closure.of_rel a
|
||||
notation `<`:max p `>`:0 := e_closure.of_path _ p
|
||||
abbreviation rfl [constructor] {A : Type} {R : A → A → Type} {a : A} := of_path R (idpath a)
|
||||
end e_closure
|
||||
open e_closure
|
||||
namespace relation
|
||||
|
||||
section
|
||||
parameters {A : Type}
|
||||
{R : A → A → Type}
|
||||
local abbreviation T := e_closure R
|
||||
|
||||
variables ⦃a a' a'' : A⦄ {s : R a a'} {r : T a a} {B C : Type}
|
||||
|
||||
protected definition e_closure.elim [unfold 8] {f : A → B}
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') : f a = f a' :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
exact e r,
|
||||
exact ap f pp,
|
||||
exact IH⁻¹,
|
||||
exact IH₁ ⬝ IH₂
|
||||
end
|
||||
|
||||
definition ap_e_closure_elim_h [unfold 12] {B C : Type} {f : A → B} {g : B → C}
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
{e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
|
||||
: ap g (e_closure.elim e t) = e_closure.elim e' t :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
apply p,
|
||||
induction pp, reflexivity,
|
||||
exact ap_inv g (e_closure.elim e r) ⬝ inverse2 IH,
|
||||
exact ap_con g (e_closure.elim e r) (e_closure.elim e r') ⬝ (IH₁ ◾ IH₂)
|
||||
end
|
||||
|
||||
definition ap_e_closure_elim_h_symm [unfold_full] {B C : Type} {f : A → B} {g : B → C}
|
||||
{e : Π⦃a a' : A⦄, R a a' → f a = f a'}
|
||||
{e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a') :
|
||||
ap_e_closure_elim_h e p t⁻¹ʳ = ap_inv g (e_closure.elim e t) ⬝ (ap_e_closure_elim_h e p t)⁻² :=
|
||||
by reflexivity
|
||||
|
||||
definition ap_e_closure_elim_h_trans [unfold_full] {B C : Type} {f : A → B} {g : B → C}
|
||||
{e : Π⦃a a' : A⦄, R a a' → f a = f a'}
|
||||
{e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a') (t' : T a' a'')
|
||||
: ap_e_closure_elim_h e p (t ⬝r t') = ap_con g (e_closure.elim e t) (e_closure.elim e t') ⬝
|
||||
(ap_e_closure_elim_h e p t ◾ ap_e_closure_elim_h e p t') :=
|
||||
by reflexivity
|
||||
|
||||
definition ap_e_closure_elim [unfold 10] {B C : Type} {f : A → B} (g : B → C)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
|
||||
: ap g (e_closure.elim e t) = e_closure.elim (λa a' r, ap g (e r)) t :=
|
||||
ap_e_closure_elim_h e (λa a' s, idp) t
|
||||
|
||||
definition ap_e_closure_elim_symm [unfold_full] {B C : Type} {f : A → B} (g : B → C)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
|
||||
: ap_e_closure_elim g e t⁻¹ʳ = ap_inv g (e_closure.elim e t) ⬝ (ap_e_closure_elim g e t)⁻² :=
|
||||
by reflexivity
|
||||
|
||||
definition ap_e_closure_elim_trans [unfold_full] {B C : Type} {f : A → B} (g : B → C)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a') (t' : T a' a'')
|
||||
: ap_e_closure_elim g e (t ⬝r t') = ap_con g (e_closure.elim e t) (e_closure.elim e t') ⬝
|
||||
(ap_e_closure_elim g e t ◾ ap_e_closure_elim g e t') :=
|
||||
by reflexivity
|
||||
|
||||
definition e_closure_elim_eq [unfold 8] {f : A → B}
|
||||
{e e' : Π⦃a a' : A⦄, R a a' → f a = f a'} (p : e ~3 e') (t : T a a')
|
||||
: e_closure.elim e t = e_closure.elim e' t :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
apply p,
|
||||
reflexivity,
|
||||
exact IH⁻²,
|
||||
exact IH₁ ◾ IH₂
|
||||
end
|
||||
|
||||
-- TODO: formulate and prove this without using function extensionality,
|
||||
-- and modify the proofs using this to also not use function extensionality
|
||||
-- strategy: use `e_closure_elim_eq` instead of `ap ... (eq_of_homotopy3 p)`
|
||||
definition ap_e_closure_elim_h_eq {B C : Type} {f : A → B} {g : B → C}
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
{e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
|
||||
: ap_e_closure_elim_h e p t =
|
||||
ap_e_closure_elim g e t ⬝ ap (λx, e_closure.elim x t) (eq_of_homotopy3 p) :=
|
||||
begin
|
||||
fapply homotopy3.rec_on p,
|
||||
intro q, esimp at q, induction q,
|
||||
esimp, rewrite eq_of_homotopy3_id
|
||||
end
|
||||
|
||||
theorem ap_ap_e_closure_elim_h {B C D : Type} {f : A → B}
|
||||
{g : B → C} (h : C → D)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
{e' : Π⦃a a' : A⦄, R a a' → g (f a) = g (f a')}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap g (e s) = e' s) (t : T a a')
|
||||
: square (ap (ap h) (ap_e_closure_elim_h e p t))
|
||||
(ap_e_closure_elim_h e (λa a' s, ap_compose h g (e s)) t)
|
||||
(ap_compose h g (e_closure.elim e t))⁻¹
|
||||
(ap_e_closure_elim_h e' (λa a' s, (ap (ap h) (p s))⁻¹) t) :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
{ esimp,
|
||||
apply square_of_eq, exact !con.right_inv ⬝ !con.left_inv⁻¹},
|
||||
{ induction pp, apply ids},
|
||||
{ rewrite [▸*,ap_con (ap h)],
|
||||
refine (transpose !ap_compose_inv)⁻¹ᵛ ⬝h _,
|
||||
rewrite [con_inv,inv_inv,-inv2_inv],
|
||||
exact !ap_inv2 ⬝v square_inv2 IH},
|
||||
{ rewrite [▸*,ap_con (ap h)],
|
||||
refine (transpose !ap_compose_con)⁻¹ᵛ ⬝h _,
|
||||
rewrite [con_inv,inv_inv,con2_inv],
|
||||
refine !ap_con2 ⬝v square_con2 IH₁ IH₂},
|
||||
end
|
||||
|
||||
theorem ap_ap_e_closure_elim {B C D : Type} {f : A → B}
|
||||
(g : B → C) (h : C → D)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a') (t : T a a')
|
||||
: square (ap (ap h) (ap_e_closure_elim g e t))
|
||||
(ap_e_closure_elim_h e (λa a' s, ap_compose h g (e s)) t)
|
||||
(ap_compose h g (e_closure.elim e t))⁻¹
|
||||
(ap_e_closure_elim h (λa a' r, ap g (e r)) t) :=
|
||||
!ap_ap_e_closure_elim_h
|
||||
|
||||
definition ap_e_closure_elim_h_zigzag {B C D : Type} {f : A → B}
|
||||
{g : B → C} (h : C → D)
|
||||
(e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
{e' : Π⦃a a' : A⦄, R a a' → h (g (f a)) = h (g (f a'))}
|
||||
(p : Π⦃a a' : A⦄ (s : R a a'), ap (h ∘ g) (e s) = e' s) (t : T a a')
|
||||
: ap_e_closure_elim h (λa a' s, ap g (e s)) t ⬝
|
||||
(ap_e_closure_elim_h e (λa a' s, ap_compose h g (e s)) t)⁻¹ ⬝
|
||||
ap_e_closure_elim_h e p t =
|
||||
ap_e_closure_elim_h (λa a' s, ap g (e s)) (λa a' s, (ap_compose h g (e s))⁻¹ ⬝ p s) t :=
|
||||
begin
|
||||
refine whisker_right _ (eq_of_square (ap_ap_e_closure_elim g h e t)⁻¹ʰ)⁻¹ ⬝ _,
|
||||
refine !con.assoc ⬝ _, apply inv_con_eq_of_eq_con, apply eq_of_square,
|
||||
apply transpose,
|
||||
-- the rest of the proof is almost the same as the proof of ap_ap_e_closure_elim[_h].
|
||||
-- Is there a connection between these theorems?
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
{ esimp, apply square_of_eq, apply idp_con},
|
||||
{ induction pp, apply ids},
|
||||
{ rewrite [▸*,ap_con (ap h)],
|
||||
refine (transpose !ap_compose_inv)⁻¹ᵛ ⬝h _,
|
||||
rewrite [con_inv,inv_inv,-inv2_inv],
|
||||
exact !ap_inv2 ⬝v square_inv2 IH},
|
||||
{ rewrite [▸*,ap_con (ap h)],
|
||||
refine (transpose !ap_compose_con)⁻¹ᵛ ⬝h _,
|
||||
rewrite [con_inv,inv_inv,con2_inv],
|
||||
refine !ap_con2 ⬝v square_con2 IH₁ IH₂},
|
||||
|
||||
end
|
||||
|
||||
definition is_equivalence_e_closure : is_equivalence T :=
|
||||
begin
|
||||
constructor,
|
||||
intro a, exact rfl,
|
||||
intro a a' t, exact t⁻¹ʳ,
|
||||
intro a a' a'' t t', exact t ⬝r t',
|
||||
end
|
||||
|
||||
/- dependent elimination -/
|
||||
|
||||
variables {P : B → Type} {Q : C → Type} {f : A → B} {g : B → C} {f' : Π(a : A), P (f a)}
|
||||
protected definition e_closure.elimo [unfold 11] (p : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a')
|
||||
: f' a =[e_closure.elim p t] f' a' :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
exact po r,
|
||||
induction pp, constructor,
|
||||
exact IH⁻¹ᵒ,
|
||||
exact IH₁ ⬝o IH₂
|
||||
end
|
||||
|
||||
definition elimo_symm [unfold_full] (p : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a')
|
||||
: e_closure.elimo p po t⁻¹ʳ = (e_closure.elimo p po t)⁻¹ᵒ :=
|
||||
by reflexivity
|
||||
|
||||
definition elimo_trans [unfold_full] (p : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(po : Π⦃a a' : A⦄ (s : R a a'), f' a =[p s] f' a') (t : T a a') (t' : T a' a'')
|
||||
: e_closure.elimo p po (t ⬝r t') = e_closure.elimo p po t ⬝o e_closure.elimo p po t' :=
|
||||
by reflexivity
|
||||
|
||||
definition ap_e_closure_elimo_h [unfold 12] {g' : Πb, Q (g b)}
|
||||
(p : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(po : Π⦃a a' : A⦄ (s : R a a'), g' (f a) =[p s] g' (f a'))
|
||||
(q : Π⦃a a' : A⦄ (s : R a a'), apd g' (p s) = po s)
|
||||
(t : T a a') : apd g' (e_closure.elim p t) = e_closure.elimo p po t :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
apply q,
|
||||
induction pp, reflexivity,
|
||||
esimp [e_closure.elim],
|
||||
exact apd_inv g' (e_closure.elim p r) ⬝ IH⁻²ᵒ,
|
||||
exact apd_con g' (e_closure.elim p r) (e_closure.elim p r') ⬝ (IH₁ ◾o IH₂)
|
||||
end
|
||||
|
||||
theorem e_closure_elimo_ap {g' : Π(a : A), Q (g (f a))}
|
||||
(p : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(po : Π⦃a a' : A⦄ (s : R a a'), g' a =[ap g (p s)] g' a')
|
||||
(t : T a a') : e_closure.elimo p (λa a' s, pathover_of_pathover_ap Q g (po s)) t =
|
||||
pathover_of_pathover_ap Q g (change_path (ap_e_closure_elim g p t)⁻¹
|
||||
(e_closure.elimo (λa a' r, ap g (p r)) po t)) :=
|
||||
begin
|
||||
induction t with a a' r a a' pp a a' r IH a a' a'' r r' IH₁ IH₂,
|
||||
{ reflexivity},
|
||||
{ induction pp; reflexivity},
|
||||
{ rewrite [+elimo_symm, ap_e_closure_elim_symm, IH, con_inv, change_path_con, ▸*, -inv2_inv,
|
||||
change_path_invo, pathover_of_pathover_ap_invo]},
|
||||
{ rewrite [+elimo_trans, ap_e_closure_elim_trans, IH₁, IH₂, con_inv, change_path_con, ▸*,
|
||||
con2_inv, change_path_cono, pathover_of_pathover_ap_cono]},
|
||||
end
|
||||
|
||||
end
|
||||
end relation
|
||||
|
|
@ -1,526 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Robert Lewis. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Robert Lewis
|
||||
|
||||
Structures with multiplicative and additive components, including division rings and fields.
|
||||
The development is modeled after Isabelle's library.
|
||||
-/
|
||||
import algebra.binary algebra.group algebra.ring
|
||||
open eq eq.ops algebra
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
|
||||
namespace algebra
|
||||
structure division_ring [class] (A : Type) extends ring A, has_inv A, zero_ne_one_class A :=
|
||||
(mul_inv_cancel : Π{a}, a ≠ zero → mul a (inv a) = one)
|
||||
(inv_mul_cancel : Π{a}, a ≠ zero → mul (inv a) a = one)
|
||||
|
||||
section division_ring
|
||||
variables [s : division_ring A] {a b c : A}
|
||||
include s
|
||||
|
||||
protected definition algebra.div (a b : A) : A := a * b⁻¹
|
||||
|
||||
definition division_ring_has_div [instance] : has_div A :=
|
||||
has_div.mk algebra.div
|
||||
|
||||
lemma division.def (a b : A) : a / b = a * b⁻¹ :=
|
||||
rfl
|
||||
|
||||
theorem mul_inv_cancel (H : a ≠ 0) : a * a⁻¹ = 1 :=
|
||||
division_ring.mul_inv_cancel H
|
||||
|
||||
theorem inv_mul_cancel (H : a ≠ 0) : a⁻¹ * a = 1 :=
|
||||
division_ring.inv_mul_cancel H
|
||||
|
||||
theorem inv_eq_one_div (a : A) : a⁻¹ = 1 / a := !one_mul⁻¹
|
||||
|
||||
theorem div_eq_mul_one_div (a b : A) : a / b = a * (1 / b) :=
|
||||
by rewrite [*division.def, one_mul]
|
||||
|
||||
theorem mul_one_div_cancel (H : a ≠ 0) : a * (1 / a) = 1 :=
|
||||
by rewrite [-inv_eq_one_div, (mul_inv_cancel H)]
|
||||
|
||||
theorem one_div_mul_cancel (H : a ≠ 0) : (1 / a) * a = 1 :=
|
||||
by rewrite [-inv_eq_one_div, (inv_mul_cancel H)]
|
||||
|
||||
theorem div_self (H : a ≠ 0) : a / a = 1 := mul_inv_cancel H
|
||||
|
||||
theorem one_div_one : 1 / 1 = (1:A) := div_self (ne.symm zero_ne_one)
|
||||
|
||||
theorem mul_div_assoc (a b : A) : (a * b) / c = a * (b / c) := !mul.assoc
|
||||
|
||||
theorem one_div_ne_zero (H : a ≠ 0) : 1 / a ≠ 0 :=
|
||||
assume H2 : 1 / a = 0,
|
||||
have C1 : 0 = (1:A), from symm (by rewrite [-(mul_one_div_cancel H), H2, mul_zero]),
|
||||
absurd C1 zero_ne_one
|
||||
|
||||
theorem one_inv_eq : 1⁻¹ = (1:A) :=
|
||||
by rewrite [-mul_one ((1:A)⁻¹), inv_mul_cancel (ne.symm (@zero_ne_one A _))]
|
||||
|
||||
theorem div_one (a : A) : a / 1 = a :=
|
||||
by rewrite [*division.def, one_inv_eq, mul_one]
|
||||
|
||||
theorem zero_div (a : A) : 0 / a = 0 := !zero_mul
|
||||
|
||||
-- note: integral domain has a "mul_ne_zero". A commutative division ring is an integral
|
||||
-- domain, but let's not define that class for now.
|
||||
theorem division_ring.mul_ne_zero (Ha : a ≠ 0) (Hb : b ≠ 0) : a * b ≠ 0 :=
|
||||
assume H : a * b = 0,
|
||||
have C1 : a = 0, by rewrite [-(mul_one a), -(mul_one_div_cancel Hb), -mul.assoc, H, zero_mul],
|
||||
absurd C1 Ha
|
||||
|
||||
theorem mul_ne_zero_comm (H : a * b ≠ 0) : b * a ≠ 0 :=
|
||||
have H2 : a ≠ 0 × b ≠ 0, from ne_zero_prod_ne_zero_of_mul_ne_zero H,
|
||||
division_ring.mul_ne_zero (prod.pr2 H2) (prod.pr1 H2)
|
||||
|
||||
theorem eq_one_div_of_mul_eq_one (H : a * b = 1) : b = 1 / a :=
|
||||
have a ≠ 0, from
|
||||
(suppose a = 0,
|
||||
have 0 = (1:A), by rewrite [-(zero_mul b), -this, H],
|
||||
absurd this zero_ne_one),
|
||||
show b = 1 / a, from symm (calc
|
||||
1 / a = (1 / a) * 1 : mul_one
|
||||
... = (1 / a) * (a * b) : H
|
||||
... = (1 / a) * a * b : mul.assoc
|
||||
... = 1 * b : one_div_mul_cancel this
|
||||
... = b : one_mul)
|
||||
|
||||
theorem eq_one_div_of_mul_eq_one_left (H : b * a = 1) : b = 1 / a :=
|
||||
have a ≠ 0, from
|
||||
(suppose a = 0,
|
||||
have 0 = 1, from symm (calc
|
||||
1 = b * a : symm H
|
||||
... = b * 0 : this
|
||||
... = 0 : mul_zero),
|
||||
absurd this zero_ne_one),
|
||||
show b = 1 / a, from symm (calc
|
||||
1 / a = 1 * (1 / a) : one_mul
|
||||
... = b * a * (1 / a) : H
|
||||
... = b * (a * (1 / a)) : mul.assoc
|
||||
... = b * 1 : mul_one_div_cancel this
|
||||
... = b : mul_one)
|
||||
|
||||
theorem division_ring.one_div_mul_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) :
|
||||
(1 / a) * (1 / b) = 1 / (b * a) :=
|
||||
have (b * a) * ((1 / a) * (1 / b)) = 1, by
|
||||
rewrite [mul.assoc, -(mul.assoc a), (mul_one_div_cancel Ha), one_mul,
|
||||
(mul_one_div_cancel Hb)],
|
||||
eq_one_div_of_mul_eq_one this
|
||||
|
||||
theorem one_div_neg_one_eq_neg_one : (1:A) / (-1) = -1 :=
|
||||
have (-1) * (-1) = (1:A), by rewrite [-neg_eq_neg_one_mul, neg_neg],
|
||||
symm (eq_one_div_of_mul_eq_one this)
|
||||
|
||||
theorem division_ring.one_div_neg_eq_neg_one_div (H : a ≠ 0) : 1 / (- a) = - (1 / a) :=
|
||||
have -1 ≠ (0:A), from
|
||||
(suppose -1 = 0, absurd (symm (calc
|
||||
1 = -(-1) : neg_neg
|
||||
... = -0 : this
|
||||
... = (0:A) : neg_zero)) zero_ne_one),
|
||||
calc
|
||||
1 / (- a) = 1 / ((-1) * a) : neg_eq_neg_one_mul
|
||||
... = (1 / a) * (1 / (- 1)) : division_ring.one_div_mul_one_div H this
|
||||
... = (1 / a) * (-1) : one_div_neg_one_eq_neg_one
|
||||
... = - (1 / a) : mul_neg_one_eq_neg
|
||||
|
||||
theorem div_neg_eq_neg_div (b : A) (Ha : a ≠ 0) : b / (- a) = - (b / a) :=
|
||||
calc
|
||||
b / (- a) = b * (1 / (- a)) : by rewrite -inv_eq_one_div
|
||||
... = b * -(1 / a) : division_ring.one_div_neg_eq_neg_one_div Ha
|
||||
... = -(b * (1 / a)) : neg_mul_eq_mul_neg
|
||||
... = - (b * a⁻¹) : inv_eq_one_div
|
||||
|
||||
theorem neg_div (a b : A) : (-b) / a = - (b / a) :=
|
||||
by rewrite [neg_eq_neg_one_mul, mul_div_assoc, -neg_eq_neg_one_mul]
|
||||
|
||||
theorem division_ring.neg_div_neg_eq (a : A) {b : A} (Hb : b ≠ 0) : (-a) / (-b) = a / b :=
|
||||
by rewrite [(div_neg_eq_neg_div _ Hb), neg_div, neg_neg]
|
||||
|
||||
theorem division_ring.one_div_one_div (H : a ≠ 0) : 1 / (1 / a) = a :=
|
||||
symm (eq_one_div_of_mul_eq_one_left (mul_one_div_cancel H))
|
||||
|
||||
theorem division_ring.eq_of_one_div_eq_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) (H : 1 / a = 1 / b) :
|
||||
a = b :=
|
||||
by rewrite [-(division_ring.one_div_one_div Ha), H, (division_ring.one_div_one_div Hb)]
|
||||
|
||||
theorem mul_inv_eq (Ha : a ≠ 0) (Hb : b ≠ 0) : (b * a)⁻¹ = a⁻¹ * b⁻¹ :=
|
||||
inverse (calc
|
||||
a⁻¹ * b⁻¹ = (1 / a) * b⁻¹ : inv_eq_one_div
|
||||
... = (1 / a) * (1 / b) : inv_eq_one_div
|
||||
... = (1 / (b * a)) : division_ring.one_div_mul_one_div Ha Hb
|
||||
... = (b * a)⁻¹ : inv_eq_one_div)
|
||||
|
||||
theorem mul_div_cancel (a : A) {b : A} (Hb : b ≠ 0) : a * b / b = a :=
|
||||
by rewrite [*division.def, mul.assoc, (mul_inv_cancel Hb), mul_one]
|
||||
|
||||
theorem div_mul_cancel (a : A) {b : A} (Hb : b ≠ 0) : a / b * b = a :=
|
||||
by rewrite [*division.def, mul.assoc, (inv_mul_cancel Hb), mul_one]
|
||||
|
||||
theorem div_add_div_same (a b c : A) : a / c + b / c = (a + b) / c := !right_distrib⁻¹
|
||||
|
||||
theorem div_sub_div_same (a b c : A) : (a / c) - (b / c) = (a - b) / c :=
|
||||
by rewrite [sub_eq_add_neg, -neg_div, div_add_div_same]
|
||||
|
||||
theorem one_div_mul_add_mul_one_div_eq_one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) :
|
||||
(1 / a) * (a + b) * (1 / b) = 1 / a + 1 / b :=
|
||||
by rewrite [(left_distrib (1 / a)), (one_div_mul_cancel Ha), right_distrib, one_mul,
|
||||
mul.assoc, (mul_one_div_cancel Hb), mul_one, add.comm]
|
||||
|
||||
theorem one_div_mul_sub_mul_one_div_eq_one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) :
|
||||
(1 / a) * (b - a) * (1 / b) = 1 / a - 1 / b :=
|
||||
by rewrite [(mul_sub_left_distrib (1 / a)), (one_div_mul_cancel Ha), mul_sub_right_distrib,
|
||||
one_mul, mul.assoc, (mul_one_div_cancel Hb), mul_one]
|
||||
|
||||
theorem div_eq_one_iff_eq (a : A) {b : A} (Hb : b ≠ 0) : a / b = 1 ↔ a = b :=
|
||||
iff.intro
|
||||
(suppose a / b = 1, symm (calc
|
||||
b = 1 * b : one_mul
|
||||
... = a / b * b : this
|
||||
... = a : div_mul_cancel _ Hb))
|
||||
(suppose a = b, calc
|
||||
a / b = b / b : this
|
||||
... = 1 : div_self Hb)
|
||||
|
||||
theorem eq_of_div_eq_one (a : A) {b : A} (Hb : b ≠ 0) : a / b = 1 → a = b :=
|
||||
iff.mp (!div_eq_one_iff_eq Hb)
|
||||
|
||||
theorem eq_div_iff_mul_eq (a : A) {b : A} (Hc : c ≠ 0) : a = b / c ↔ a * c = b :=
|
||||
iff.intro
|
||||
(suppose a = b / c, by rewrite [this, (!div_mul_cancel Hc)])
|
||||
(suppose a * c = b, begin rewrite [-mul_div_cancel a Hc, this] end)
|
||||
|
||||
theorem eq_div_of_mul_eq (a b : A) {c : A} (Hc : c ≠ 0) : a * c = b → a = b / c :=
|
||||
iff.mpr (!eq_div_iff_mul_eq Hc)
|
||||
|
||||
theorem mul_eq_of_eq_div (a b: A) {c : A} (Hc : c ≠ 0) : a = b / c → a * c = b :=
|
||||
iff.mp (!eq_div_iff_mul_eq Hc)
|
||||
|
||||
theorem add_div_eq_mul_add_div (a b : A) {c : A} (Hc : c ≠ 0) : a + b / c = (a * c + b) / c :=
|
||||
have (a + b / c) * c = a * c + b, by rewrite [right_distrib, (!div_mul_cancel Hc)],
|
||||
(iff.elim_right (!eq_div_iff_mul_eq Hc)) this
|
||||
|
||||
theorem mul_mul_div (a : A) {c : A} (Hc : c ≠ 0) : a = a * c * (1 / c) :=
|
||||
calc
|
||||
a = a * 1 : mul_one
|
||||
... = a * (c * (1 / c)) : mul_one_div_cancel Hc
|
||||
... = a * c * (1 / c) : mul.assoc
|
||||
|
||||
-- There are many similar rules to these last two in the Isabelle library
|
||||
-- that haven't been ported yet. Do as necessary.
|
||||
end division_ring
|
||||
|
||||
structure field [class] (A : Type) extends division_ring A, comm_ring A
|
||||
|
||||
section field
|
||||
variables [s : field A] {a b c d: A}
|
||||
include s
|
||||
|
||||
theorem field.one_div_mul_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : (1 / a) * (1 / b) = 1 / (a * b) :=
|
||||
by rewrite [(division_ring.one_div_mul_one_div Ha Hb), mul.comm b]
|
||||
|
||||
theorem field.div_mul_right (Hb : b ≠ 0) (H : a * b ≠ 0) : a / (a * b) = 1 / b :=
|
||||
have a ≠ 0, from prod.pr1 (ne_zero_prod_ne_zero_of_mul_ne_zero H),
|
||||
symm (calc
|
||||
1 / b = 1 * (1 / b) : one_mul
|
||||
... = (a * a⁻¹) * (1 / b) : mul_inv_cancel this
|
||||
... = a * (a⁻¹ * (1 / b)) : mul.assoc
|
||||
... = a * ((1 / a) * (1 / b)) : inv_eq_one_div
|
||||
... = a * (1 / (b * a)) : division_ring.one_div_mul_one_div this Hb
|
||||
... = a * (1 / (a * b)) : mul.comm
|
||||
... = a * (a * b)⁻¹ : inv_eq_one_div)
|
||||
|
||||
theorem field.div_mul_left (Ha : a ≠ 0) (H : a * b ≠ 0) : b / (a * b) = 1 / a :=
|
||||
let H1 : b * a ≠ 0 := mul_ne_zero_comm H in
|
||||
by rewrite [mul.comm a, (field.div_mul_right Ha H1)]
|
||||
|
||||
theorem mul_div_cancel_left (Ha : a ≠ 0) : a * b / a = b :=
|
||||
by rewrite [mul.comm a, (!mul_div_cancel Ha)]
|
||||
|
||||
theorem mul_div_cancel' (Hb : b ≠ 0) : b * (a / b) = a :=
|
||||
by rewrite [mul.comm, (!div_mul_cancel Hb)]
|
||||
|
||||
theorem one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : 1 / a + 1 / b = (a + b) / (a * b) :=
|
||||
have a * b ≠ 0, from (division_ring.mul_ne_zero Ha Hb),
|
||||
by rewrite [add.comm, -(field.div_mul_left Ha this), -(field.div_mul_right Hb this), *division.def,
|
||||
-right_distrib]
|
||||
|
||||
theorem field.div_mul_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) :
|
||||
(a / b) * (c / d) = (a * c) / (b * d) :=
|
||||
by rewrite [*division.def, 2 mul.assoc, (mul.comm b⁻¹), mul.assoc, (mul_inv_eq Hd Hb)]
|
||||
|
||||
theorem mul_div_mul_left (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) :
|
||||
(c * a) / (c * b) = a / b :=
|
||||
by rewrite [-(!field.div_mul_div Hc Hb), (div_self Hc), one_mul]
|
||||
|
||||
theorem mul_div_mul_right (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) :
|
||||
(a * c) / (b * c) = a / b :=
|
||||
by rewrite [(mul.comm a), (mul.comm b), (!mul_div_mul_left Hb Hc)]
|
||||
|
||||
theorem div_mul_eq_mul_div (a b c : A) : (b / c) * a = (b * a) / c :=
|
||||
by rewrite [*division.def, mul.assoc, (mul.comm c⁻¹), -mul.assoc]
|
||||
|
||||
theorem field.div_mul_eq_mul_div_comm (a b : A) {c : A} (Hc : c ≠ 0) :
|
||||
(b / c) * a = b * (a / c) :=
|
||||
by rewrite [(div_mul_eq_mul_div), -(one_mul c), -(!field.div_mul_div (ne.symm zero_ne_one) Hc),
|
||||
div_one, one_mul]
|
||||
|
||||
theorem div_add_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) :
|
||||
(a / b) + (c / d) = ((a * d) + (b * c)) / (b * d) :=
|
||||
by rewrite [-(!mul_div_mul_right Hb Hd), -(!mul_div_mul_left Hd Hb), div_add_div_same]
|
||||
|
||||
theorem div_sub_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) :
|
||||
(a / b) - (c / d) = ((a * d) - (b * c)) / (b * d) :=
|
||||
by rewrite [*sub_eq_add_neg, neg_eq_neg_one_mul, -mul_div_assoc, (!div_add_div Hb Hd),
|
||||
-mul.assoc, (mul.comm b), mul.assoc, -neg_eq_neg_one_mul]
|
||||
|
||||
theorem mul_eq_mul_of_div_eq_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0)
|
||||
(Hd : d ≠ 0) (H : a / b = c / d) : a * d = c * b :=
|
||||
by rewrite [-mul_one (a*d), mul.assoc, (mul.comm d), -mul.assoc, -(div_self Hb),
|
||||
-(!field.div_mul_eq_mul_div_comm Hb), H, (div_mul_eq_mul_div), (!div_mul_cancel Hd)]
|
||||
|
||||
theorem field.one_div_div (Ha : a ≠ 0) (Hb : b ≠ 0) : 1 / (a / b) = b / a :=
|
||||
have (a / b) * (b / a) = 1, from calc
|
||||
(a / b) * (b / a) = (a * b) / (b * a) : !field.div_mul_div Hb Ha
|
||||
... = (a * b) / (a * b) : mul.comm
|
||||
... = 1 : div_self (division_ring.mul_ne_zero Ha Hb),
|
||||
symm (eq_one_div_of_mul_eq_one this)
|
||||
|
||||
theorem field.div_div_eq_mul_div (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) :
|
||||
a / (b / c) = (a * c) / b :=
|
||||
by rewrite [div_eq_mul_one_div, (field.one_div_div Hb Hc), -mul_div_assoc]
|
||||
|
||||
theorem field.div_div_eq_div_mul (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) :
|
||||
(a / b) / c = a / (b * c) :=
|
||||
by rewrite [div_eq_mul_one_div, (!field.div_mul_div Hb Hc), mul_one]
|
||||
|
||||
theorem field.div_div_div_div_eq (a : A) {b c d : A} (Hb : b ≠ 0) (Hc : c ≠ 0) (Hd : d ≠ 0) :
|
||||
(a / b) / (c / d) = (a * d) / (b * c) :=
|
||||
by rewrite [(!field.div_div_eq_mul_div Hc Hd), (div_mul_eq_mul_div),
|
||||
(!field.div_div_eq_div_mul Hb Hc)]
|
||||
|
||||
theorem field.div_mul_eq_div_mul_one_div (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) :
|
||||
a / (b * c) = (a / b) * (1 / c) :=
|
||||
by rewrite [-!field.div_div_eq_div_mul Hb Hc, -div_eq_mul_one_div]
|
||||
|
||||
theorem eq_of_mul_eq_mul_of_nonzero_left {a b c : A} (H : a ≠ 0) (H2 : a * b = a * c) : b = c :=
|
||||
by rewrite [-one_mul b, -div_self H, div_mul_eq_mul_div, H2, mul_div_cancel_left H]
|
||||
|
||||
theorem eq_of_mul_eq_mul_of_nonzero_right {a b c : A} (H : c ≠ 0) (H2 : a * c = b * c) : a = b :=
|
||||
by rewrite [-mul_one a, -div_self H, -mul_div_assoc, H2, mul_div_cancel _ H]
|
||||
|
||||
end field
|
||||
|
||||
structure discrete_field [class] (A : Type) extends field A :=
|
||||
(has_decidable_eq : decidable_eq A)
|
||||
(inv_zero : inv zero = zero)
|
||||
|
||||
attribute discrete_field.has_decidable_eq [instance]
|
||||
|
||||
section discrete_field
|
||||
variable [s : discrete_field A]
|
||||
include s
|
||||
variables {a b c d : A}
|
||||
|
||||
-- many of the theorems in discrete_field are the same as theorems in field sum division ring,
|
||||
-- but with fewer hypotheses since 0⁻¹ = 0 and equality is decidable.
|
||||
|
||||
theorem discrete_field.eq_zero_sum_eq_zero_of_mul_eq_zero
|
||||
(x y : A) (H : x * y = 0) : x = 0 ⊎ y = 0 :=
|
||||
decidable.by_cases
|
||||
(suppose x = 0, sum.inl this)
|
||||
(suppose x ≠ 0,
|
||||
sum.inr (by rewrite [-one_mul y, -(inv_mul_cancel this), mul.assoc, H, mul_zero]))
|
||||
|
||||
definition discrete_field.to_integral_domain [trans_instance] : integral_domain A :=
|
||||
⦃ integral_domain, s,
|
||||
eq_zero_sum_eq_zero_of_mul_eq_zero := discrete_field.eq_zero_sum_eq_zero_of_mul_eq_zero⦄
|
||||
|
||||
theorem inv_zero : 0⁻¹ = (0:A) := !discrete_field.inv_zero
|
||||
|
||||
theorem one_div_zero : 1 / 0 = (0:A) :=
|
||||
calc
|
||||
1 / 0 = 1 * 0⁻¹ : refl
|
||||
... = 1 * 0 : inv_zero
|
||||
... = 0 : mul_zero
|
||||
|
||||
theorem div_zero (a : A) : a / 0 = 0 := by rewrite [div_eq_mul_one_div, one_div_zero, mul_zero]
|
||||
|
||||
theorem ne_zero_of_one_div_ne_zero (H : 1 / a ≠ 0) : a ≠ 0 :=
|
||||
assume Ha : a = 0, absurd (Ha⁻¹ ▸ one_div_zero) H
|
||||
|
||||
theorem eq_zero_of_one_div_eq_zero (H : 1 / a = 0) : a = 0 :=
|
||||
decidable.by_cases
|
||||
(assume Ha, Ha)
|
||||
(assume Ha, empty.elim ((one_div_ne_zero Ha) H))
|
||||
|
||||
variables (a b)
|
||||
theorem one_div_mul_one_div' : (1 / a) * (1 / b) = 1 / (b * a) :=
|
||||
decidable.by_cases
|
||||
(suppose a = 0,
|
||||
by rewrite [this, div_zero, zero_mul, -(@div_zero A s 1), mul_zero b])
|
||||
(assume Ha : a ≠ 0,
|
||||
decidable.by_cases
|
||||
(suppose b = 0,
|
||||
by rewrite [this, div_zero, mul_zero, -(@div_zero A s 1), zero_mul a])
|
||||
(suppose b ≠ 0, division_ring.one_div_mul_one_div Ha this))
|
||||
|
||||
theorem one_div_neg_eq_neg_one_div : 1 / (- a) = - (1 / a) :=
|
||||
decidable.by_cases
|
||||
(suppose a = 0, by rewrite [this, neg_zero, 2 div_zero, neg_zero])
|
||||
(suppose a ≠ 0, division_ring.one_div_neg_eq_neg_one_div this)
|
||||
|
||||
theorem neg_div_neg_eq : (-a) / (-b) = a / b :=
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, neg_zero, 2 div_zero])
|
||||
(assume Hb : b ≠ 0, !division_ring.neg_div_neg_eq Hb)
|
||||
|
||||
theorem one_div_one_div : 1 / (1 / a) = a :=
|
||||
decidable.by_cases
|
||||
(assume Ha : a = 0, by rewrite [Ha, 2 div_zero])
|
||||
(assume Ha : a ≠ 0, division_ring.one_div_one_div Ha)
|
||||
|
||||
variables {a b}
|
||||
theorem eq_of_one_div_eq_one_div (H : 1 / a = 1 / b) : a = b :=
|
||||
decidable.by_cases
|
||||
(assume Ha : a = 0,
|
||||
have Hb : b = 0, from eq_zero_of_one_div_eq_zero (by rewrite [-H, Ha, div_zero]),
|
||||
Hb⁻¹ ▸ Ha)
|
||||
(assume Ha : a ≠ 0,
|
||||
have Hb : b ≠ 0, from ne_zero_of_one_div_ne_zero (H ▸ (one_div_ne_zero Ha)),
|
||||
division_ring.eq_of_one_div_eq_one_div Ha Hb H)
|
||||
|
||||
variables (a b)
|
||||
theorem mul_inv' : (b * a)⁻¹ = a⁻¹ * b⁻¹ :=
|
||||
decidable.by_cases
|
||||
(assume Ha : a = 0, by rewrite [Ha, mul_zero, 2 inv_zero, zero_mul])
|
||||
(assume Ha : a ≠ 0,
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, zero_mul, 2 inv_zero, mul_zero])
|
||||
(assume Hb : b ≠ 0, mul_inv_eq Ha Hb))
|
||||
|
||||
-- the following are specifically for fields
|
||||
theorem one_div_mul_one_div : (1 / a) * (1 / b) = 1 / (a * b) :=
|
||||
by rewrite [one_div_mul_one_div', mul.comm b]
|
||||
|
||||
variable {a}
|
||||
theorem div_mul_right (Ha : a ≠ 0) : a / (a * b) = 1 / b :=
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, mul_zero, 2 div_zero])
|
||||
(assume Hb : b ≠ 0, field.div_mul_right Hb (mul_ne_zero Ha Hb))
|
||||
|
||||
variables (a) {b}
|
||||
theorem div_mul_left (Hb : b ≠ 0) : b / (a * b) = 1 / a :=
|
||||
by rewrite [mul.comm a, div_mul_right _ Hb]
|
||||
|
||||
variables (a b c)
|
||||
theorem div_mul_div : (a / b) * (c / d) = (a * c) / (b * d) :=
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, div_zero, zero_mul, -(@div_zero A s (a * c)), zero_mul])
|
||||
(assume Hb : b ≠ 0,
|
||||
decidable.by_cases
|
||||
(assume Hd : d = 0, by rewrite [Hd, div_zero, mul_zero, -(@div_zero A s (a * c)),
|
||||
mul_zero])
|
||||
(assume Hd : d ≠ 0, !field.div_mul_div Hb Hd))
|
||||
|
||||
variable {c}
|
||||
theorem mul_div_mul_left' (Hc : c ≠ 0) : (c * a) / (c * b) = a / b :=
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, mul_zero, 2 div_zero])
|
||||
(assume Hb : b ≠ 0, !mul_div_mul_left Hb Hc)
|
||||
|
||||
theorem mul_div_mul_right' (Hc : c ≠ 0) : (a * c) / (b * c) = a / b :=
|
||||
by rewrite [(mul.comm a), (mul.comm b), (!mul_div_mul_left' Hc)]
|
||||
|
||||
variables (a b c d)
|
||||
theorem div_mul_eq_mul_div_comm : (b / c) * a = b * (a / c) :=
|
||||
decidable.by_cases
|
||||
(assume Hc : c = 0, by rewrite [Hc, div_zero, zero_mul, -(mul_zero b), -(@div_zero A s a)])
|
||||
(assume Hc : c ≠ 0, !field.div_mul_eq_mul_div_comm Hc)
|
||||
|
||||
theorem one_div_div : 1 / (a / b) = b / a :=
|
||||
decidable.by_cases
|
||||
(assume Ha : a = 0, by rewrite [Ha, zero_div, 2 div_zero])
|
||||
(assume Ha : a ≠ 0,
|
||||
decidable.by_cases
|
||||
(assume Hb : b = 0, by rewrite [Hb, 2 div_zero, zero_div])
|
||||
(assume Hb : b ≠ 0, field.one_div_div Ha Hb))
|
||||
|
||||
theorem div_div_eq_mul_div : a / (b / c) = (a * c) / b :=
|
||||
by rewrite [div_eq_mul_one_div, one_div_div, -mul_div_assoc]
|
||||
|
||||
theorem div_div_eq_div_mul : (a / b) / c = a / (b * c) :=
|
||||
by rewrite [div_eq_mul_one_div, div_mul_div, mul_one]
|
||||
|
||||
theorem div_div_div_div_eq : (a / b) / (c / d) = (a * d) / (b * c) :=
|
||||
by rewrite [div_div_eq_mul_div, div_mul_eq_mul_div, div_div_eq_div_mul]
|
||||
|
||||
variable {a}
|
||||
theorem div_helper (H : a ≠ 0) : (1 / (a * b)) * a = 1 / b :=
|
||||
by rewrite [div_mul_eq_mul_div, one_mul, !div_mul_right H]
|
||||
|
||||
variable (a)
|
||||
theorem div_mul_eq_div_mul_one_div : a / (b * c) = (a / b) * (1 / c) :=
|
||||
by rewrite [-div_div_eq_div_mul, -div_eq_mul_one_div]
|
||||
|
||||
end discrete_field
|
||||
|
||||
namespace norm_num
|
||||
|
||||
theorem div_add_helper [s : field A] (n d b c val : A) (Hd : d ≠ 0) (H : n + b * d = val)
|
||||
(H2 : c * d = val) : n / d + b = c :=
|
||||
begin
|
||||
apply eq_of_mul_eq_mul_of_nonzero_right Hd,
|
||||
rewrite [H2, -H, right_distrib, div_mul_cancel _ Hd]
|
||||
end
|
||||
|
||||
theorem add_div_helper [s : field A] (n d b c val : A) (Hd : d ≠ 0) (H : d * b + n = val)
|
||||
(H2 : d * c = val) : b + n / d = c :=
|
||||
begin
|
||||
apply eq_of_mul_eq_mul_of_nonzero_left Hd,
|
||||
rewrite [H2, -H, left_distrib, mul_div_cancel' Hd]
|
||||
end
|
||||
|
||||
theorem div_mul_helper [s : field A] (n d c v : A) (Hd : d ≠ 0) (H : (n * c) / d = v) :
|
||||
(n / d) * c = v :=
|
||||
by rewrite [-H, field.div_mul_eq_mul_div_comm _ _ Hd, mul_div_assoc]
|
||||
|
||||
theorem mul_div_helper [s : field A] (a n d v : A) (Hd : d ≠ 0) (H : (a * n) / d = v) :
|
||||
a * (n / d) = v :=
|
||||
by rewrite [-H, mul_div_assoc]
|
||||
|
||||
theorem nonzero_of_div_helper [s : field A] (a b : A) (Ha : a ≠ 0) (Hb : b ≠ 0) : a / b ≠ 0 :=
|
||||
begin
|
||||
intro Hab,
|
||||
have Habb : (a / b) * b = 0, by rewrite [Hab, zero_mul],
|
||||
rewrite [div_mul_cancel _ Hb at Habb],
|
||||
exact Ha Habb
|
||||
end
|
||||
|
||||
theorem div_helper [s : field A] (n d v : A) (Hd : d ≠ 0) (H : v * d = n) : n / d = v :=
|
||||
begin
|
||||
apply eq_of_mul_eq_mul_of_nonzero_right Hd,
|
||||
rewrite (div_mul_cancel _ Hd),
|
||||
exact inverse H
|
||||
end
|
||||
|
||||
theorem div_eq_div_helper [s : field A] (a b c d v : A) (H1 : a * d = v) (H2 : c * b = v)
|
||||
(Hb : b ≠ 0) (Hd : d ≠ 0) : a / b = c / d :=
|
||||
begin
|
||||
apply eq_div_of_mul_eq,
|
||||
exact Hd,
|
||||
rewrite div_mul_eq_mul_div,
|
||||
apply inverse,
|
||||
apply eq_div_of_mul_eq,
|
||||
exact Hb,
|
||||
rewrite [H1, H2]
|
||||
end
|
||||
|
||||
theorem subst_into_div [s : has_div A] (a₁ b₁ a₂ b₂ v : A) (H : a₁ / b₁ = v) (H1 : a₂ = a₁)
|
||||
(H2 : b₂ = b₁) : a₂ / b₂ = v :=
|
||||
by rewrite [H1, H2, H]
|
||||
|
||||
end norm_num
|
||||
end algebra
|
||||
|
|
@ -1,330 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
|
@ -1,207 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad, Leonardo de Moura
|
||||
|
||||
Various multiplicative and additive structures. Partially modeled on Isabelle's library.
|
||||
-/
|
||||
|
||||
import algebra.inf_group
|
||||
|
||||
open eq eq.ops -- note: ⁻¹ will be overloaded
|
||||
open binary algebra is_trunc
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
|
||||
/- semigroup -/
|
||||
|
||||
namespace algebra
|
||||
|
||||
structure is_set_structure [class] (A : Type) :=
|
||||
(is_set_carrier : is_set A)
|
||||
|
||||
attribute is_set_structure.is_set_carrier [instance] [priority 950]
|
||||
|
||||
structure semigroup [class] (A : Type) extends is_set_structure A, inf_semigroup A
|
||||
|
||||
structure comm_semigroup [class] (A : Type) extends semigroup A, comm_inf_semigroup A
|
||||
|
||||
structure left_cancel_semigroup [class] (A : Type) extends semigroup A, left_cancel_inf_semigroup A
|
||||
|
||||
structure right_cancel_semigroup [class] (A : Type) extends semigroup A, right_cancel_inf_semigroup A
|
||||
|
||||
/- additive semigroup -/
|
||||
|
||||
definition add_semigroup [class] : Type → Type := semigroup
|
||||
|
||||
definition add_semigroup.is_set_carrier [instance] [priority 900] (A : Type) [H : add_semigroup A] :
|
||||
is_set A :=
|
||||
@is_set_structure.is_set_carrier A (@semigroup.to_is_set_structure A H)
|
||||
|
||||
definition add_inf_semigroup_of_add_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_semigroup A] : add_inf_semigroup A :=
|
||||
@semigroup.to_inf_semigroup A H
|
||||
|
||||
definition add_comm_semigroup [class] : Type → Type := comm_semigroup
|
||||
|
||||
definition add_semigroup_of_add_comm_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_semigroup A] : add_semigroup A :=
|
||||
@comm_semigroup.to_semigroup A H
|
||||
|
||||
definition add_comm_inf_semigroup_of_add_comm_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_semigroup A] : add_comm_inf_semigroup A :=
|
||||
@comm_semigroup.to_comm_inf_semigroup A H
|
||||
|
||||
definition add_left_cancel_semigroup [class] : Type → Type := left_cancel_semigroup
|
||||
|
||||
definition add_semigroup_of_add_left_cancel_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_left_cancel_semigroup A] : add_semigroup A :=
|
||||
@left_cancel_semigroup.to_semigroup A H
|
||||
|
||||
definition add_left_cancel_inf_semigroup_of_add_left_cancel_semigroup [reducible] [trans_instance]
|
||||
(A : Type) [H : add_left_cancel_semigroup A] : add_left_cancel_inf_semigroup A :=
|
||||
@left_cancel_semigroup.to_left_cancel_inf_semigroup A H
|
||||
|
||||
definition add_right_cancel_semigroup [class] : Type → Type := right_cancel_semigroup
|
||||
|
||||
definition add_semigroup_of_add_right_cancel_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_right_cancel_semigroup A] : add_semigroup A :=
|
||||
@right_cancel_semigroup.to_semigroup A H
|
||||
|
||||
definition add_right_cancel_inf_semigroup_of_add_right_cancel_semigroup [reducible] [trans_instance]
|
||||
(A : Type) [H : add_right_cancel_semigroup A] : add_right_cancel_inf_semigroup A :=
|
||||
@right_cancel_semigroup.to_right_cancel_inf_semigroup A H
|
||||
|
||||
/- monoid -/
|
||||
|
||||
structure monoid [class] (A : Type) extends semigroup A, inf_monoid A
|
||||
|
||||
structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A, comm_inf_monoid A
|
||||
|
||||
/- additive monoid -/
|
||||
|
||||
definition add_monoid [class] : Type → Type := monoid
|
||||
|
||||
definition add_semigroup_of_add_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_monoid A] : add_semigroup A :=
|
||||
@monoid.to_semigroup A H
|
||||
|
||||
definition add_inf_monoid_of_add_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_monoid A] : add_inf_monoid A :=
|
||||
@monoid.to_inf_monoid A H
|
||||
|
||||
definition add_comm_monoid [class] : Type → Type := comm_monoid
|
||||
|
||||
definition add_monoid_of_add_comm_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_monoid A] : add_monoid A :=
|
||||
@comm_monoid.to_monoid A H
|
||||
|
||||
definition add_comm_semigroup_of_add_comm_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_monoid A] : add_comm_semigroup A :=
|
||||
@comm_monoid.to_comm_semigroup A H
|
||||
|
||||
definition add_comm_inf_monoid_of_add_comm_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_monoid A] : add_comm_inf_monoid A :=
|
||||
@comm_monoid.to_comm_inf_monoid A H
|
||||
|
||||
definition add_monoid.to_monoid {A : Type} [s : add_monoid A] : monoid A := s
|
||||
definition add_comm_monoid.to_comm_monoid {A : Type} [s : add_comm_monoid A] : comm_monoid A := s
|
||||
definition monoid.to_add_monoid {A : Type} [s : monoid A] : add_monoid A := s
|
||||
definition comm_monoid.to_add_comm_monoid {A : Type} [s : comm_monoid A] : add_comm_monoid A := s
|
||||
|
||||
/- group -/
|
||||
|
||||
structure group [class] (A : Type) extends monoid A, inf_group A
|
||||
|
||||
definition group_of_inf_group (A : Type) [s : inf_group A] [is_set A] : group A :=
|
||||
⦃group, s, is_set_carrier := _⦄
|
||||
|
||||
section group
|
||||
|
||||
variable [s : group A]
|
||||
include s
|
||||
|
||||
definition group.to_left_cancel_semigroup [trans_instance] : left_cancel_semigroup A :=
|
||||
⦃ left_cancel_semigroup, s,
|
||||
mul_left_cancel := @mul_left_cancel A _ ⦄
|
||||
|
||||
definition group.to_right_cancel_semigroup [trans_instance] : right_cancel_semigroup A :=
|
||||
⦃ right_cancel_semigroup, s,
|
||||
mul_right_cancel := @mul_right_cancel A _ ⦄
|
||||
|
||||
end group
|
||||
|
||||
structure ab_group [class] (A : Type) extends group A, comm_monoid A, ab_inf_group A
|
||||
|
||||
definition ab_group_of_ab_inf_group (A : Type) [s : ab_inf_group A] [is_set A] : ab_group A :=
|
||||
⦃ab_group, s, is_set_carrier := _⦄
|
||||
|
||||
/- additive group -/
|
||||
|
||||
definition add_group [class] : Type → Type := group
|
||||
|
||||
definition add_semigroup_of_add_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_group A] : add_monoid A :=
|
||||
@group.to_monoid A H
|
||||
|
||||
definition add_inf_group_of_add_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_group A] : add_inf_group A :=
|
||||
@group.to_inf_group A H
|
||||
|
||||
definition add_group.to_group {A : Type} [s : add_group A] : group A := s
|
||||
definition group.to_add_group {A : Type} [s : group A] : add_group A := s
|
||||
|
||||
definition add_group_of_add_inf_group (A : Type) [s : add_inf_group A] [is_set A] :
|
||||
add_group A :=
|
||||
⦃group, s, is_set_carrier := _⦄
|
||||
|
||||
section add_group
|
||||
|
||||
variables [s : add_group A]
|
||||
include s
|
||||
|
||||
definition add_group.to_add_left_cancel_semigroup [reducible] [trans_instance] :
|
||||
add_left_cancel_semigroup A :=
|
||||
@group.to_left_cancel_semigroup A s
|
||||
|
||||
definition add_group.to_add_right_cancel_semigroup [reducible] [trans_instance] :
|
||||
add_right_cancel_semigroup A :=
|
||||
@group.to_right_cancel_semigroup A s
|
||||
|
||||
end add_group
|
||||
|
||||
definition add_ab_group [class] : Type → Type := ab_group
|
||||
|
||||
definition add_group_of_add_ab_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_ab_group A] : add_group A :=
|
||||
@ab_group.to_group A H
|
||||
|
||||
definition add_comm_monoid_of_add_ab_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_ab_group A] : add_comm_monoid A :=
|
||||
@ab_group.to_comm_monoid A H
|
||||
|
||||
definition add_ab_inf_group_of_add_ab_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_ab_group A] : add_ab_inf_group A :=
|
||||
@ab_group.to_ab_inf_group A H
|
||||
|
||||
definition add_ab_group.to_ab_group {A : Type} [s : add_ab_group A] : ab_group A := s
|
||||
definition ab_group.to_add_ab_group {A : Type} [s : ab_group A] : add_ab_group A := s
|
||||
|
||||
definition add_ab_group_of_add_ab_inf_group (A : Type) [s : add_ab_inf_group A] [is_set A] :
|
||||
add_ab_group A :=
|
||||
⦃ab_group, s, is_set_carrier := _⦄
|
||||
|
||||
definition group_of_add_group (A : Type) [G : add_group A] : group A :=
|
||||
⦃group,
|
||||
mul := has_add.add,
|
||||
mul_assoc := add.assoc,
|
||||
one := !has_zero.zero,
|
||||
one_mul := zero_add,
|
||||
mul_one := add_zero,
|
||||
inv := has_neg.neg,
|
||||
mul_left_inv := add.left_inv,
|
||||
is_set_carrier := _⦄
|
||||
|
||||
end algebra
|
||||
open algebra
|
||||
|
|
@ -1,539 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Basic group theory
|
||||
-/
|
||||
|
||||
import algebra.category.category algebra.bundled .homomorphism
|
||||
|
||||
open eq algebra pointed function is_trunc pi equiv is_equiv
|
||||
set_option class.force_new true
|
||||
|
||||
namespace group
|
||||
definition pointed_Group [instance] [constructor] (G : Group) : pointed G :=
|
||||
pointed.mk 1
|
||||
|
||||
definition Group.struct' [instance] [reducible] (G : Group) : group G :=
|
||||
Group.struct G
|
||||
|
||||
definition ab_group_Group_of_AbGroup [instance] [constructor] [priority 900]
|
||||
(G : AbGroup) : ab_group (Group_of_AbGroup G) :=
|
||||
begin esimp, exact _ end
|
||||
|
||||
definition ab_group_pSet_of_Group [instance] (G : AbGroup) : ab_group (pSet_of_Group G) :=
|
||||
AbGroup.struct G
|
||||
|
||||
definition group_pSet_of_Group [instance] [priority 900] (G : Group) :
|
||||
group (pSet_of_Group G) :=
|
||||
Group.struct G
|
||||
|
||||
/- group homomorphisms -/
|
||||
/-
|
||||
definition is_homomorphism [class] [reducible]
|
||||
{G₁ G₂ : Type} [has_mul G₁] [has_mul G₂] (φ : G₁ → G₂) : Type :=
|
||||
Π(g h : G₁), φ (g * h) = φ g * φ h
|
||||
|
||||
section
|
||||
variables {G G₁ G₂ G₃ : Type} {g h : G₁} (ψ : G₂ → G₃) {φ₁ φ₂ : G₁ → G₂} (φ : G₁ → G₂)
|
||||
[group G] [group G₁] [group G₂] [group G₃]
|
||||
[is_homomorphism ψ] [is_homomorphism φ₁] [is_homomorphism φ₂] [is_homomorphism φ]
|
||||
|
||||
definition respect_mul {G₁ G₂ : Type} [has_mul G₁] [has_mul G₂] (φ : G₁ → G₂)
|
||||
[is_homomorphism φ] : Π(g h : G₁), φ (g * h) = φ g * φ h :=
|
||||
by assumption
|
||||
|
||||
theorem respect_one /- φ -/ : φ 1 = 1 :=
|
||||
mul.right_cancel
|
||||
(calc
|
||||
φ 1 * φ 1 = φ (1 * 1) : respect_mul φ
|
||||
... = φ 1 : ap φ !one_mul
|
||||
... = 1 * φ 1 : one_mul)
|
||||
|
||||
theorem respect_inv /- φ -/ (g : G₁) : φ g⁻¹ = (φ g)⁻¹ :=
|
||||
eq_inv_of_mul_eq_one (!respect_mul⁻¹ ⬝ ap φ !mul.left_inv ⬝ !respect_one)
|
||||
|
||||
definition is_embedding_homomorphism /- φ -/ (H : Π{g}, φ g = 1 → g = 1) : is_embedding φ :=
|
||||
begin
|
||||
apply function.is_embedding_of_is_injective,
|
||||
intro g g' p,
|
||||
apply eq_of_mul_inv_eq_one,
|
||||
apply H,
|
||||
refine !respect_mul ⬝ _,
|
||||
rewrite [respect_inv φ, p],
|
||||
apply mul.right_inv
|
||||
end
|
||||
|
||||
definition is_homomorphism_compose {ψ : G₂ → G₃} {φ : G₁ → G₂}
|
||||
(H1 : is_homomorphism ψ) (H2 : is_homomorphism φ) : is_homomorphism (ψ ∘ φ) :=
|
||||
λg h, ap ψ !respect_mul ⬝ !respect_mul
|
||||
|
||||
definition is_homomorphism_id (G : Type) [group G] : is_homomorphism (@id G) :=
|
||||
λg h, idp
|
||||
|
||||
end
|
||||
|
||||
section additive
|
||||
|
||||
definition is_add_homomorphism [class] [reducible] {G₁ G₂ : Type} [has_add G₁] [has_add G₂]
|
||||
(φ : G₁ → G₂) : Type :=
|
||||
Π(g h : G₁), φ (g + h) = φ g + φ h
|
||||
|
||||
variables {G₁ G₂ : Type} (φ : G₁ → G₂) [add_group G₁] [add_group G₂] [is_add_homomorphism φ]
|
||||
|
||||
definition respect_add /- φ -/ : Π(g h : G₁), φ (g + h) = φ g + φ h :=
|
||||
by assumption
|
||||
|
||||
theorem respect_zero /- φ -/ : φ 0 = 0 :=
|
||||
add.right_cancel
|
||||
(calc
|
||||
φ 0 + φ 0 = φ (0 + 0) : respect_add φ
|
||||
... = φ 0 : ap φ !zero_add
|
||||
... = 0 + φ 0 : zero_add)
|
||||
|
||||
theorem respect_neg /- φ -/ (g : G₁) : φ (-g) = -(φ g) :=
|
||||
eq_neg_of_add_eq_zero (!respect_add⁻¹ ⬝ ap φ !add.left_inv ⬝ !respect_zero)
|
||||
|
||||
end additive
|
||||
-/
|
||||
structure homomorphism (G₁ G₂ : Group) : Type :=
|
||||
(φ : G₁ → G₂)
|
||||
(p : is_mul_hom φ)
|
||||
|
||||
infix ` →g `:55 := homomorphism
|
||||
|
||||
definition group_fun [unfold 3] [coercion] := @homomorphism.φ
|
||||
definition homomorphism.struct [unfold 3] [instance] [priority 900] {G₁ G₂ : Group}
|
||||
(φ : G₁ →g G₂) : is_mul_hom φ :=
|
||||
homomorphism.p φ
|
||||
|
||||
definition homomorphism.mulstruct [instance] [priority 2000] {G₁ G₂ : Group} (φ : G₁ →g G₂)
|
||||
: is_mul_hom φ :=
|
||||
homomorphism.p φ
|
||||
|
||||
definition homomorphism.addstruct [instance] [priority 2000] {G₁ G₂ : AddGroup} (φ : G₁ →g G₂)
|
||||
: is_add_hom φ :=
|
||||
homomorphism.p φ
|
||||
|
||||
variables {G G₁ G₂ G₃ : Group} {g h : G₁} {ψ : G₂ →g G₃} {φ₁ φ₂ : G₁ →g G₂} (φ : G₁ →g G₂)
|
||||
|
||||
definition to_respect_mul /- φ -/ (g h : G₁) : φ (g * h) = φ g * φ h :=
|
||||
respect_mul φ g h
|
||||
|
||||
theorem to_respect_one /- φ -/ : φ 1 = 1 :=
|
||||
respect_one φ
|
||||
|
||||
theorem to_respect_inv /- φ -/ (g : G₁) : φ g⁻¹ = (φ g)⁻¹ :=
|
||||
respect_inv φ g
|
||||
|
||||
definition to_is_embedding_homomorphism /- φ -/ (H : Π{g}, φ g = 1 → g = 1) : is_embedding φ :=
|
||||
is_embedding_of_is_mul_hom φ @H
|
||||
|
||||
variables (G₁ G₂)
|
||||
definition is_set_homomorphism [instance] : is_set (G₁ →g G₂) :=
|
||||
begin
|
||||
have H : G₁ →g G₂ ≃ Σ(f : G₁ → G₂), Π(g₁ g₂ : G₁), f (g₁ * g₂) = f g₁ * f g₂,
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro φ, induction φ, constructor, exact (respect_mul φ)},
|
||||
{ intro v, induction v with f H, constructor, exact H},
|
||||
{ intro v, induction v, reflexivity},
|
||||
{ intro φ, induction φ, reflexivity}
|
||||
end,
|
||||
apply is_trunc_equiv_closed_rev, exact H
|
||||
end
|
||||
|
||||
variables {G₁ G₂}
|
||||
definition pmap_of_homomorphism [constructor] /- φ -/ : G₁ →* G₂ :=
|
||||
pmap.mk φ begin esimp, exact respect_one φ end
|
||||
|
||||
definition homomorphism_change_fun [constructor] {G₁ G₂ : Group}
|
||||
(φ : G₁ →g G₂) (f : G₁ → G₂) (p : φ ~ f) : G₁ →g G₂ :=
|
||||
homomorphism.mk f
|
||||
(λg h, (p (g * h))⁻¹ ⬝ to_respect_mul φ g h ⬝ ap011 mul (p g) (p h))
|
||||
|
||||
definition homomorphism_eq (p : group_fun φ₁ ~ group_fun φ₂) : φ₁ = φ₂ :=
|
||||
begin
|
||||
induction φ₁ with φ₁ q₁, induction φ₂ with φ₂ q₂, esimp at p, induction p,
|
||||
exact ap (homomorphism.mk φ₁) !is_prop.elim
|
||||
end
|
||||
|
||||
section additive
|
||||
variables {H₁ H₂ : AddGroup} (χ : H₁ →g H₂)
|
||||
definition to_respect_add /- χ -/ (g h : H₁) : χ (g + h) = χ g + χ h :=
|
||||
respect_add χ g h
|
||||
|
||||
theorem to_respect_zero /- χ -/ : χ 0 = 0 :=
|
||||
respect_zero χ
|
||||
|
||||
theorem to_respect_neg /- χ -/ (g : H₁) : χ (-g) = -(χ g) :=
|
||||
respect_neg χ g
|
||||
|
||||
end additive
|
||||
|
||||
section add_mul
|
||||
variables {H₁ : AddGroup} {H₂ : Group} (χ : H₁ →g H₂)
|
||||
definition to_respect_add_mul /- χ -/ (g h : H₁) : χ (g + h) = χ g * χ h :=
|
||||
to_respect_mul χ g h
|
||||
|
||||
theorem to_respect_zero_one /- χ -/ : χ 0 = 1 :=
|
||||
to_respect_one χ
|
||||
|
||||
theorem to_respect_neg_inv /- χ -/ (g : H₁) : χ (-g) = (χ g)⁻¹ :=
|
||||
to_respect_inv χ g
|
||||
|
||||
end add_mul
|
||||
|
||||
section mul_add
|
||||
variables {H₁ : Group} {H₂ : AddGroup} (χ : H₁ →g H₂)
|
||||
definition to_respect_mul_add /- χ -/ (g h : H₁) : χ (g * h) = χ g + χ h :=
|
||||
to_respect_mul χ g h
|
||||
|
||||
theorem to_respect_one_zero /- χ -/ : χ 1 = 0 :=
|
||||
to_respect_one χ
|
||||
|
||||
theorem to_respect_inv_neg /- χ -/ (g : H₁) : χ g⁻¹ = -(χ g) :=
|
||||
to_respect_inv χ g
|
||||
|
||||
end mul_add
|
||||
|
||||
/- categorical structure of groups + homomorphisms -/
|
||||
|
||||
definition homomorphism_compose [constructor] [trans] (ψ : G₂ →g G₃) (φ : G₁ →g G₂) : G₁ →g G₃ :=
|
||||
homomorphism.mk (ψ ∘ φ) (is_mul_hom_compose _ _)
|
||||
|
||||
variable (G)
|
||||
definition homomorphism_id [constructor] [refl] : G →g G :=
|
||||
homomorphism.mk (@id G) (is_mul_hom_id G)
|
||||
variable {G}
|
||||
|
||||
abbreviation gid [constructor] := @homomorphism_id
|
||||
infixr ` ∘g `:75 := homomorphism_compose
|
||||
notation 1 := homomorphism_id _
|
||||
|
||||
structure isomorphism (A B : Group) :=
|
||||
(to_hom : A →g B)
|
||||
(is_equiv_to_hom : is_equiv to_hom)
|
||||
|
||||
infix ` ≃g `:25 := isomorphism
|
||||
attribute isomorphism.to_hom [coercion]
|
||||
attribute isomorphism.is_equiv_to_hom [instance]
|
||||
attribute isomorphism._trans_of_to_hom [unfold 3]
|
||||
|
||||
definition equiv_of_isomorphism [constructor] (φ : G₁ ≃g G₂) : G₁ ≃ G₂ :=
|
||||
equiv.mk φ _
|
||||
|
||||
definition pequiv_of_isomorphism [constructor] (φ : G₁ ≃g G₂) :
|
||||
G₁ ≃* G₂ :=
|
||||
pequiv.mk φ begin esimp, exact _ end begin esimp, exact respect_one φ end
|
||||
|
||||
definition isomorphism_of_equiv [constructor] (φ : G₁ ≃ G₂)
|
||||
(p : Πg₁ g₂, φ (g₁ * g₂) = φ g₁ * φ g₂) : G₁ ≃g G₂ :=
|
||||
isomorphism.mk (homomorphism.mk φ p) !to_is_equiv
|
||||
|
||||
definition isomorphism_of_eq [constructor] {G₁ G₂ : Group} (φ : G₁ = G₂) : G₁ ≃g G₂ :=
|
||||
isomorphism_of_equiv (equiv_of_eq (ap Group.carrier φ))
|
||||
begin intros, induction φ, reflexivity end
|
||||
|
||||
definition pequiv_of_isomorphism_of_eq {G₁ G₂ : Group} (p : G₁ = G₂) :
|
||||
pequiv_of_isomorphism (isomorphism_of_eq p) = pequiv_of_eq (ap pType_of_Group p) :=
|
||||
begin
|
||||
induction p,
|
||||
apply pequiv_eq,
|
||||
fapply pmap_eq,
|
||||
{ intro g, reflexivity},
|
||||
{ apply is_prop.elim}
|
||||
end
|
||||
|
||||
definition to_ginv [constructor] (φ : G₁ ≃g G₂) : G₂ →g G₁ :=
|
||||
homomorphism.mk φ⁻¹
|
||||
abstract begin
|
||||
intro g₁ g₂, apply eq_of_fn_eq_fn' φ,
|
||||
rewrite [respect_mul φ, +right_inv φ]
|
||||
end end
|
||||
|
||||
variable (G)
|
||||
definition isomorphism.refl [refl] [constructor] : G ≃g G :=
|
||||
isomorphism.mk 1 !is_equiv_id
|
||||
variable {G}
|
||||
|
||||
definition isomorphism.symm [symm] [constructor] (φ : G₁ ≃g G₂) : G₂ ≃g G₁ :=
|
||||
isomorphism.mk (to_ginv φ) !is_equiv_inv
|
||||
|
||||
definition isomorphism.trans [trans] [constructor] (φ : G₁ ≃g G₂) (ψ : G₂ ≃g G₃) : G₁ ≃g G₃ :=
|
||||
isomorphism.mk (ψ ∘g φ) !is_equiv_compose
|
||||
|
||||
definition isomorphism.eq_trans [trans] [constructor]
|
||||
{G₁ G₂ : Group} {G₃ : Group} (φ : G₁ = G₂) (ψ : G₂ ≃g G₃) : G₁ ≃g G₃ :=
|
||||
proof isomorphism.trans (isomorphism_of_eq φ) ψ qed
|
||||
|
||||
definition isomorphism.trans_eq [trans] [constructor]
|
||||
{G₁ : Group} {G₂ G₃ : Group} (φ : G₁ ≃g G₂) (ψ : G₂ = G₃) : G₁ ≃g G₃ :=
|
||||
isomorphism.trans φ (isomorphism_of_eq ψ)
|
||||
|
||||
postfix `⁻¹ᵍ`:(max + 1) := isomorphism.symm
|
||||
infixl ` ⬝g `:75 := isomorphism.trans
|
||||
infixl ` ⬝gp `:75 := isomorphism.trans_eq
|
||||
infixl ` ⬝pg `:75 := isomorphism.eq_trans
|
||||
|
||||
definition pmap_of_isomorphism [constructor] (φ : G₁ ≃g G₂) :
|
||||
G₁ →* G₂ :=
|
||||
pequiv_of_isomorphism φ
|
||||
|
||||
/- category of groups -/
|
||||
|
||||
section
|
||||
open category
|
||||
definition precategory_group [constructor] : precategory Group :=
|
||||
precategory.mk homomorphism
|
||||
@homomorphism_compose
|
||||
@homomorphism_id
|
||||
(λG₁ G₂ G₃ G₄ φ₃ φ₂ φ₁, homomorphism_eq (λg, idp))
|
||||
(λG₁ G₂ φ, homomorphism_eq (λg, idp))
|
||||
(λG₁ G₂ φ, homomorphism_eq (λg, idp))
|
||||
end
|
||||
|
||||
-- TODO
|
||||
-- definition category_group : category Group :=
|
||||
-- category.mk precategory_group
|
||||
-- begin
|
||||
-- intro G₁ G₂,
|
||||
-- fapply adjointify,
|
||||
-- { intro φ, fapply Group_eq, },
|
||||
-- { },
|
||||
-- { }
|
||||
-- end
|
||||
|
||||
/- given an equivalence A ≃ B we can transport a group structure on A to a group structure on B -/
|
||||
|
||||
section
|
||||
|
||||
parameters {A B : Type} (f : A ≃ B) [group A]
|
||||
|
||||
definition group_equiv_mul (b b' : B) : B := f (f⁻¹ᶠ b * f⁻¹ᶠ b')
|
||||
|
||||
definition group_equiv_one : B := f one
|
||||
|
||||
definition group_equiv_inv (b : B) : B := f (f⁻¹ᶠ b)⁻¹
|
||||
|
||||
local infix * := group_equiv_mul
|
||||
local postfix ^ := group_equiv_inv
|
||||
local notation 1 := group_equiv_one
|
||||
|
||||
theorem group_equiv_mul_assoc (b₁ b₂ b₃ : B) : (b₁ * b₂) * b₃ = b₁ * (b₂ * b₃) :=
|
||||
by rewrite [↑group_equiv_mul, +left_inv f, mul.assoc]
|
||||
|
||||
theorem group_equiv_one_mul (b : B) : 1 * b = b :=
|
||||
by rewrite [↑group_equiv_mul, ↑group_equiv_one, left_inv f, one_mul, right_inv f]
|
||||
|
||||
theorem group_equiv_mul_one (b : B) : b * 1 = b :=
|
||||
by rewrite [↑group_equiv_mul, ↑group_equiv_one, left_inv f, mul_one, right_inv f]
|
||||
|
||||
theorem group_equiv_mul_left_inv (b : B) : b^ * b = 1 :=
|
||||
by rewrite [↑group_equiv_mul, ↑group_equiv_one, ↑group_equiv_inv,
|
||||
+left_inv f, mul.left_inv]
|
||||
|
||||
definition group_equiv_closed : group B :=
|
||||
⦃group,
|
||||
mul := group_equiv_mul,
|
||||
mul_assoc := group_equiv_mul_assoc,
|
||||
one := group_equiv_one,
|
||||
one_mul := group_equiv_one_mul,
|
||||
mul_one := group_equiv_mul_one,
|
||||
inv := group_equiv_inv,
|
||||
mul_left_inv := group_equiv_mul_left_inv,
|
||||
is_set_carrier := is_trunc_equiv_closed 0 f⦄
|
||||
|
||||
end
|
||||
|
||||
variable (G)
|
||||
|
||||
/- the trivial group -/
|
||||
open unit
|
||||
definition trivial_group [constructor] : group unit :=
|
||||
group.mk _ (λx y, star) (λx y z, idp) star (unit.rec idp) (unit.rec idp) (λx, star) (λx, idp)
|
||||
|
||||
definition Trivial_group [constructor] : Group :=
|
||||
Group.mk _ trivial_group
|
||||
|
||||
abbreviation G0 := Trivial_group
|
||||
|
||||
definition trivial_group_of_is_contr [H : is_contr G] : G ≃g G0 :=
|
||||
begin
|
||||
fapply isomorphism_of_equiv,
|
||||
{ apply equiv_unit_of_is_contr},
|
||||
{ intros, reflexivity}
|
||||
end
|
||||
|
||||
variable {G}
|
||||
|
||||
/-
|
||||
A group where the point in the pointed type corresponds with 1 in the group.
|
||||
We need this structure when we are given a pointed type, and want to say that there is a group
|
||||
structure on it which is compatible with the point. This is used in chain complexes.
|
||||
-/
|
||||
structure pgroup [class] (X : Type*) extends semigroup X, has_inv X :=
|
||||
(pt_mul : Πa, mul pt a = a)
|
||||
(mul_pt : Πa, mul a pt = a)
|
||||
(mul_left_inv_pt : Πa, mul (inv a) a = pt)
|
||||
|
||||
definition group_of_pgroup [reducible] [instance] (X : Type*) [H : pgroup X]
|
||||
: group X :=
|
||||
⦃group, H,
|
||||
one := pt,
|
||||
one_mul := pgroup.pt_mul ,
|
||||
mul_one := pgroup.mul_pt,
|
||||
mul_left_inv := pgroup.mul_left_inv_pt⦄
|
||||
|
||||
definition pgroup_of_group (X : Type*) [H : group X] (p : one = pt :> X) : pgroup X :=
|
||||
begin
|
||||
cases X with X x, esimp at *, induction p,
|
||||
exact ⦃pgroup, H,
|
||||
pt_mul := one_mul,
|
||||
mul_pt := mul_one,
|
||||
mul_left_inv_pt := mul.left_inv⦄
|
||||
end
|
||||
|
||||
definition Group_of_pgroup (G : Type*) [pgroup G] : Group :=
|
||||
Group.mk G _
|
||||
|
||||
definition pgroup_Group [instance] (G : Group) : pgroup G :=
|
||||
⦃ pgroup, Group.struct G,
|
||||
pt_mul := one_mul,
|
||||
mul_pt := mul_one,
|
||||
mul_left_inv_pt := mul.left_inv ⦄
|
||||
|
||||
-- infinity pgroups
|
||||
|
||||
structure inf_pgroup [class] (X : Type*) extends inf_semigroup X, has_inv X :=
|
||||
(pt_mul : Πa, mul pt a = a)
|
||||
(mul_pt : Πa, mul a pt = a)
|
||||
(mul_left_inv_pt : Πa, mul (inv a) a = pt)
|
||||
|
||||
definition inf_group_of_inf_pgroup [reducible] [instance] (X : Type*) [H : inf_pgroup X]
|
||||
: inf_group X :=
|
||||
⦃inf_group, H,
|
||||
one := pt,
|
||||
one_mul := inf_pgroup.pt_mul ,
|
||||
mul_one := inf_pgroup.mul_pt,
|
||||
mul_left_inv := inf_pgroup.mul_left_inv_pt⦄
|
||||
|
||||
definition inf_pgroup_of_inf_group (X : Type*) [H : inf_group X] (p : one = pt :> X) : inf_pgroup X :=
|
||||
begin
|
||||
cases X with X x, esimp at *, induction p,
|
||||
exact ⦃inf_pgroup, H,
|
||||
pt_mul := one_mul,
|
||||
mul_pt := mul_one,
|
||||
mul_left_inv_pt := mul.left_inv⦄
|
||||
end
|
||||
|
||||
definition inf_Group_of_inf_pgroup (G : Type*) [inf_pgroup G] : InfGroup :=
|
||||
InfGroup.mk G _
|
||||
|
||||
definition inf_pgroup_InfGroup [instance] (G : InfGroup) : inf_pgroup G :=
|
||||
⦃ inf_pgroup, InfGroup.struct G,
|
||||
pt_mul := one_mul,
|
||||
mul_pt := mul_one,
|
||||
mul_left_inv_pt := mul.left_inv ⦄
|
||||
|
||||
/- equality of groups and abelian groups -/
|
||||
|
||||
definition group.to_has_mul {A : Type} (H : group A) : has_mul A := _
|
||||
definition group.to_has_inv {A : Type} (H : group A) : has_inv A := _
|
||||
definition group.to_has_one {A : Type} (H : group A) : has_one A := _
|
||||
local attribute group.to_has_mul group.to_has_inv [coercion]
|
||||
|
||||
universe variable l
|
||||
variables {A B : Type.{l}}
|
||||
definition group_eq {G H : group A} (same_mul' : Π(g h : A), @mul A G g h = @mul A H g h)
|
||||
: G = H :=
|
||||
begin
|
||||
have foo : Π(g : A), @inv A G g = (@inv A G g * g) * @inv A H g,
|
||||
from λg, !mul_inv_cancel_right⁻¹,
|
||||
cases G with Gs Gm Gh1 G1 Gh2 Gh3 Gi Gh4,
|
||||
cases H with Hs Hm Hh1 H1 Hh2 Hh3 Hi Hh4,
|
||||
have same_mul : Gm = Hm, from eq_of_homotopy2 same_mul',
|
||||
cases same_mul,
|
||||
have same_one : G1 = H1, from calc
|
||||
G1 = Hm G1 H1 : Hh3
|
||||
... = H1 : Gh2,
|
||||
have same_inv : Gi = Hi, from eq_of_homotopy (take g, calc
|
||||
Gi g = Hm (Hm (Gi g) g) (Hi g) : foo
|
||||
... = Hm G1 (Hi g) : by rewrite Gh4
|
||||
... = Hi g : Gh2),
|
||||
cases same_one, cases same_inv,
|
||||
have ps : Gs = Hs, from !is_prop.elim,
|
||||
have ph1 : Gh1 = Hh1, from !is_prop.elim,
|
||||
have ph2 : Gh2 = Hh2, from !is_prop.elim,
|
||||
have ph3 : Gh3 = Hh3, from !is_prop.elim,
|
||||
have ph4 : Gh4 = Hh4, from !is_prop.elim,
|
||||
cases ps, cases ph1, cases ph2, cases ph3, cases ph4, reflexivity
|
||||
end
|
||||
|
||||
definition group_pathover {G : group A} {H : group B} {p : A = B}
|
||||
(resp_mul : Π(g h : A), cast p (g * h) = cast p g * cast p h) : G =[p] H :=
|
||||
begin
|
||||
induction p,
|
||||
apply pathover_idp_of_eq, exact group_eq (resp_mul)
|
||||
end
|
||||
|
||||
definition Group_eq_of_eq {G H : Group} (p : Group.carrier G = Group.carrier H)
|
||||
(resp_mul : Π(g h : G), cast p (g * h) = cast p g * cast p h) : G = H :=
|
||||
begin
|
||||
cases G with Gc G, cases H with Hc H,
|
||||
apply (apd011 Group.mk p),
|
||||
exact group_pathover resp_mul
|
||||
end
|
||||
|
||||
definition Group_eq {G H : Group} (f : Group.carrier G ≃ Group.carrier H)
|
||||
(resp_mul : Π(g h : G), f (g * h) = f g * f h) : G = H :=
|
||||
Group_eq_of_eq (ua f) (λg h, !cast_ua ⬝ resp_mul g h ⬝ ap011 mul !cast_ua⁻¹ !cast_ua⁻¹)
|
||||
|
||||
definition eq_of_isomorphism {G₁ G₂ : Group} (φ : G₁ ≃g G₂) : G₁ = G₂ :=
|
||||
Group_eq (equiv_of_isomorphism φ) (respect_mul φ)
|
||||
|
||||
definition ab_group.to_has_mul {A : Type} (H : ab_group A) : has_mul A := _
|
||||
local attribute ab_group.to_has_mul [coercion]
|
||||
|
||||
definition ab_group_eq {A : Type} {G H : ab_group A}
|
||||
(same_mul : Π(g h : A), @mul A G g h = @mul A H g h)
|
||||
: G = H :=
|
||||
begin
|
||||
have g_eq : @ab_group.to_group A G = @ab_group.to_group A H, from group_eq same_mul,
|
||||
cases G with Gs Gm Gh1 G1 Gh2 Gh3 Gi Gh4 Gh5,
|
||||
cases H with Hs Hm Hh1 H1 Hh2 Hh3 Hi Hh4 Hh5,
|
||||
have pm : Gm = Hm, from ap (@mul _ ∘ group.to_has_mul) g_eq,
|
||||
have pi : Gi = Hi, from ap (@inv _ ∘ group.to_has_inv) g_eq,
|
||||
have p1 : G1 = H1, from ap (@one _ ∘ group.to_has_one) g_eq,
|
||||
induction pm, induction pi, induction p1,
|
||||
have ps : Gs = Hs, from !is_prop.elim,
|
||||
have ph1 : Gh1 = Hh1, from !is_prop.elim,
|
||||
have ph2 : Gh2 = Hh2, from !is_prop.elim,
|
||||
have ph3 : Gh3 = Hh3, from !is_prop.elim,
|
||||
have ph4 : Gh4 = Hh4, from !is_prop.elim,
|
||||
have ph5 : Gh5 = Hh5, from !is_prop.elim,
|
||||
induction ps, induction ph1, induction ph2, induction ph3, induction ph4, induction ph5,
|
||||
reflexivity
|
||||
end
|
||||
|
||||
definition ab_group_pathover {A B : Type} {G : ab_group A} {H : ab_group B} {p : A = B}
|
||||
(resp_mul : Π(g h : A), cast p (g * h) = cast p g * cast p h) : G =[p] H :=
|
||||
begin
|
||||
induction p,
|
||||
apply pathover_idp_of_eq, exact ab_group_eq (resp_mul)
|
||||
end
|
||||
|
||||
definition AbGroup_eq_of_isomorphism {G₁ G₂ : AbGroup} (φ : G₁ ≃g G₂) : G₁ = G₂ :=
|
||||
begin
|
||||
induction G₁, induction G₂,
|
||||
apply apd011 AbGroup.mk (ua (equiv_of_isomorphism φ)),
|
||||
apply ab_group_pathover,
|
||||
intro g h, exact !cast_ua ⬝ respect_mul φ g h ⬝ ap011 mul !cast_ua⁻¹ !cast_ua⁻¹
|
||||
end
|
||||
|
||||
definition trivial_group_of_is_contr' (G : Group) [H : is_contr G] : G = G0 :=
|
||||
eq_of_isomorphism (trivial_group_of_is_contr G)
|
||||
|
||||
|
||||
end group
|
||||
|
|
@ -1,162 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jeremy Avigad
|
||||
|
||||
Homomorphisms between structures.
|
||||
-/
|
||||
import algebra.ring algebra.category.category
|
||||
open eq function is_trunc
|
||||
|
||||
namespace algebra
|
||||
|
||||
/- additive structures -/
|
||||
|
||||
variables {A B C : Type}
|
||||
|
||||
definition is_add_hom [class] [has_add A] [has_add B] (f : A → B) : Type :=
|
||||
∀ a₁ a₂, f (a₁ + a₂) = f a₁ + f a₂
|
||||
|
||||
definition respect_add [has_add A] [has_add B] (f : A → B) [H : is_add_hom f] (a₁ a₂ : A) :
|
||||
f (a₁ + a₂) = f a₁ + f a₂ := H a₁ a₂
|
||||
|
||||
definition is_prop_is_add_hom [instance] [has_add A] [has_add B] [is_set B] (f : A → B) :
|
||||
is_prop (is_add_hom f) :=
|
||||
by unfold is_add_hom; apply _
|
||||
|
||||
definition is_add_hom_id (A : Type) [has_add A] : is_add_hom (@id A) :=
|
||||
take a₁ a₂, rfl
|
||||
|
||||
definition is_add_hom_compose [has_add A] [has_add B] [has_add C]
|
||||
(f : B → C) (g : A → B) [is_add_hom f] [is_add_hom g] : is_add_hom (f ∘ g) :=
|
||||
take a₁ a₂, begin esimp, rewrite [respect_add g, respect_add f] end
|
||||
|
||||
section add_group_A_B
|
||||
variables [add_group A] [add_group B]
|
||||
|
||||
definition respect_zero (f : A → B) [is_add_hom f] :
|
||||
f (0 : A) = 0 :=
|
||||
have f 0 + f 0 = f 0 + 0, by rewrite [-respect_add f, +add_zero],
|
||||
eq_of_add_eq_add_left this
|
||||
|
||||
definition respect_neg (f : A → B) [is_add_hom f] (a : A) :
|
||||
f (- a) = - f a :=
|
||||
have f (- a) + f a = 0, by rewrite [-respect_add f, add.left_inv, respect_zero f],
|
||||
eq_neg_of_add_eq_zero this
|
||||
|
||||
definition respect_sub (f : A → B) [is_add_hom f] (a₁ a₂ : A) :
|
||||
f (a₁ - a₂) = f a₁ - f a₂ :=
|
||||
by rewrite [*sub_eq_add_neg, *(respect_add f), (respect_neg f)]
|
||||
|
||||
definition is_embedding_of_is_add_hom [add_group B] (f : A → B) [is_add_hom f]
|
||||
(H : ∀ x, f x = 0 → x = 0) :
|
||||
is_embedding f :=
|
||||
is_embedding_of_is_injective
|
||||
(take x₁ x₂,
|
||||
suppose f x₁ = f x₂,
|
||||
have f (x₁ - x₂) = 0, by rewrite [respect_sub f, this, sub_self],
|
||||
have x₁ - x₂ = 0, from H _ this,
|
||||
eq_of_sub_eq_zero this)
|
||||
|
||||
definition eq_zero_of_is_add_hom [add_group B] {f : A → B} [is_add_hom f]
|
||||
[is_embedding f] {a : A} (fa0 : f a = 0) :
|
||||
a = 0 :=
|
||||
have f a = f 0, by rewrite [fa0, respect_zero f],
|
||||
show a = 0, from is_injective_of_is_embedding this
|
||||
end add_group_A_B
|
||||
|
||||
/- multiplicative structures -/
|
||||
|
||||
definition is_mul_hom [class] [has_mul A] [has_mul B] (f : A → B) : Type :=
|
||||
∀ a₁ a₂, f (a₁ * a₂) = f a₁ * f a₂
|
||||
|
||||
definition respect_mul [has_mul A] [has_mul B] (f : A → B) [H : is_mul_hom f] (a₁ a₂ : A) :
|
||||
f (a₁ * a₂) = f a₁ * f a₂ := H a₁ a₂
|
||||
|
||||
definition is_prop_is_mul_hom [instance] [has_mul A] [has_mul B] [is_set B] (f : A → B) :
|
||||
is_prop (is_mul_hom f) :=
|
||||
begin unfold is_mul_hom, apply _ end
|
||||
|
||||
definition is_mul_hom_id (A : Type) [has_mul A] : is_mul_hom (@id A) :=
|
||||
take a₁ a₂, rfl
|
||||
|
||||
definition is_mul_hom_compose [has_mul A] [has_mul B] [has_mul C]
|
||||
(f : B → C) (g : A → B) [is_mul_hom f] [is_mul_hom g] : is_mul_hom (f ∘ g) :=
|
||||
take a₁ a₂, begin esimp, rewrite [respect_mul g, respect_mul f] end
|
||||
|
||||
section group_A_B
|
||||
variables [group A] [group B]
|
||||
|
||||
definition respect_one (f : A → B) [is_mul_hom f] :
|
||||
f (1 : A) = 1 :=
|
||||
have f 1 * f 1 = f 1 * 1, by rewrite [-respect_mul f, *mul_one],
|
||||
eq_of_mul_eq_mul_left' this
|
||||
|
||||
definition respect_inv (f : A → B) [is_mul_hom f] (a : A) :
|
||||
f (a⁻¹) = (f a)⁻¹ :=
|
||||
have f (a⁻¹) * f a = 1, by rewrite [-respect_mul f, mul.left_inv, respect_one f],
|
||||
eq_inv_of_mul_eq_one this
|
||||
|
||||
definition is_embedding_of_is_mul_hom [group B] (f : A → B) [is_mul_hom f]
|
||||
(H : ∀ x, f x = 1 → x = 1) :
|
||||
is_embedding f :=
|
||||
is_embedding_of_is_injective
|
||||
(take x₁ x₂,
|
||||
suppose f x₁ = f x₂,
|
||||
have f (x₁ * x₂⁻¹) = 1, by rewrite [respect_mul f, respect_inv f, this, mul.right_inv],
|
||||
have x₁ * x₂⁻¹ = 1, from H _ this,
|
||||
eq_of_mul_inv_eq_one this)
|
||||
|
||||
definition eq_one_of_is_mul_hom [add_group B] {f : A → B} [is_mul_hom f]
|
||||
[is_embedding f] {a : A} (fa1 : f a = 1) :
|
||||
a = 1 :=
|
||||
have f a = f 1, by rewrite [fa1, respect_one f],
|
||||
show a = 1, from is_injective_of_is_embedding this
|
||||
end group_A_B
|
||||
|
||||
/- rings -/
|
||||
|
||||
definition is_ring_hom [class] {R₁ R₂ : Type} [semiring R₁] [semiring R₂] (f : R₁ → R₂) :=
|
||||
is_add_hom f × is_mul_hom f × f 1 = 1
|
||||
|
||||
definition is_ring_hom.mk {R₁ R₂ : Type} [semiring R₁] [semiring R₂] (f : R₁ → R₂)
|
||||
(h₁ : is_add_hom f) (h₂ : is_mul_hom f) (h₃ : f 1 = 1) : is_ring_hom f :=
|
||||
pair h₁ (pair h₂ h₃)
|
||||
|
||||
definition is_add_hom_of_is_ring_hom [instance] {R₁ R₂ : Type} [semiring R₁] [semiring R₂]
|
||||
(f : R₁ → R₂) [H : is_ring_hom f] : is_add_hom f :=
|
||||
prod.pr1 H
|
||||
|
||||
definition is_mul_hom_of_is_ring_hom [instance] {R₁ R₂ : Type} [semiring R₁] [semiring R₂]
|
||||
(f : R₁ → R₂) [H : is_ring_hom f] : is_mul_hom f :=
|
||||
prod.pr1 (prod.pr2 H)
|
||||
|
||||
definition is_ring_hom.respect_one {R₁ R₂ : Type} [semiring R₁] [semiring R₂]
|
||||
(f : R₁ → R₂) [H : is_ring_hom f] : f 1 = 1 :=
|
||||
prod.pr2 (prod.pr2 H)
|
||||
|
||||
definition is_prop_is_ring_hom [instance] {R₁ R₂ : Type} [semiring R₁] [semiring R₂] (f : R₁ → R₂) :
|
||||
is_prop (is_ring_hom f) :=
|
||||
have h₁ : is_prop (is_add_hom f), from _,
|
||||
have h₂ : is_prop (is_mul_hom f), from _,
|
||||
have h₃ : is_prop (f 1 = 1), from _,
|
||||
begin unfold is_ring_hom, apply _ end
|
||||
|
||||
section semiring
|
||||
variables {R₁ R₂ R₃ : Type} [semiring R₁] [semiring R₂] [semiring R₃]
|
||||
variables (g : R₂ → R₃) (f : R₁ → R₂) [is_ring_hom g] [is_ring_hom f]
|
||||
|
||||
definition is_ring_hom_id : is_ring_hom (@id R₁) :=
|
||||
is_ring_hom.mk id (λ a₁ a₂, rfl) (λ a₁ a₂, rfl) rfl
|
||||
|
||||
definition is_ring_hom_comp : is_ring_hom (g ∘ f) :=
|
||||
is_ring_hom.mk _
|
||||
(take a₁ a₂, begin esimp, rewrite [respect_add f, respect_add g] end)
|
||||
(take r a, by esimp; rewrite [respect_mul f, respect_mul g])
|
||||
(by esimp; rewrite *is_ring_hom.respect_one)
|
||||
|
||||
definition respect_mul_add_mul (a b c d : R₁) : f (a * b + c * d) = f a * f b + f c * f d :=
|
||||
by rewrite [respect_add f, +(respect_mul f)]
|
||||
end semiring
|
||||
|
||||
end algebra
|
||||
|
|
@ -1,271 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
homotopy groups of a pointed space
|
||||
-/
|
||||
|
||||
import .trunc_group types.trunc .group_theory types.nat.hott
|
||||
|
||||
open nat eq pointed trunc is_trunc algebra group function equiv unit is_equiv nat
|
||||
|
||||
-- TODO: consistently make n an argument before A
|
||||
-- TODO: rename cghomotopy_group to aghomotopy_group
|
||||
-- TODO: rename homotopy_group_functor_compose to homotopy_group_functor_pcompose
|
||||
namespace eq
|
||||
|
||||
definition inf_pgroup_loop [constructor] [instance] (A : Type*) : inf_pgroup (Ω A) :=
|
||||
inf_pgroup.mk concat con.assoc inverse idp_con con_idp con.left_inv
|
||||
|
||||
definition inf_group_loop [constructor] (A : Type*) : inf_group (Ω A) := _
|
||||
|
||||
definition ab_inf_group_loop [constructor] [instance] (A : Type*) : ab_inf_group (Ω (Ω A)) :=
|
||||
⦃ab_inf_group, inf_group_loop _, mul_comm := eckmann_hilton⦄
|
||||
|
||||
definition gloop [constructor] (A : Type*) : InfGroup :=
|
||||
InfGroup.mk (Ω A) (inf_group_loop A)
|
||||
|
||||
definition homotopy_group [reducible] [constructor] (n : ℕ) (A : Type*) : Set* :=
|
||||
ptrunc 0 (Ω[n] A)
|
||||
|
||||
notation `π[`:95 n:0 `]`:0 := homotopy_group n
|
||||
|
||||
definition group_homotopy_group [instance] [constructor] [reducible] (n : ℕ) (A : Type*)
|
||||
: group (π[succ n] A) :=
|
||||
trunc_group (Ω[succ n] A)
|
||||
|
||||
definition group_homotopy_group2 [instance] (k : ℕ) (A : Type*) :
|
||||
group (carrier (ptrunctype.to_pType (π[k + 1] A))) :=
|
||||
group_homotopy_group k A
|
||||
|
||||
definition ab_group_homotopy_group [constructor] [reducible] (n : ℕ) (A : Type*)
|
||||
: ab_group (π[succ (succ n)] A) :=
|
||||
trunc_ab_group (Ω[succ (succ n)] A)
|
||||
|
||||
local attribute ab_group_homotopy_group [instance]
|
||||
|
||||
definition ghomotopy_group [constructor] : Π(n : ℕ) [is_succ n] (A : Type*), Group
|
||||
| (succ n) x A := Group.mk (π[succ n] A) _
|
||||
|
||||
definition cghomotopy_group [constructor] :
|
||||
Π(n : ℕ) [is_at_least_two n] (A : Type*), AbGroup
|
||||
| (succ (succ n)) x A := AbGroup.mk (π[succ (succ n)] A) _
|
||||
|
||||
definition fundamental_group [constructor] (A : Type*) : Group :=
|
||||
ghomotopy_group 1 A
|
||||
|
||||
notation `πg[`:95 n:0 `]`:0 := ghomotopy_group n
|
||||
notation `πag[`:95 n:0 `]`:0 := cghomotopy_group n
|
||||
|
||||
notation `π₁` := fundamental_group -- should this be notation for the group or pointed type?
|
||||
|
||||
definition tr_mul_tr {n : ℕ} {A : Type*} (p q : Ω[n + 1] A) :
|
||||
tr p *[πg[n+1] A] tr q = tr (p ⬝ q) :=
|
||||
by reflexivity
|
||||
|
||||
definition tr_mul_tr' {n : ℕ} {A : Type*} (p q : Ω[succ n] A)
|
||||
: tr p *[π[succ n] A] tr q = tr (p ⬝ q) :=
|
||||
idp
|
||||
|
||||
definition homotopy_group_pequiv [constructor] (n : ℕ) {A B : Type*} (H : A ≃* B)
|
||||
: π[n] A ≃* π[n] B :=
|
||||
ptrunc_pequiv_ptrunc 0 (loopn_pequiv_loopn n H)
|
||||
|
||||
definition homotopy_group_pequiv_loop_ptrunc [constructor] (k : ℕ) (A : Type*) :
|
||||
π[k] A ≃* Ω[k] (ptrunc k A) :=
|
||||
begin
|
||||
refine !loopn_ptrunc_pequiv⁻¹ᵉ* ⬝e* _,
|
||||
exact loopn_pequiv_loopn k (pequiv_of_eq begin rewrite [trunc_index.zero_add] end)
|
||||
end
|
||||
|
||||
open trunc_index
|
||||
definition homotopy_group_ptrunc_of_le [constructor] {k n : ℕ} (H : k ≤ n) (A : Type*) :
|
||||
π[k] (ptrunc n A) ≃* π[k] A :=
|
||||
calc
|
||||
π[k] (ptrunc n A) ≃* Ω[k] (ptrunc k (ptrunc n A))
|
||||
: homotopy_group_pequiv_loop_ptrunc k (ptrunc n A)
|
||||
... ≃* Ω[k] (ptrunc k A)
|
||||
: loopn_pequiv_loopn k (ptrunc_ptrunc_pequiv_left A (of_nat_le_of_nat H))
|
||||
... ≃* π[k] A : (homotopy_group_pequiv_loop_ptrunc k A)⁻¹ᵉ*
|
||||
|
||||
definition homotopy_group_ptrunc [constructor] (k : ℕ) (A : Type*) :
|
||||
π[k] (ptrunc k A) ≃* π[k] A :=
|
||||
homotopy_group_ptrunc_of_le (le.refl k) A
|
||||
|
||||
theorem trivial_homotopy_of_is_set (A : Type*) [H : is_set A] (n : ℕ) : πg[n+1] A ≃g G0 :=
|
||||
begin
|
||||
apply trivial_group_of_is_contr,
|
||||
apply is_trunc_trunc_of_is_trunc,
|
||||
apply is_contr_loop_of_is_trunc,
|
||||
apply is_trunc_succ_succ_of_is_set
|
||||
end
|
||||
|
||||
definition homotopy_group_succ_out (A : Type*) (n : ℕ) : π[n + 1] A = π₁ (Ω[n] A) := idp
|
||||
|
||||
definition homotopy_group_succ_in (A : Type*) (n : ℕ) : π[n + 1] A ≃* π[n] (Ω A) :=
|
||||
ptrunc_pequiv_ptrunc 0 (loopn_succ_in A n)
|
||||
|
||||
definition ghomotopy_group_succ_out (A : Type*) (n : ℕ) : πg[n + 1] A = π₁ (Ω[n] A) := idp
|
||||
|
||||
definition homotopy_group_succ_in_con {A : Type*} {n : ℕ} (g h : πg[n + 2] A) :
|
||||
homotopy_group_succ_in A (succ n) (g * h) =
|
||||
homotopy_group_succ_in A (succ n) g * homotopy_group_succ_in A (succ n) h :=
|
||||
begin
|
||||
induction g with p, induction h with q, esimp,
|
||||
apply ap tr, apply loopn_succ_in_con
|
||||
end
|
||||
|
||||
definition ghomotopy_group_succ_in [constructor] (A : Type*) (n : ℕ) :
|
||||
πg[n + 2] A ≃g πg[n + 1] (Ω A) :=
|
||||
begin
|
||||
fapply isomorphism_of_equiv,
|
||||
{ exact homotopy_group_succ_in A (succ n)},
|
||||
{ exact homotopy_group_succ_in_con},
|
||||
end
|
||||
|
||||
definition homotopy_group_functor [constructor] (n : ℕ) {A B : Type*} (f : A →* B)
|
||||
: π[n] A →* π[n] B :=
|
||||
ptrunc_functor 0 (apn n f)
|
||||
|
||||
notation `π→[`:95 n:0 `]`:0 := homotopy_group_functor n
|
||||
|
||||
definition homotopy_group_functor_phomotopy [constructor] (n : ℕ) {A B : Type*} {f g : A →* B}
|
||||
(p : f ~* g) : π→[n] f ~* π→[n] g :=
|
||||
ptrunc_functor_phomotopy 0 (apn_phomotopy n p)
|
||||
|
||||
definition homotopy_group_functor_pid (n : ℕ) (A : Type*) : π→[n] (pid A) ~* pid (π[n] A) :=
|
||||
ptrunc_functor_phomotopy 0 !apn_pid ⬝* !ptrunc_functor_pid
|
||||
|
||||
definition homotopy_group_functor_compose [constructor] (n : ℕ) {A B C : Type*} (g : B →* C)
|
||||
(f : A →* B) : π→[n] (g ∘* f) ~* π→[n] g ∘* π→[n] f :=
|
||||
ptrunc_functor_phomotopy 0 !apn_pcompose ⬝* !ptrunc_functor_pcompose
|
||||
|
||||
definition is_equiv_homotopy_group_functor [constructor] (n : ℕ) {A B : Type*} (f : A →* B)
|
||||
[is_equiv f] : is_equiv (π→[n] f) :=
|
||||
@(is_equiv_trunc_functor 0 _) !is_equiv_apn
|
||||
|
||||
definition homotopy_group_functor_succ_phomotopy_in (n : ℕ) {A B : Type*} (f : A →* B) :
|
||||
homotopy_group_succ_in B n ∘* π→[n + 1] f ~*
|
||||
π→[n] (Ω→ f) ∘* homotopy_group_succ_in A n :=
|
||||
begin
|
||||
refine !ptrunc_functor_pcompose⁻¹* ⬝* _ ⬝* !ptrunc_functor_pcompose,
|
||||
exact ptrunc_functor_phomotopy 0 (apn_succ_phomotopy_in n f)
|
||||
end
|
||||
|
||||
definition is_equiv_homotopy_group_functor_ap1 (n : ℕ) {A B : Type*} (f : A →* B)
|
||||
[is_equiv (π→[n + 1] f)] : is_equiv (π→[n] (Ω→ f)) :=
|
||||
have is_equiv (homotopy_group_succ_in B n ∘* π→[n + 1] f),
|
||||
from is_equiv_compose _ (π→[n + 1] f),
|
||||
have is_equiv (π→[n] (Ω→ f) ∘ homotopy_group_succ_in A n),
|
||||
from is_equiv.homotopy_closed _ (homotopy_group_functor_succ_phomotopy_in n f),
|
||||
is_equiv.cancel_right (homotopy_group_succ_in A n) _
|
||||
|
||||
definition tinverse [constructor] {X : Type*} : π[1] X →* π[1] X :=
|
||||
ptrunc_functor 0 pinverse
|
||||
|
||||
definition is_equiv_tinverse [constructor] (A : Type*) : is_equiv (@tinverse A) :=
|
||||
by apply @is_equiv_trunc_functor; apply is_equiv_eq_inverse
|
||||
|
||||
definition ptrunc_functor_pinverse [constructor] {X : Type*}
|
||||
: ptrunc_functor 0 (@pinverse X) ~* @tinverse X :=
|
||||
begin
|
||||
fapply phomotopy.mk,
|
||||
{ reflexivity},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition homotopy_group_functor_mul [constructor] (n : ℕ) {A B : Type*} (g : A →* B)
|
||||
(p q : πg[n+1] A) :
|
||||
(π→[n + 1] g) (p *[πg[n+1] A] q) = (π→[n+1] g) p *[πg[n+1] B] (π→[n + 1] g) q :=
|
||||
begin
|
||||
unfold [ghomotopy_group, homotopy_group] at *,
|
||||
refine @trunc.rec _ _ _ (λq, !is_trunc_eq) _ p, clear p, intro p,
|
||||
refine @trunc.rec _ _ _ (λq, !is_trunc_eq) _ q, clear q, intro q,
|
||||
apply ap tr, apply apn_con
|
||||
end
|
||||
|
||||
definition homotopy_group_homomorphism [constructor] (n : ℕ) [H : is_succ n] {A B : Type*}
|
||||
(f : A →* B) : πg[n] A →g πg[n] B :=
|
||||
begin
|
||||
induction H with n, fconstructor,
|
||||
{ exact homotopy_group_functor (n+1) f},
|
||||
{ apply homotopy_group_functor_mul}
|
||||
end
|
||||
|
||||
notation `π→g[`:95 n:0 `]`:0 := homotopy_group_homomorphism n
|
||||
|
||||
definition homotopy_group_isomorphism_of_pequiv [constructor] (n : ℕ) {A B : Type*} (f : A ≃* B)
|
||||
: πg[n+1] A ≃g πg[n+1] B :=
|
||||
begin
|
||||
apply isomorphism.mk (homotopy_group_homomorphism (succ n) f),
|
||||
esimp, apply is_equiv_trunc_functor, apply is_equiv_apn,
|
||||
end
|
||||
|
||||
definition homotopy_group_add (A : Type*) (n m : ℕ) :
|
||||
πg[n+m+1] A ≃g πg[n+1] (Ω[m] A) :=
|
||||
begin
|
||||
revert A, induction m with m IH: intro A,
|
||||
{ reflexivity},
|
||||
{ esimp [loopn, nat.add], refine !ghomotopy_group_succ_in ⬝g _, refine !IH ⬝g _,
|
||||
apply homotopy_group_isomorphism_of_pequiv,
|
||||
exact !loopn_succ_in⁻¹ᵉ*}
|
||||
end
|
||||
|
||||
theorem trivial_homotopy_add_of_is_set_loopn {A : Type*} {n : ℕ} (m : ℕ)
|
||||
(H : is_set (Ω[n] A)) : πg[m+n+1] A ≃g G0 :=
|
||||
!homotopy_group_add ⬝g !trivial_homotopy_of_is_set
|
||||
|
||||
theorem trivial_homotopy_le_of_is_set_loopn {A : Type*} {n : ℕ} (m : ℕ) (H1 : n ≤ m)
|
||||
(H2 : is_set (Ω[n] A)) : πg[m+1] A ≃g G0 :=
|
||||
obtain (k : ℕ) (p : n + k = m), from le.elim H1,
|
||||
isomorphism_of_eq (ap (λx, πg[x+1] A) (p⁻¹ ⬝ add.comm n k)) ⬝g
|
||||
trivial_homotopy_add_of_is_set_loopn k H2
|
||||
|
||||
definition homotopy_group_pequiv_loop_ptrunc_con {k : ℕ} {A : Type*} (p q : πg[k +1] A) :
|
||||
homotopy_group_pequiv_loop_ptrunc (succ k) A (p * q) =
|
||||
homotopy_group_pequiv_loop_ptrunc (succ k) A p ⬝
|
||||
homotopy_group_pequiv_loop_ptrunc (succ k) A q :=
|
||||
begin
|
||||
refine _ ⬝ !loopn_pequiv_loopn_con,
|
||||
exact ap (loopn_pequiv_loopn _ _) !loopn_ptrunc_pequiv_inv_con
|
||||
end
|
||||
|
||||
definition homotopy_group_pequiv_loop_ptrunc_inv_con {k : ℕ} {A : Type*}
|
||||
(p q : Ω[succ k] (ptrunc (succ k) A)) :
|
||||
(homotopy_group_pequiv_loop_ptrunc (succ k) A)⁻¹ᵉ* (p ⬝ q) =
|
||||
(homotopy_group_pequiv_loop_ptrunc (succ k) A)⁻¹ᵉ* p *
|
||||
(homotopy_group_pequiv_loop_ptrunc (succ k) A)⁻¹ᵉ* q :=
|
||||
inv_preserve_binary (homotopy_group_pequiv_loop_ptrunc (succ k) A) mul concat
|
||||
(@homotopy_group_pequiv_loop_ptrunc_con k A) p q
|
||||
|
||||
definition ghomotopy_group_ptrunc [constructor] (k : ℕ) (A : Type*) :
|
||||
πg[k+1] (ptrunc (k+1) A) ≃g πg[k+1] A :=
|
||||
begin
|
||||
fapply isomorphism_of_equiv,
|
||||
{ exact homotopy_group_ptrunc (k+1) A},
|
||||
{ intro g₁ g₂,
|
||||
refine _ ⬝ !homotopy_group_pequiv_loop_ptrunc_inv_con,
|
||||
apply ap ((homotopy_group_pequiv_loop_ptrunc (k+1) A)⁻¹ᵉ*),
|
||||
refine _ ⬝ !loopn_pequiv_loopn_con ,
|
||||
apply ap (loopn_pequiv_loopn (k+1) _),
|
||||
apply homotopy_group_pequiv_loop_ptrunc_con}
|
||||
end
|
||||
|
||||
/- some homomorphisms -/
|
||||
|
||||
-- definition is_homomorphism_cast_loopn_succ_eq_in {A : Type*} (n : ℕ) :
|
||||
-- is_homomorphism (loopn_succ_in A (succ n) : πg[n+1+1] A → πg[n+1] (Ω A)) :=
|
||||
-- begin
|
||||
-- intro g h, induction g with g, induction h with h,
|
||||
-- xrewrite [tr_mul_tr, - + fn_cast_eq_cast_fn _ (λn, tr), tr_mul_tr, ↑cast, -tr_compose,
|
||||
-- loopn_succ_eq_in_concat, - + tr_compose],
|
||||
-- end
|
||||
|
||||
definition is_mul_hom_inverse (A : Type*) (n : ℕ)
|
||||
: is_mul_hom (λp, p⁻¹ : (πag[n+2] A) → (πag[n+2] A)) :=
|
||||
begin
|
||||
intro g h, exact ap inv (mul.comm g h) ⬝ mul_inv h g,
|
||||
end
|
||||
|
||||
end eq
|
||||
|
|
@ -1,722 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad, Leonardo de Moura
|
||||
|
||||
-/
|
||||
|
||||
import algebra.binary algebra.priority
|
||||
|
||||
open eq eq.ops -- note: ⁻¹ will be overloaded
|
||||
open binary algebra is_trunc
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
|
||||
/- inf_semigroup -/
|
||||
|
||||
namespace algebra
|
||||
|
||||
structure inf_semigroup [class] (A : Type) extends has_mul A :=
|
||||
(mul_assoc : Πa b c, mul (mul a b) c = mul a (mul b c))
|
||||
|
||||
definition mul.assoc [s : inf_semigroup A] (a b c : A) : a * b * c = a * (b * c) :=
|
||||
!inf_semigroup.mul_assoc
|
||||
|
||||
structure comm_inf_semigroup [class] (A : Type) extends inf_semigroup A :=
|
||||
(mul_comm : Πa b, mul a b = mul b a)
|
||||
|
||||
definition mul.comm [s : comm_inf_semigroup A] (a b : A) : a * b = b * a :=
|
||||
!comm_inf_semigroup.mul_comm
|
||||
|
||||
theorem mul.left_comm [s : comm_inf_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) :=
|
||||
binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c
|
||||
|
||||
theorem mul.right_comm [s : comm_inf_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b :=
|
||||
binary.right_comm (@mul.comm A _) (@mul.assoc A _) a b c
|
||||
|
||||
structure left_cancel_inf_semigroup [class] (A : Type) extends inf_semigroup A :=
|
||||
(mul_left_cancel : Πa b c, mul a b = mul a c → b = c)
|
||||
|
||||
theorem mul.left_cancel [s : left_cancel_inf_semigroup A] {a b c : A} :
|
||||
a * b = a * c → b = c :=
|
||||
!left_cancel_inf_semigroup.mul_left_cancel
|
||||
|
||||
abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel
|
||||
|
||||
structure right_cancel_inf_semigroup [class] (A : Type) extends inf_semigroup A :=
|
||||
(mul_right_cancel : Πa b c, mul a b = mul c b → a = c)
|
||||
|
||||
definition mul.right_cancel [s : right_cancel_inf_semigroup A] {a b c : A} :
|
||||
a * b = c * b → a = c :=
|
||||
!right_cancel_inf_semigroup.mul_right_cancel
|
||||
|
||||
abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel
|
||||
|
||||
/- additive inf_semigroup -/
|
||||
|
||||
definition add_inf_semigroup [class] : Type → Type := inf_semigroup
|
||||
|
||||
definition has_add_of_add_inf_semigroup [reducible] [trans_instance] (A : Type) [H : add_inf_semigroup A] :
|
||||
has_add A :=
|
||||
has_add.mk (@inf_semigroup.mul A H)
|
||||
|
||||
definition add.assoc [s : add_inf_semigroup A] (a b c : A) : a + b + c = a + (b + c) :=
|
||||
@mul.assoc A s a b c
|
||||
|
||||
definition add_comm_inf_semigroup [class] : Type → Type := comm_inf_semigroup
|
||||
|
||||
definition add_inf_semigroup_of_add_comm_inf_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_inf_semigroup A] : add_inf_semigroup A :=
|
||||
@comm_inf_semigroup.to_inf_semigroup A H
|
||||
|
||||
definition add.comm [s : add_comm_inf_semigroup A] (a b : A) : a + b = b + a :=
|
||||
@mul.comm A s a b
|
||||
|
||||
theorem add.left_comm [s : add_comm_inf_semigroup A] (a b c : A) :
|
||||
a + (b + c) = b + (a + c) :=
|
||||
binary.left_comm (@add.comm A _) (@add.assoc A _) a b c
|
||||
|
||||
theorem add.right_comm [s : add_comm_inf_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
|
||||
binary.right_comm (@add.comm A _) (@add.assoc A _) a b c
|
||||
|
||||
definition add_left_cancel_inf_semigroup [class] : Type → Type := left_cancel_inf_semigroup
|
||||
|
||||
definition add_inf_semigroup_of_add_left_cancel_inf_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_left_cancel_inf_semigroup A] : add_inf_semigroup A :=
|
||||
@left_cancel_inf_semigroup.to_inf_semigroup A H
|
||||
|
||||
definition add.left_cancel [s : add_left_cancel_inf_semigroup A] {a b c : A} :
|
||||
a + b = a + c → b = c :=
|
||||
@mul.left_cancel A s a b c
|
||||
|
||||
abbreviation eq_of_add_eq_add_left := @add.left_cancel
|
||||
|
||||
definition add_right_cancel_inf_semigroup [class] : Type → Type := right_cancel_inf_semigroup
|
||||
|
||||
definition add_inf_semigroup_of_add_right_cancel_inf_semigroup [reducible] [trans_instance] (A : Type)
|
||||
[H : add_right_cancel_inf_semigroup A] : add_inf_semigroup A :=
|
||||
@right_cancel_inf_semigroup.to_inf_semigroup A H
|
||||
|
||||
definition add.right_cancel [s : add_right_cancel_inf_semigroup A] {a b c : A} :
|
||||
a + b = c + b → a = c :=
|
||||
@mul.right_cancel A s a b c
|
||||
|
||||
abbreviation eq_of_add_eq_add_right := @add.right_cancel
|
||||
|
||||
/- inf_monoid -/
|
||||
|
||||
structure inf_monoid [class] (A : Type) extends inf_semigroup A, has_one A :=
|
||||
(one_mul : Πa, mul one a = a) (mul_one : Πa, mul a one = a)
|
||||
|
||||
definition one_mul [s : inf_monoid A] (a : A) : 1 * a = a := !inf_monoid.one_mul
|
||||
|
||||
definition mul_one [s : inf_monoid A] (a : A) : a * 1 = a := !inf_monoid.mul_one
|
||||
|
||||
structure comm_inf_monoid [class] (A : Type) extends inf_monoid A, comm_inf_semigroup A
|
||||
|
||||
/- additive inf_monoid -/
|
||||
|
||||
definition add_inf_monoid [class] : Type → Type := inf_monoid
|
||||
|
||||
definition add_inf_semigroup_of_add_inf_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_inf_monoid A] : add_inf_semigroup A :=
|
||||
@inf_monoid.to_inf_semigroup A H
|
||||
|
||||
definition has_zero_of_add_inf_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_inf_monoid A] : has_zero A :=
|
||||
has_zero.mk (@inf_monoid.one A H)
|
||||
|
||||
definition zero_add [s : add_inf_monoid A] (a : A) : 0 + a = a := @inf_monoid.one_mul A s a
|
||||
|
||||
definition add_zero [s : add_inf_monoid A] (a : A) : a + 0 = a := @inf_monoid.mul_one A s a
|
||||
|
||||
definition add_comm_inf_monoid [class] : Type → Type := comm_inf_monoid
|
||||
|
||||
definition add_inf_monoid_of_add_comm_inf_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_inf_monoid A] : add_inf_monoid A :=
|
||||
@comm_inf_monoid.to_inf_monoid A H
|
||||
|
||||
definition add_comm_inf_semigroup_of_add_comm_inf_monoid [reducible] [trans_instance] (A : Type)
|
||||
[H : add_comm_inf_monoid A] : add_comm_inf_semigroup A :=
|
||||
@comm_inf_monoid.to_comm_inf_semigroup A H
|
||||
|
||||
section add_comm_inf_monoid
|
||||
variables [s : add_comm_inf_monoid A]
|
||||
include s
|
||||
|
||||
theorem add_comm_three (a b c : A) : a + b + c = c + b + a :=
|
||||
by rewrite [{a + _}add.comm, {_ + c}add.comm, -*add.assoc]
|
||||
|
||||
theorem add.comm4 : Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
|
||||
comm4 add.comm add.assoc
|
||||
end add_comm_inf_monoid
|
||||
|
||||
/- group -/
|
||||
|
||||
structure inf_group [class] (A : Type) extends inf_monoid A, has_inv A :=
|
||||
(mul_left_inv : Πa, mul (inv a) a = one)
|
||||
|
||||
-- Note: with more work, we could derive the axiom one_mul
|
||||
|
||||
section inf_group
|
||||
|
||||
variable [s : inf_group A]
|
||||
include s
|
||||
|
||||
definition mul.left_inv (a : A) : a⁻¹ * a = 1 := !inf_group.mul_left_inv
|
||||
|
||||
theorem inv_mul_cancel_left (a b : A) : a⁻¹ * (a * b) = b :=
|
||||
by rewrite [-mul.assoc, mul.left_inv, one_mul]
|
||||
|
||||
theorem inv_mul_cancel_right (a b : A) : a * b⁻¹ * b = a :=
|
||||
by rewrite [mul.assoc, mul.left_inv, mul_one]
|
||||
|
||||
theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b :=
|
||||
by rewrite [-mul_one a⁻¹, -H, inv_mul_cancel_left]
|
||||
|
||||
theorem one_inv : 1⁻¹ = (1 : A) := inv_eq_of_mul_eq_one (one_mul 1)
|
||||
|
||||
theorem inv_inv (a : A) : (a⁻¹)⁻¹ = a := inv_eq_of_mul_eq_one (mul.left_inv a)
|
||||
|
||||
theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b :=
|
||||
by rewrite [-inv_inv a, H, inv_inv b]
|
||||
|
||||
theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b :=
|
||||
iff.intro (assume H, inv.inj H) (assume H, ap _ H)
|
||||
|
||||
theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 :=
|
||||
one_inv ▸ inv_eq_inv_iff_eq a 1
|
||||
|
||||
theorem inv_eq_one {a : A} (H : a = 1) : a⁻¹ = 1 :=
|
||||
iff.mpr (inv_eq_one_iff_eq_one a) H
|
||||
|
||||
theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 :=
|
||||
iff.mp !inv_eq_one_iff_eq_one
|
||||
|
||||
theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ :=
|
||||
by rewrite [H, inv_inv]
|
||||
|
||||
theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ :=
|
||||
iff.intro !eq_inv_of_eq_inv !eq_inv_of_eq_inv
|
||||
|
||||
theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ :=
|
||||
begin apply eq_inv_of_eq_inv, symmetry, exact inv_eq_of_mul_eq_one H end
|
||||
|
||||
theorem mul.right_inv (a : A) : a * a⁻¹ = 1 :=
|
||||
calc
|
||||
a * a⁻¹ = (a⁻¹)⁻¹ * a⁻¹ : inv_inv
|
||||
... = 1 : mul.left_inv
|
||||
|
||||
theorem mul_inv_cancel_left (a b : A) : a * (a⁻¹ * b) = b :=
|
||||
calc
|
||||
a * (a⁻¹ * b) = a * a⁻¹ * b : by rewrite mul.assoc
|
||||
... = 1 * b : mul.right_inv
|
||||
... = b : one_mul
|
||||
|
||||
theorem mul_inv_cancel_right (a b : A) : a * b * b⁻¹ = a :=
|
||||
calc
|
||||
a * b * b⁻¹ = a * (b * b⁻¹) : mul.assoc
|
||||
... = a * 1 : mul.right_inv
|
||||
... = a : mul_one
|
||||
|
||||
theorem mul_inv (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
|
||||
inv_eq_of_mul_eq_one
|
||||
(calc
|
||||
a * b * (b⁻¹ * a⁻¹) = a * (b * (b⁻¹ * a⁻¹)) : mul.assoc
|
||||
... = a * a⁻¹ : mul_inv_cancel_left
|
||||
... = 1 : mul.right_inv)
|
||||
|
||||
theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b :=
|
||||
calc
|
||||
a = a * b⁻¹ * b : by rewrite inv_mul_cancel_right
|
||||
... = 1 * b : H
|
||||
... = b : one_mul
|
||||
|
||||
theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ :=
|
||||
by rewrite [-H, mul_inv_cancel_right]
|
||||
|
||||
theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c :=
|
||||
by rewrite [-H, inv_mul_cancel_left]
|
||||
|
||||
theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c :=
|
||||
by rewrite [H, inv_mul_cancel_left]
|
||||
|
||||
theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c :=
|
||||
by rewrite [H, mul_inv_cancel_right]
|
||||
|
||||
theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c :=
|
||||
!inv_inv ▸ (eq_mul_inv_of_mul_eq H)
|
||||
|
||||
theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c :=
|
||||
!inv_inv ▸ (eq_inv_mul_of_mul_eq H)
|
||||
|
||||
theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c :=
|
||||
!inv_inv ▸ (inv_mul_eq_of_eq_mul H)
|
||||
|
||||
theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c :=
|
||||
!inv_inv ▸ (mul_inv_eq_of_eq_mul H)
|
||||
|
||||
theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c :=
|
||||
iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul
|
||||
|
||||
theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ :=
|
||||
iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv
|
||||
|
||||
theorem mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c :=
|
||||
by rewrite [-inv_mul_cancel_left a b, H, inv_mul_cancel_left]
|
||||
|
||||
theorem mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c :=
|
||||
by rewrite [-mul_inv_cancel_right a b, H, mul_inv_cancel_right]
|
||||
|
||||
theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 :=
|
||||
by rewrite [-inv_eq_of_mul_eq_one H, mul.left_inv]
|
||||
|
||||
theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 :=
|
||||
iff.intro !mul_eq_one_of_mul_eq_one !mul_eq_one_of_mul_eq_one
|
||||
|
||||
definition conj_by (g a : A) := g * a * g⁻¹
|
||||
definition is_conjugate (a b : A) := Σ x, conj_by x b = a
|
||||
|
||||
local infixl ` ~ ` := is_conjugate
|
||||
local infixr ` ∘c `:55 := conj_by
|
||||
|
||||
lemma conj_compose (f g a : A) : f ∘c g ∘c a = f*g ∘c a :=
|
||||
calc f ∘c g ∘c a = f * (g * a * g⁻¹) * f⁻¹ : rfl
|
||||
... = f * (g * a) * g⁻¹ * f⁻¹ : mul.assoc
|
||||
... = f * g * a * g⁻¹ * f⁻¹ : mul.assoc
|
||||
... = f * g * a * (g⁻¹ * f⁻¹) : mul.assoc
|
||||
... = f * g * a * (f * g)⁻¹ : mul_inv
|
||||
lemma conj_id (a : A) : 1 ∘c a = a :=
|
||||
calc 1 * a * 1⁻¹ = a * 1⁻¹ : one_mul
|
||||
... = a * 1 : one_inv
|
||||
... = a : mul_one
|
||||
lemma conj_one (g : A) : g ∘c 1 = 1 :=
|
||||
calc g * 1 * g⁻¹ = g * g⁻¹ : mul_one
|
||||
... = 1 : mul.right_inv
|
||||
lemma conj_inv_cancel (g : A) : Π a, g⁻¹ ∘c g ∘c a = a :=
|
||||
assume a, calc
|
||||
g⁻¹ ∘c g ∘c a = g⁻¹*g ∘c a : conj_compose
|
||||
... = 1 ∘c a : mul.left_inv
|
||||
... = a : conj_id
|
||||
|
||||
lemma conj_inv (g : A) : Π a, (g ∘c a)⁻¹ = g ∘c a⁻¹ :=
|
||||
take a, calc
|
||||
(g * a * g⁻¹)⁻¹ = g⁻¹⁻¹ * (g * a)⁻¹ : mul_inv
|
||||
... = g⁻¹⁻¹ * (a⁻¹ * g⁻¹) : mul_inv
|
||||
... = g⁻¹⁻¹ * a⁻¹ * g⁻¹ : mul.assoc
|
||||
... = g * a⁻¹ * g⁻¹ : inv_inv
|
||||
|
||||
lemma is_conj.refl (a : A) : a ~ a := sigma.mk 1 (conj_id a)
|
||||
|
||||
lemma is_conj.symm (a b : A) : a ~ b → b ~ a :=
|
||||
assume Pab, obtain x (Pconj : x ∘c b = a), from Pab,
|
||||
have Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a, begin congruence, assumption end,
|
||||
sigma.mk x⁻¹ (inverse (conj_inv_cancel x b ▸ Pxinv))
|
||||
|
||||
lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c :=
|
||||
assume Pab, assume Pbc,
|
||||
obtain x (Px : x ∘c b = a), from Pab,
|
||||
obtain y (Py : y ∘c c = b), from Pbc,
|
||||
sigma.mk (x*y) (calc
|
||||
x*y ∘c c = x ∘c y ∘c c : conj_compose
|
||||
... = x ∘c b : Py
|
||||
... = a : Px)
|
||||
|
||||
definition inf_group.to_left_cancel_inf_semigroup [trans_instance] : left_cancel_inf_semigroup A :=
|
||||
⦃ left_cancel_inf_semigroup, s,
|
||||
mul_left_cancel := @mul_left_cancel A s ⦄
|
||||
|
||||
definition inf_group.to_right_cancel_inf_semigroup [trans_instance] : right_cancel_inf_semigroup A :=
|
||||
⦃ right_cancel_inf_semigroup, s,
|
||||
mul_right_cancel := @mul_right_cancel A s ⦄
|
||||
|
||||
end inf_group
|
||||
|
||||
structure ab_inf_group [class] (A : Type) extends inf_group A, comm_inf_monoid A
|
||||
|
||||
/- additive inf_group -/
|
||||
|
||||
definition add_inf_group [class] : Type → Type := inf_group
|
||||
|
||||
definition add_inf_semigroup_of_add_inf_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_inf_group A] : add_inf_monoid A :=
|
||||
@inf_group.to_inf_monoid A H
|
||||
|
||||
definition has_neg_of_add_inf_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_inf_group A] : has_neg A :=
|
||||
has_neg.mk (@inf_group.inv A H)
|
||||
|
||||
section add_inf_group
|
||||
|
||||
variables [s : add_inf_group A]
|
||||
include s
|
||||
|
||||
theorem add.left_inv (a : A) : -a + a = 0 := @inf_group.mul_left_inv A s a
|
||||
|
||||
theorem neg_add_cancel_left (a b : A) : -a + (a + b) = b :=
|
||||
by rewrite [-add.assoc, add.left_inv, zero_add]
|
||||
|
||||
theorem neg_add_cancel_right (a b : A) : a + -b + b = a :=
|
||||
by rewrite [add.assoc, add.left_inv, add_zero]
|
||||
|
||||
theorem neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b :=
|
||||
by rewrite [-add_zero (-a), -H, neg_add_cancel_left]
|
||||
|
||||
theorem neg_zero : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0)
|
||||
|
||||
theorem neg_neg (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a)
|
||||
|
||||
theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b :=
|
||||
by rewrite [-neg_eq_of_add_eq_zero H, neg_neg]
|
||||
|
||||
theorem neg.inj {a b : A} (H : -a = -b) : a = b :=
|
||||
calc
|
||||
a = -(-a) : neg_neg
|
||||
... = b : neg_eq_of_add_eq_zero (H⁻¹ ▸ (add.left_inv _))
|
||||
|
||||
theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b :=
|
||||
iff.intro (assume H, neg.inj H) (assume H, ap _ H)
|
||||
|
||||
theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b :=
|
||||
iff.mp !neg_eq_neg_iff_eq
|
||||
|
||||
theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 :=
|
||||
neg_zero ▸ !neg_eq_neg_iff_eq
|
||||
|
||||
theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 :=
|
||||
iff.mp !neg_eq_zero_iff_eq_zero
|
||||
|
||||
theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a :=
|
||||
H⁻¹ ▸ (neg_neg b)⁻¹
|
||||
|
||||
theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a :=
|
||||
iff.intro !eq_neg_of_eq_neg !eq_neg_of_eq_neg
|
||||
|
||||
theorem add.right_inv (a : A) : a + -a = 0 :=
|
||||
calc
|
||||
a + -a = -(-a) + -a : neg_neg
|
||||
... = 0 : add.left_inv
|
||||
|
||||
theorem add_neg_cancel_left (a b : A) : a + (-a + b) = b :=
|
||||
by rewrite [-add.assoc, add.right_inv, zero_add]
|
||||
|
||||
theorem add_neg_cancel_right (a b : A) : a + b + -b = a :=
|
||||
by rewrite [add.assoc, add.right_inv, add_zero]
|
||||
|
||||
theorem neg_add_rev (a b : A) : -(a + b) = -b + -a :=
|
||||
neg_eq_of_add_eq_zero
|
||||
begin
|
||||
rewrite [add.assoc, add_neg_cancel_left, add.right_inv]
|
||||
end
|
||||
|
||||
-- TODO: delete these in favor of sub rules?
|
||||
theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c :=
|
||||
H ▸ !add_neg_cancel_right⁻¹
|
||||
|
||||
theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c :=
|
||||
H ▸ !neg_add_cancel_left⁻¹
|
||||
|
||||
theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c :=
|
||||
H⁻¹ ▸ !neg_add_cancel_left
|
||||
|
||||
theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c :=
|
||||
H⁻¹ ▸ !add_neg_cancel_right
|
||||
|
||||
theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c :=
|
||||
!neg_neg ▸ (eq_add_neg_of_add_eq H)
|
||||
|
||||
theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c :=
|
||||
!neg_neg ▸ (eq_neg_add_of_add_eq H)
|
||||
|
||||
theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c :=
|
||||
!neg_neg ▸ (neg_add_eq_of_eq_add H)
|
||||
|
||||
theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c :=
|
||||
!neg_neg ▸ (add_neg_eq_of_eq_add H)
|
||||
|
||||
theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c :=
|
||||
iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add
|
||||
|
||||
theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b :=
|
||||
iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg
|
||||
|
||||
theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c :=
|
||||
calc b = -a + (a + b) : !neg_add_cancel_left⁻¹
|
||||
... = -a + (a + c) : H
|
||||
... = c : neg_add_cancel_left
|
||||
|
||||
theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c :=
|
||||
calc a = (a + b) + -b : !add_neg_cancel_right⁻¹
|
||||
... = (c + b) + -b : H
|
||||
... = c : add_neg_cancel_right
|
||||
|
||||
definition add_inf_group.to_add_left_cancel_inf_semigroup [reducible] [trans_instance] :
|
||||
add_left_cancel_inf_semigroup A :=
|
||||
@inf_group.to_left_cancel_inf_semigroup A s
|
||||
|
||||
definition add_inf_group.to_add_right_cancel_inf_semigroup [reducible] [trans_instance] :
|
||||
add_right_cancel_inf_semigroup A :=
|
||||
@inf_group.to_right_cancel_inf_semigroup A s
|
||||
|
||||
theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) :=
|
||||
by rewrite [neg_add_rev, neg_neg]
|
||||
|
||||
/- sub -/
|
||||
|
||||
-- TODO: derive corresponding facts for div in a field
|
||||
protected definition algebra.sub [reducible] (a b : A) : A := a + -b
|
||||
|
||||
definition add_inf_group_has_sub [instance] : has_sub A :=
|
||||
has_sub.mk algebra.sub
|
||||
|
||||
theorem sub_eq_add_neg (a b : A) : a - b = a + -b := rfl
|
||||
|
||||
theorem sub_self (a : A) : a - a = 0 := !add.right_inv
|
||||
|
||||
theorem sub_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right
|
||||
|
||||
theorem add_sub_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right
|
||||
|
||||
theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b :=
|
||||
calc
|
||||
a = (a - b) + b : !sub_add_cancel⁻¹
|
||||
... = 0 + b : H
|
||||
... = b : zero_add
|
||||
|
||||
theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 :=
|
||||
iff.intro (assume H, H ▸ !sub_self) (assume H, eq_of_sub_eq_zero H)
|
||||
|
||||
theorem zero_sub (a : A) : 0 - a = -a := !zero_add
|
||||
|
||||
theorem sub_zero (a : A) : a - 0 = a :=
|
||||
by rewrite [sub_eq_add_neg, neg_zero, add_zero]
|
||||
|
||||
theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b :=
|
||||
by change a + -(-b) = a + b; rewrite neg_neg
|
||||
|
||||
theorem neg_sub (a b : A) : -(a - b) = b - a :=
|
||||
neg_eq_of_add_eq_zero
|
||||
(calc
|
||||
a - b + (b - a) = a - b + b - a : by krewrite -add.assoc
|
||||
... = a - a : sub_add_cancel
|
||||
... = 0 : sub_self)
|
||||
|
||||
theorem add_sub (a b c : A) : a + (b - c) = a + b - c := !add.assoc⁻¹
|
||||
|
||||
theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b :=
|
||||
calc
|
||||
a - (b + c) = a + (-c - b) : by rewrite [sub_eq_add_neg, neg_add_rev]
|
||||
... = a - c - b : by krewrite -add.assoc
|
||||
|
||||
theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b :=
|
||||
iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H)
|
||||
|
||||
theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b :=
|
||||
iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H)
|
||||
|
||||
theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d :=
|
||||
calc
|
||||
a = b ↔ a - b = 0 : eq_iff_sub_eq_zero
|
||||
... = (c - d = 0) : H
|
||||
... ↔ c = d : iff.symm (eq_iff_sub_eq_zero c d)
|
||||
|
||||
theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c :=
|
||||
!eq_add_neg_of_add_eq H
|
||||
|
||||
theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c :=
|
||||
!add_neg_eq_of_eq_add H
|
||||
|
||||
theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c :=
|
||||
eq_add_of_add_neg_eq H
|
||||
|
||||
theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
|
||||
add_eq_of_eq_add_neg H
|
||||
|
||||
end add_inf_group
|
||||
|
||||
definition add_ab_inf_group [class] : Type → Type := ab_inf_group
|
||||
|
||||
definition add_inf_group_of_add_ab_inf_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_ab_inf_group A] : add_inf_group A :=
|
||||
@ab_inf_group.to_inf_group A H
|
||||
|
||||
definition add_comm_inf_monoid_of_add_ab_inf_group [reducible] [trans_instance] (A : Type)
|
||||
[H : add_ab_inf_group A] : add_comm_inf_monoid A :=
|
||||
@ab_inf_group.to_comm_inf_monoid A H
|
||||
|
||||
section add_ab_inf_group
|
||||
variable [s : add_ab_inf_group A]
|
||||
include s
|
||||
|
||||
theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c :=
|
||||
!add.comm ▸ !sub_add_eq_sub_sub_swap
|
||||
|
||||
theorem neg_add_eq_sub (a b : A) : -a + b = b - a := !add.comm
|
||||
|
||||
theorem neg_add (a b : A) : -(a + b) = -a + -b := add.comm (-b) (-a) ▸ neg_add_rev a b
|
||||
|
||||
theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b := !add.right_comm
|
||||
|
||||
theorem sub_sub (a b c : A) : a - b - c = a - (b + c) :=
|
||||
by rewrite [▸ a + -b + -c = _, add.assoc, -neg_add]
|
||||
|
||||
theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b :=
|
||||
by rewrite [sub_add_eq_sub_sub, (add.comm c a), add_sub_cancel]
|
||||
|
||||
theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c :=
|
||||
!eq_sub_of_add_eq (!add.comm ▸ H)
|
||||
|
||||
theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c :=
|
||||
!sub_eq_of_eq_add (!add.comm ▸ H)
|
||||
|
||||
theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c :=
|
||||
!add.comm ▸ eq_add_of_sub_eq H
|
||||
|
||||
theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c :=
|
||||
!add.comm ▸ add_eq_of_eq_sub H
|
||||
|
||||
theorem sub_sub_self (a b : A) : a - (a - b) = b :=
|
||||
by rewrite [sub_eq_add_neg, neg_sub, add.comm, sub_add_cancel]
|
||||
|
||||
theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) :=
|
||||
by rewrite [sub_add_eq_sub_sub, -sub_add_eq_add_sub a c b, add_sub]
|
||||
|
||||
theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) :=
|
||||
by rewrite [add_sub, sub_add_cancel] ⬝ !add.comm
|
||||
|
||||
theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
|
||||
by rewrite [neg_sub, sub_neg_eq_add, neg_add_eq_sub]
|
||||
end add_ab_inf_group
|
||||
|
||||
definition inf_group_of_add_inf_group (A : Type) [G : add_inf_group A] : inf_group A :=
|
||||
⦃inf_group,
|
||||
mul := has_add.add,
|
||||
mul_assoc := add.assoc,
|
||||
one := !has_zero.zero,
|
||||
one_mul := zero_add,
|
||||
mul_one := add_zero,
|
||||
inv := has_neg.neg,
|
||||
mul_left_inv := add.left_inv ⦄
|
||||
|
||||
namespace norm_num
|
||||
|
||||
definition add1 [s : has_add A] [s' : has_one A] (a : A) : A := add a one
|
||||
|
||||
theorem add_comm_four [s : add_comm_inf_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) :=
|
||||
by rewrite [-add.assoc at {1}, add.comm, {a + b}add.comm at {1}, *add.assoc]
|
||||
|
||||
theorem add_comm_middle [s : add_comm_inf_semigroup A] (a b c : A) : a + b + c = a + c + b :=
|
||||
by rewrite [add.assoc, add.comm b, -add.assoc]
|
||||
|
||||
theorem bit0_add_bit0 [s : add_comm_inf_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
|
||||
!add_comm_four
|
||||
|
||||
theorem bit0_add_bit0_helper [s : add_comm_inf_semigroup A] (a b t : A) (H : a + b = t) :
|
||||
bit0 a + bit0 b = bit0 t :=
|
||||
by rewrite -H; apply bit0_add_bit0
|
||||
|
||||
theorem bit1_add_bit0 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
|
||||
bit1 a + bit0 b = bit1 (a + b) :=
|
||||
begin
|
||||
rewrite [↑bit0, ↑bit1, add_comm_middle], congruence, apply add_comm_four
|
||||
end
|
||||
|
||||
theorem bit1_add_bit0_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t : A)
|
||||
(H : a + b = t) : bit1 a + bit0 b = bit1 t :=
|
||||
by rewrite -H; apply bit1_add_bit0
|
||||
|
||||
theorem bit0_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
|
||||
bit0 a + bit1 b = bit1 (a + b) :=
|
||||
by rewrite [{bit0 a + bit1 b}add.comm,{a + b}add.comm]; exact bit1_add_bit0 b a
|
||||
|
||||
theorem bit0_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t : A)
|
||||
(H : a + b = t) : bit0 a + bit1 b = bit1 t :=
|
||||
by rewrite -H; apply bit0_add_bit1
|
||||
|
||||
theorem bit1_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a b : A) :
|
||||
bit1 a + bit1 b = bit0 (add1 (a + b)) :=
|
||||
begin
|
||||
rewrite ↑[bit0, bit1, add1, add.assoc],
|
||||
rewrite [*add.assoc, {_ + (b + 1)}add.comm, {_ + (b + 1 + _)}add.comm,
|
||||
{_ + (b + 1 + _ + _)}add.comm, *add.assoc, {1 + a}add.comm, -{b + (a + 1)}add.assoc,
|
||||
{b + a}add.comm, *add.assoc]
|
||||
end
|
||||
|
||||
theorem bit1_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a b t s: A)
|
||||
(H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s :=
|
||||
begin rewrite [-H2, -H], apply bit1_add_bit1 end
|
||||
|
||||
theorem bin_add_zero [s : add_inf_monoid A] (a : A) : a + zero = a := !add_zero
|
||||
|
||||
theorem bin_zero_add [s : add_inf_monoid A] (a : A) : zero + a = a := !zero_add
|
||||
|
||||
theorem one_add_bit0 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) : one + bit0 a = bit1 a :=
|
||||
begin rewrite ↑[bit0, bit1], rewrite add.comm end
|
||||
|
||||
theorem bit0_add_one [s : has_add A] [s' : has_one A] (a : A) : bit0 a + one = bit1 a :=
|
||||
rfl
|
||||
|
||||
theorem bit1_add_one [s : has_add A] [s' : has_one A] (a : A) : bit1 a + one = add1 (bit1 a) :=
|
||||
rfl
|
||||
|
||||
theorem bit1_add_one_helper [s : has_add A] [s' : has_one A] (a t : A) (H : add1 (bit1 a) = t) :
|
||||
bit1 a + one = t :=
|
||||
by rewrite -H
|
||||
|
||||
theorem one_add_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) :
|
||||
one + bit1 a = add1 (bit1 a) := !add.comm
|
||||
|
||||
theorem one_add_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a t : A)
|
||||
(H : add1 (bit1 a) = t) : one + bit1 a = t :=
|
||||
by rewrite -H; apply one_add_bit1
|
||||
|
||||
theorem add1_bit0 [s : has_add A] [s' : has_one A] (a : A) : add1 (bit0 a) = bit1 a :=
|
||||
rfl
|
||||
|
||||
theorem add1_bit1 [s : add_comm_inf_semigroup A] [s' : has_one A] (a : A) :
|
||||
add1 (bit1 a) = bit0 (add1 a) :=
|
||||
begin
|
||||
rewrite ↑[add1, bit1, bit0],
|
||||
rewrite [add.assoc, add_comm_four]
|
||||
end
|
||||
|
||||
theorem add1_bit1_helper [s : add_comm_inf_semigroup A] [s' : has_one A] (a t : A) (H : add1 a = t) :
|
||||
add1 (bit1 a) = bit0 t :=
|
||||
by rewrite -H; apply add1_bit1
|
||||
|
||||
theorem add1_one [s : has_add A] [s' : has_one A] : add1 (one : A) = bit0 one :=
|
||||
rfl
|
||||
|
||||
theorem add1_zero [s : add_inf_monoid A] [s' : has_one A] : add1 (zero : A) = one :=
|
||||
begin
|
||||
rewrite [↑add1, zero_add]
|
||||
end
|
||||
|
||||
theorem one_add_one [s : has_add A] [s' : has_one A] : (one : A) + one = bit0 one :=
|
||||
rfl
|
||||
|
||||
theorem subst_into_sum [s : has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
|
||||
(prt : tl + tr = t) : l + r = t :=
|
||||
by rewrite [prl, prr, prt]
|
||||
|
||||
theorem neg_zero_helper [s : add_inf_group A] (a : A) (H : a = 0) : - a = 0 :=
|
||||
by rewrite [H, neg_zero]
|
||||
|
||||
end norm_num
|
||||
|
||||
end algebra
|
||||
open algebra
|
||||
|
||||
attribute [simp]
|
||||
zero_add add_zero one_mul mul_one
|
||||
at simplifier.unit
|
||||
|
||||
attribute [simp]
|
||||
neg_neg sub_eq_add_neg
|
||||
at simplifier.neg
|
||||
|
||||
attribute [simp]
|
||||
add.assoc add.comm add.left_comm
|
||||
mul.left_comm mul.comm mul.assoc
|
||||
at simplifier.ac
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jeremy Avigad
|
||||
-/
|
||||
import .order
|
||||
|
||||
open eq
|
||||
|
||||
variable {A : Type}
|
||||
set_option class.force_new true
|
||||
|
||||
/- lattices (we could split this to upper- and lower-semilattices, if needed) -/
|
||||
|
||||
namespace algebra
|
||||
structure lattice [class] (A : Type) extends weak_order A :=
|
||||
(inf : A → A → A)
|
||||
(sup : A → A → A)
|
||||
(inf_le_left : Π a b, le (inf a b) a)
|
||||
(inf_le_right : Π a b, le (inf a b) b)
|
||||
(le_inf : Πa b c, le c a → le c b → le c (inf a b))
|
||||
(le_sup_left : Π a b, le a (sup a b))
|
||||
(le_sup_right : Π a b, le b (sup a b))
|
||||
(sup_le : Π a b c, le a c → le b c → le (sup a b) c)
|
||||
|
||||
definition inf := @lattice.inf
|
||||
definition sup := @lattice.sup
|
||||
infix ` ⊓ `:70 := inf
|
||||
infix ` ⊔ `:65 := sup
|
||||
|
||||
section
|
||||
variable [s : lattice A]
|
||||
include s
|
||||
|
||||
theorem inf_le_left (a b : A) : a ⊓ b ≤ a := !lattice.inf_le_left
|
||||
|
||||
theorem inf_le_right (a b : A) : a ⊓ b ≤ b := !lattice.inf_le_right
|
||||
|
||||
theorem le_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ a ⊓ b := !lattice.le_inf H₁ H₂
|
||||
|
||||
theorem le_sup_left (a b : A) : a ≤ a ⊔ b := !lattice.le_sup_left
|
||||
|
||||
theorem le_sup_right (a b : A) : b ≤ a ⊔ b := !lattice.le_sup_right
|
||||
|
||||
theorem sup_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : a ⊔ b ≤ c := !lattice.sup_le H₁ H₂
|
||||
|
||||
/- inf -/
|
||||
|
||||
theorem eq_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : Π{d}, d ≤ a → d ≤ b → d ≤ c) :
|
||||
c = a ⊓ b :=
|
||||
le.antisymm (le_inf H₁ H₂) (H₃ !inf_le_left !inf_le_right)
|
||||
|
||||
theorem inf.comm (a b : A) : a ⊓ b = b ⊓ a :=
|
||||
eq_inf !inf_le_right !inf_le_left (λ c H₁ H₂, le_inf H₂ H₁)
|
||||
|
||||
theorem inf.assoc (a b c : A) : (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c) :=
|
||||
begin
|
||||
apply eq_inf,
|
||||
{ apply le.trans, apply inf_le_left, apply inf_le_left },
|
||||
{ apply le_inf, apply le.trans, apply inf_le_left, apply inf_le_right, apply inf_le_right },
|
||||
{ intros [d, H₁, H₂], apply le_inf, apply le_inf H₁, apply le.trans H₂, apply inf_le_left,
|
||||
apply le.trans H₂, apply inf_le_right }
|
||||
end
|
||||
|
||||
theorem inf.left_comm (a b c : A) : a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) :=
|
||||
binary.left_comm (@inf.comm A s) (@inf.assoc A s) a b c
|
||||
|
||||
theorem inf.right_comm (a b c : A) : (a ⊓ b) ⊓ c = (a ⊓ c) ⊓ b :=
|
||||
binary.right_comm (@inf.comm A s) (@inf.assoc A s) a b c
|
||||
|
||||
theorem inf_self (a : A) : a ⊓ a = a :=
|
||||
by apply inverse; apply eq_inf (le.refl a) !le.refl; intros; assumption
|
||||
|
||||
theorem inf_eq_left {a b : A} (H : a ≤ b) : a ⊓ b = a :=
|
||||
by apply inverse; apply eq_inf !le.refl H; intros; assumption
|
||||
|
||||
theorem inf_eq_right {a b : A} (H : b ≤ a) : a ⊓ b = b :=
|
||||
eq.subst !inf.comm (inf_eq_left H)
|
||||
|
||||
/- sup -/
|
||||
|
||||
theorem eq_sup {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : Π{d}, a ≤ d → b ≤ d → c ≤ d) :
|
||||
c = a ⊔ b :=
|
||||
le.antisymm (H₃ !le_sup_left !le_sup_right) (sup_le H₁ H₂)
|
||||
|
||||
theorem sup.comm (a b : A) : a ⊔ b = b ⊔ a :=
|
||||
eq_sup !le_sup_right !le_sup_left (λ c H₁ H₂, sup_le H₂ H₁)
|
||||
|
||||
theorem sup.assoc (a b c : A) : (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c) :=
|
||||
begin
|
||||
apply eq_sup,
|
||||
{ apply le.trans, apply le_sup_left a b, apply le_sup_left },
|
||||
{ apply sup_le, apply le.trans, apply le_sup_right a b, apply le_sup_left, apply le_sup_right },
|
||||
{ intros [d, H₁, H₂], apply sup_le, apply sup_le H₁, apply le.trans !le_sup_left H₂,
|
||||
apply le.trans !le_sup_right H₂}
|
||||
end
|
||||
|
||||
theorem sup.left_comm (a b c : A) : a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) :=
|
||||
binary.left_comm (@sup.comm A s) (@sup.assoc A s) a b c
|
||||
|
||||
theorem sup.right_comm (a b c : A) : (a ⊔ b) ⊔ c = (a ⊔ c) ⊔ b :=
|
||||
binary.right_comm (@sup.comm A s) (@sup.assoc A s) a b c
|
||||
|
||||
theorem sup_self (a : A) : a ⊔ a = a :=
|
||||
by apply inverse; apply eq_sup (le.refl a) !le.refl; intros; assumption
|
||||
|
||||
theorem sup_eq_left {a b : A} (H : b ≤ a) : a ⊔ b = a :=
|
||||
by apply inverse; apply eq_sup !le.refl H; intros; assumption
|
||||
|
||||
theorem sup_eq_right {a b : A} (H : a ≤ b) : a ⊔ b = b :=
|
||||
eq.subst !sup.comm (sup_eq_left H)
|
||||
end
|
||||
|
||||
end algebra
|
||||
|
|
@ -1,446 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jeremy Avigad
|
||||
|
||||
Weak orders "≤", strict orders "<", and structures that include both.
|
||||
-/
|
||||
import algebra.binary algebra.priority
|
||||
open eq eq.ops algebra
|
||||
-- set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
|
||||
/- weak orders -/
|
||||
|
||||
namespace algebra
|
||||
structure weak_order [class] (A : Type) extends has_le A :=
|
||||
(le_refl : Πa, le a a)
|
||||
(le_trans : Πa b c, le a b → le b c → le a c)
|
||||
(le_antisymm : Πa b, le a b → le b a → a = b)
|
||||
|
||||
section
|
||||
variable [s : weak_order A]
|
||||
include s
|
||||
|
||||
definition le.refl [refl] (a : A) : a ≤ a := !weak_order.le_refl
|
||||
|
||||
definition le_of_eq {a b : A} (H : a = b) : a ≤ b := H ▸ le.refl a
|
||||
|
||||
definition le.trans [trans] {a b c : A} : a ≤ b → b ≤ c → a ≤ c := !weak_order.le_trans
|
||||
|
||||
definition ge.trans [trans] {a b c : A} (H1 : a ≥ b) (H2: b ≥ c) : a ≥ c := le.trans H2 H1
|
||||
|
||||
definition le.antisymm {a b : A} : a ≤ b → b ≤ a → a = b := !weak_order.le_antisymm
|
||||
|
||||
-- Alternate syntax. (Abbreviations do not migrate well.)
|
||||
definition eq_of_le_of_ge {a b : A} : a ≤ b → b ≤ a → a = b := !le.antisymm
|
||||
end
|
||||
|
||||
structure linear_weak_order [class] (A : Type) extends weak_order A :=
|
||||
(le_total : Πa b, le a b ⊎ le b a)
|
||||
|
||||
section
|
||||
variables [linear_weak_order A]
|
||||
|
||||
theorem le.total (a b : A) : a ≤ b ⊎ b ≤ a := !linear_weak_order.le_total
|
||||
|
||||
theorem le_of_not_ge {a b : A} (H : ¬ a ≥ b) : a ≤ b := sum.resolve_left !le.total H
|
||||
|
||||
definition le_by_cases (a b : A) {P : Type} (H1 : a ≤ b → P) (H2 : b ≤ a → P) : P :=
|
||||
begin
|
||||
cases (le.total a b) with H H,
|
||||
{ exact H1 H},
|
||||
{ exact H2 H}
|
||||
end
|
||||
end
|
||||
|
||||
/- strict orders -/
|
||||
|
||||
structure strict_order [class] (A : Type) extends has_lt A :=
|
||||
(lt_irrefl : Πa, ¬ lt a a)
|
||||
(lt_trans : Πa b c, lt a b → lt b c → lt a c)
|
||||
|
||||
section
|
||||
variable [s : strict_order A]
|
||||
include s
|
||||
|
||||
definition lt.irrefl (a : A) : ¬ a < a := !strict_order.lt_irrefl
|
||||
definition not_lt_self (a : A) : ¬ a < a := !lt.irrefl -- alternate syntax
|
||||
|
||||
theorem lt_self_iff_empty (a : A) : a < a ↔ empty :=
|
||||
iff_empty_intro (lt.irrefl a)
|
||||
|
||||
definition lt.trans [trans] {a b c : A} : a < b → b < c → a < c := !strict_order.lt_trans
|
||||
|
||||
definition gt.trans [trans] {a b c : A} (H1 : a > b) (H2: b > c) : a > c := lt.trans H2 H1
|
||||
|
||||
theorem ne_of_lt {a b : A} (lt_ab : a < b) : a ≠ b :=
|
||||
assume eq_ab : a = b,
|
||||
show empty, from lt.irrefl b (eq_ab ▸ lt_ab)
|
||||
|
||||
theorem ne_of_gt {a b : A} (gt_ab : a > b) : a ≠ b :=
|
||||
ne.symm (ne_of_lt gt_ab)
|
||||
|
||||
theorem lt.asymm {a b : A} (H : a < b) : ¬ b < a :=
|
||||
assume H1 : b < a, lt.irrefl _ (lt.trans H H1)
|
||||
|
||||
theorem not_lt_of_gt {a b : A} (H : a > b) : ¬ a < b := !lt.asymm H -- alternate syntax
|
||||
end
|
||||
|
||||
/- well-founded orders -/
|
||||
|
||||
structure wf_strict_order [class] (A : Type) extends strict_order A :=
|
||||
(wf_rec : ΠP : A → Type, (Πx, (Πy, lt y x → P y) → P x) → Πx, P x)
|
||||
|
||||
definition wf.rec_on {A : Type} [s : wf_strict_order A] {P : A → Type}
|
||||
(x : A) (H : Πx, (Πy, wf_strict_order.lt y x → P y) → P x) : P x :=
|
||||
wf_strict_order.wf_rec P H x
|
||||
|
||||
/- structures with a weak and a strict order -/
|
||||
|
||||
structure order_pair [class] (A : Type) extends weak_order A, has_lt A :=
|
||||
(le_of_lt : Π a b, lt a b → le a b)
|
||||
(lt_of_lt_of_le : Π a b c, lt a b → le b c → lt a c)
|
||||
(lt_of_le_of_lt : Π a b c, le a b → lt b c → lt a c)
|
||||
(lt_irrefl : Π a, ¬ lt a a)
|
||||
|
||||
section
|
||||
variable [s : order_pair A]
|
||||
variables {a b c : A}
|
||||
include s
|
||||
|
||||
definition le_of_lt : a < b → a ≤ b := !order_pair.le_of_lt
|
||||
|
||||
definition lt_of_lt_of_le [trans] : a < b → b ≤ c → a < c := !order_pair.lt_of_lt_of_le
|
||||
|
||||
definition lt_of_le_of_lt [trans] : a ≤ b → b < c → a < c := !order_pair.lt_of_le_of_lt
|
||||
|
||||
private definition lt_irrefl (s' : order_pair A) (a : A) : ¬ a < a := !order_pair.lt_irrefl
|
||||
|
||||
private theorem lt_trans (s' : order_pair A) (a b c: A) (lt_ab : a < b) (lt_bc : b < c) : a < c :=
|
||||
lt_of_lt_of_le lt_ab (le_of_lt lt_bc)
|
||||
|
||||
definition order_pair.to_strict_order [trans_instance] : strict_order A :=
|
||||
⦃ strict_order, s, lt_irrefl := lt_irrefl s, lt_trans := lt_trans s ⦄
|
||||
|
||||
definition gt_of_gt_of_ge [trans] (H1 : a > b) (H2 : b ≥ c) : a > c := lt_of_le_of_lt H2 H1
|
||||
|
||||
definition gt_of_ge_of_gt [trans] (H1 : a ≥ b) (H2 : b > c) : a > c := lt_of_lt_of_le H2 H1
|
||||
|
||||
theorem not_le_of_gt (H : a > b) : ¬ a ≤ b :=
|
||||
assume H1 : a ≤ b,
|
||||
lt.irrefl _ (lt_of_lt_of_le H H1)
|
||||
|
||||
theorem not_lt_of_ge (H : a ≥ b) : ¬ a < b :=
|
||||
assume H1 : a < b,
|
||||
lt.irrefl _ (lt_of_le_of_lt H H1)
|
||||
end
|
||||
|
||||
structure strong_order_pair [class] (A : Type) extends weak_order A, has_lt A :=
|
||||
(le_iff_lt_sum_eq : Πa b, le a b ↔ lt a b ⊎ a = b)
|
||||
(lt_irrefl : Π a, ¬ lt a a)
|
||||
|
||||
definition le_iff_lt_sum_eq [s : strong_order_pair A] {a b : A} : a ≤ b ↔ a < b ⊎ a = b :=
|
||||
!strong_order_pair.le_iff_lt_sum_eq
|
||||
|
||||
theorem lt_sum_eq_of_le [s : strong_order_pair A] {a b : A} (le_ab : a ≤ b) : a < b ⊎ a = b :=
|
||||
iff.mp le_iff_lt_sum_eq le_ab
|
||||
|
||||
theorem le_of_lt_sum_eq [s : strong_order_pair A] {a b : A} (lt_sum_eq : a < b ⊎ a = b) : a ≤ b :=
|
||||
iff.mpr le_iff_lt_sum_eq lt_sum_eq
|
||||
|
||||
private definition lt_irrefl' [s : strong_order_pair A] (a : A) : ¬ a < a :=
|
||||
!strong_order_pair.lt_irrefl
|
||||
|
||||
private theorem le_of_lt' [s : strong_order_pair A] (a b : A) : a < b → a ≤ b :=
|
||||
take Hlt, le_of_lt_sum_eq (sum.inl Hlt)
|
||||
|
||||
private theorem lt_iff_le_prod_ne [s : strong_order_pair A] {a b : A} : a < b ↔ (a ≤ b × a ≠ b) :=
|
||||
iff.intro
|
||||
(take Hlt, pair (le_of_lt_sum_eq (sum.inl Hlt)) (take Hab, absurd (Hab ▸ Hlt) !lt_irrefl'))
|
||||
(take Hand,
|
||||
have Hor : a < b ⊎ a = b, from lt_sum_eq_of_le (prod.pr1 Hand),
|
||||
sum_resolve_left Hor (prod.pr2 Hand))
|
||||
|
||||
theorem lt_of_le_of_ne [s : strong_order_pair A] {a b : A} : a ≤ b → a ≠ b → a < b :=
|
||||
take H1 H2, iff.mpr lt_iff_le_prod_ne (pair H1 H2)
|
||||
|
||||
private theorem ne_of_lt' [s : strong_order_pair A] {a b : A} (H : a < b) : a ≠ b :=
|
||||
prod.pr2 ((iff.mp (@lt_iff_le_prod_ne _ _ _ _)) H)
|
||||
|
||||
private theorem lt_of_lt_of_le' [s : strong_order_pair A] (a b c : A) : a < b → b ≤ c → a < c :=
|
||||
assume lt_ab : a < b,
|
||||
assume le_bc : b ≤ c,
|
||||
have le_ac : a ≤ c, from le.trans (le_of_lt' _ _ lt_ab) le_bc,
|
||||
have ne_ac : a ≠ c, from
|
||||
assume eq_ac : a = c,
|
||||
have le_ba : b ≤ a, from eq_ac⁻¹ ▸ le_bc,
|
||||
have eq_ab : a = b, from le.antisymm (le_of_lt' _ _ lt_ab) le_ba,
|
||||
show empty, from ne_of_lt' lt_ab eq_ab,
|
||||
show a < c, from iff.mpr (lt_iff_le_prod_ne) (pair le_ac ne_ac)
|
||||
|
||||
theorem lt_of_le_of_lt' [s : strong_order_pair A] (a b c : A) : a ≤ b → b < c → a < c :=
|
||||
assume le_ab : a ≤ b,
|
||||
assume lt_bc : b < c,
|
||||
have le_ac : a ≤ c, from le.trans le_ab (le_of_lt' _ _ lt_bc),
|
||||
have ne_ac : a ≠ c, from
|
||||
assume eq_ac : a = c,
|
||||
have le_cb : c ≤ b, from eq_ac ▸ le_ab,
|
||||
have eq_bc : b = c, from le.antisymm (le_of_lt' _ _ lt_bc) le_cb,
|
||||
show empty, from ne_of_lt' lt_bc eq_bc,
|
||||
show a < c, from iff.mpr (lt_iff_le_prod_ne) (pair le_ac ne_ac)
|
||||
|
||||
definition strong_order_pair.to_order_pair [trans_instance] [s : strong_order_pair A] : order_pair A :=
|
||||
⦃ order_pair, s,
|
||||
lt_irrefl := lt_irrefl',
|
||||
le_of_lt := le_of_lt',
|
||||
lt_of_le_of_lt := lt_of_le_of_lt',
|
||||
lt_of_lt_of_le := lt_of_lt_of_le' ⦄
|
||||
|
||||
/- linear orders -/
|
||||
|
||||
structure linear_order_pair [class] (A : Type) extends order_pair A, linear_weak_order A
|
||||
|
||||
structure linear_strong_order_pair [class] (A : Type) extends strong_order_pair A,
|
||||
linear_weak_order A
|
||||
|
||||
definition linear_strong_order_pair.to_linear_order_pair [trans_instance]
|
||||
[s : linear_strong_order_pair A] : linear_order_pair A :=
|
||||
⦃ linear_order_pair, s, strong_order_pair.to_order_pair ⦄
|
||||
|
||||
section
|
||||
variable [s : linear_strong_order_pair A]
|
||||
variables (a b c : A)
|
||||
include s
|
||||
|
||||
theorem lt.trichotomy : a < b ⊎ a = b ⊎ b < a :=
|
||||
sum.elim (le.total a b)
|
||||
(assume H : a ≤ b,
|
||||
sum.elim (iff.mp !le_iff_lt_sum_eq H) (assume H1, sum.inl H1) (assume H1, sum.inr (sum.inl H1)))
|
||||
(assume H : b ≤ a,
|
||||
sum.elim (iff.mp !le_iff_lt_sum_eq H)
|
||||
(assume H1, sum.inr (sum.inr H1))
|
||||
(assume H1, sum.inr (sum.inl (H1⁻¹))))
|
||||
|
||||
definition lt.by_cases {a b : A} {P : Type}
|
||||
(H1 : a < b → P) (H2 : a = b → P) (H3 : b < a → P) : P :=
|
||||
sum.elim !lt.trichotomy
|
||||
(assume H, H1 H)
|
||||
(assume H, sum.elim H (assume H', H2 H') (assume H', H3 H'))
|
||||
|
||||
definition lt_ge_by_cases {a b : A} {P : Type} (H1 : a < b → P) (H2 : a ≥ b → P) : P :=
|
||||
lt.by_cases H1 (λH, H2 (H ▸ le.refl a)) (λH, H2 (le_of_lt H))
|
||||
|
||||
theorem le_of_not_gt {a b : A} (H : ¬ a > b) : a ≤ b :=
|
||||
lt.by_cases (assume H', absurd H' H) (assume H', H' ▸ !le.refl) (assume H', le_of_lt H')
|
||||
|
||||
theorem lt_of_not_ge {a b : A} (H : ¬ a ≥ b) : a < b :=
|
||||
lt.by_cases
|
||||
(assume H', absurd (le_of_lt H') H)
|
||||
(assume H', absurd (H' ▸ !le.refl) H)
|
||||
(assume H', H')
|
||||
|
||||
theorem lt_sum_ge : a < b ⊎ a ≥ b :=
|
||||
lt.by_cases
|
||||
(assume H1 : a < b, sum.inl H1)
|
||||
(assume H1 : a = b, sum.inr (H1 ▸ le.refl a))
|
||||
(assume H1 : a > b, sum.inr (le_of_lt H1))
|
||||
|
||||
theorem le_sum_gt : a ≤ b ⊎ a > b :=
|
||||
!sum.swap (lt_sum_ge b a)
|
||||
|
||||
theorem lt_sum_gt_of_ne {a b : A} (H : a ≠ b) : a < b ⊎ a > b :=
|
||||
lt.by_cases (assume H1, sum.inl H1) (assume H1, absurd H1 H) (assume H1, sum.inr H1)
|
||||
end
|
||||
|
||||
open decidable
|
||||
|
||||
structure decidable_linear_order [class] (A : Type) extends linear_strong_order_pair A :=
|
||||
(decidable_lt : decidable_rel lt)
|
||||
|
||||
section
|
||||
variable [s : decidable_linear_order A]
|
||||
variables {a b c d : A}
|
||||
include s
|
||||
open decidable
|
||||
|
||||
definition decidable_lt [instance] : decidable (a < b) :=
|
||||
@decidable_linear_order.decidable_lt _ _ _ _
|
||||
|
||||
definition decidable_le [instance] : decidable (a ≤ b) :=
|
||||
by_cases
|
||||
(assume H : a < b, inl (le_of_lt H))
|
||||
(assume H : ¬ a < b,
|
||||
have H1 : b ≤ a, from le_of_not_gt H,
|
||||
by_cases
|
||||
(assume H2 : b < a, inr (not_le_of_gt H2))
|
||||
(assume H2 : ¬ b < a, inl (le_of_not_gt H2)))
|
||||
|
||||
definition has_decidable_eq [instance] : decidable (a = b) :=
|
||||
by_cases
|
||||
(assume H : a ≤ b,
|
||||
by_cases
|
||||
(assume H1 : b ≤ a, inl (le.antisymm H H1))
|
||||
(assume H1 : ¬ b ≤ a, inr (assume H2 : a = b, H1 (H2 ▸ le.refl a))))
|
||||
(assume H : ¬ a ≤ b,
|
||||
(inr (assume H1 : a = b, H (H1 ▸ !le.refl))))
|
||||
|
||||
theorem eq_sum_lt_of_not_lt {a b : A} (H : ¬ a < b) : a = b ⊎ b < a :=
|
||||
if Heq : a = b then sum.inl Heq else sum.inr (lt_of_not_ge (λ Hge, H (lt_of_le_of_ne Hge Heq)))
|
||||
|
||||
theorem eq_sum_lt_of_le {a b : A} (H : a ≤ b) : a = b ⊎ a < b :=
|
||||
begin
|
||||
cases eq_sum_lt_of_not_lt (not_lt_of_ge H),
|
||||
exact sum.inl a_1⁻¹,
|
||||
exact sum.inr a_1
|
||||
end
|
||||
|
||||
|
||||
-- testing equality first may result in more definitional equalities
|
||||
definition lt.cases {B : Type} (a b : A) (t_lt t_eq t_gt : B) : B :=
|
||||
if a = b then t_eq else (if a < b then t_lt else t_gt)
|
||||
|
||||
theorem lt.cases_of_eq {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a = b) :
|
||||
lt.cases a b t_lt t_eq t_gt = t_eq := if_pos H
|
||||
|
||||
theorem lt.cases_of_lt {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a < b) :
|
||||
lt.cases a b t_lt t_eq t_gt = t_lt :=
|
||||
if_neg (ne_of_lt H) ⬝ if_pos H
|
||||
|
||||
theorem lt.cases_of_gt {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a > b) :
|
||||
lt.cases a b t_lt t_eq t_gt = t_gt :=
|
||||
if_neg (ne.symm (ne_of_lt H)) ⬝ if_neg (lt.asymm H)
|
||||
|
||||
definition min (a b : A) : A := if a ≤ b then a else b
|
||||
definition max (a b : A) : A := if a ≤ b then b else a
|
||||
|
||||
/- these show min and max form a lattice -/
|
||||
|
||||
theorem min_le_left (a b : A) : min a b ≤ a :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑min, if_pos H])
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H]; apply le_of_lt (lt_of_not_ge H))
|
||||
|
||||
theorem min_le_right (a b : A) : min a b ≤ b :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑min, if_pos H]; apply H)
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H])
|
||||
|
||||
theorem le_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ min a b :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑min, if_pos H]; apply H₁)
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H]; apply H₂)
|
||||
|
||||
theorem le_max_left (a b : A) : a ≤ max a b :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑max, if_pos H]; apply H)
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H])
|
||||
|
||||
theorem le_max_right (a b : A) : b ≤ max a b :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑max, if_pos H])
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H]; apply le_of_lt (lt_of_not_ge H))
|
||||
|
||||
theorem max_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : max a b ≤ c :=
|
||||
by_cases
|
||||
(assume H : a ≤ b, by rewrite [↑max, if_pos H]; apply H₂)
|
||||
(assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H]; apply H₁)
|
||||
|
||||
theorem le_max_left_iff_unit (a b : A) : a ≤ max a b ↔ unit :=
|
||||
iff_unit_intro (le_max_left a b)
|
||||
|
||||
theorem le_max_right_iff_unit (a b : A) : b ≤ max a b ↔ unit :=
|
||||
iff_unit_intro (le_max_right a b)
|
||||
|
||||
/- these are also proved for lattices, but with inf and sup in place of min and max -/
|
||||
|
||||
theorem eq_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : Π{d}, d ≤ a → d ≤ b → d ≤ c) :
|
||||
c = min a b :=
|
||||
le.antisymm (le_min H₁ H₂) (H₃ !min_le_left !min_le_right)
|
||||
|
||||
theorem min.comm (a b : A) : min a b = min b a :=
|
||||
eq_min !min_le_right !min_le_left (λ c H₁ H₂, le_min H₂ H₁)
|
||||
|
||||
theorem min.assoc (a b c : A) : min (min a b) c = min a (min b c) :=
|
||||
begin
|
||||
apply eq_min,
|
||||
{ apply le.trans, apply min_le_left, apply min_le_left },
|
||||
{ apply le_min, apply le.trans, apply min_le_left, apply min_le_right, apply min_le_right },
|
||||
{ intros [d, H₁, H₂], apply le_min, apply le_min H₁, apply le.trans H₂, apply min_le_left,
|
||||
apply le.trans H₂, apply min_le_right }
|
||||
end
|
||||
|
||||
theorem min.left_comm (a b c : A) : min a (min b c) = min b (min a c) :=
|
||||
binary.left_comm (@min.comm A s) (@min.assoc A s) a b c
|
||||
|
||||
theorem min.right_comm (a b c : A) : min (min a b) c = min (min a c) b :=
|
||||
binary.right_comm (@min.comm A s) (@min.assoc A s) a b c
|
||||
|
||||
theorem min_self (a : A) : min a a = a :=
|
||||
by apply inverse; apply eq_min (le.refl a) !le.refl; intros; assumption
|
||||
|
||||
theorem min_eq_left {a b : A} (H : a ≤ b) : min a b = a :=
|
||||
by apply inverse; apply eq_min !le.refl H; intros; assumption
|
||||
|
||||
theorem min_eq_right {a b : A} (H : b ≤ a) : min a b = b :=
|
||||
eq.subst !min.comm (min_eq_left H)
|
||||
|
||||
theorem eq_max {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : Π{d}, a ≤ d → b ≤ d → c ≤ d) :
|
||||
c = max a b :=
|
||||
le.antisymm (H₃ !le_max_left !le_max_right) (max_le H₁ H₂)
|
||||
|
||||
theorem max.comm (a b : A) : max a b = max b a :=
|
||||
eq_max !le_max_right !le_max_left (λ c H₁ H₂, max_le H₂ H₁)
|
||||
|
||||
theorem max.assoc (a b c : A) : max (max a b) c = max a (max b c) :=
|
||||
begin
|
||||
apply eq_max,
|
||||
{ apply le.trans, apply le_max_left a b, apply le_max_left },
|
||||
{ apply max_le, apply le.trans, apply le_max_right a b, apply le_max_left, apply le_max_right },
|
||||
{ intros [d, H₁, H₂], apply max_le, apply max_le H₁, apply le.trans !le_max_left H₂,
|
||||
apply le.trans !le_max_right H₂}
|
||||
end
|
||||
|
||||
theorem max.left_comm (a b c : A) : max a (max b c) = max b (max a c) :=
|
||||
binary.left_comm (@max.comm A s) (@max.assoc A s) a b c
|
||||
|
||||
theorem max.right_comm (a b c : A) : max (max a b) c = max (max a c) b :=
|
||||
binary.right_comm (@max.comm A s) (@max.assoc A s) a b c
|
||||
|
||||
theorem max_self (a : A) : max a a = a :=
|
||||
by apply inverse; apply eq_max (le.refl a) !le.refl; intros; assumption
|
||||
|
||||
theorem max_eq_left {a b : A} (H : b ≤ a) : max a b = a :=
|
||||
by apply inverse; apply eq_max !le.refl H; intros; assumption
|
||||
|
||||
theorem max_eq_right {a b : A} (H : a ≤ b) : max a b = b :=
|
||||
eq.subst !max.comm (max_eq_left H)
|
||||
|
||||
/- these rely on lt_of_lt -/
|
||||
|
||||
theorem min_eq_left_of_lt {a b : A} (H : a < b) : min a b = a :=
|
||||
min_eq_left (le_of_lt H)
|
||||
|
||||
theorem min_eq_right_of_lt {a b : A} (H : b < a) : min a b = b :=
|
||||
min_eq_right (le_of_lt H)
|
||||
|
||||
theorem max_eq_left_of_lt {a b : A} (H : b < a) : max a b = a :=
|
||||
max_eq_left (le_of_lt H)
|
||||
|
||||
theorem max_eq_right_of_lt {a b : A} (H : a < b) : max a b = b :=
|
||||
max_eq_right (le_of_lt H)
|
||||
|
||||
/- these use the fact that it is a linear ordering -/
|
||||
|
||||
theorem lt_min {a b c : A} (H₁ : a < b) (H₂ : a < c) : a < min b c :=
|
||||
sum.elim !le_sum_gt
|
||||
(assume H : b ≤ c, by rewrite (min_eq_left H); apply H₁)
|
||||
(assume H : b > c, by rewrite (min_eq_right_of_lt H); apply H₂)
|
||||
|
||||
theorem max_lt {a b c : A} (H₁ : a < c) (H₂ : b < c) : max a b < c :=
|
||||
sum.elim !le_sum_gt
|
||||
(assume H : a ≤ b, by rewrite (max_eq_right H); apply H₂)
|
||||
(assume H : a > b, by rewrite (max_eq_left_of_lt H); apply H₁)
|
||||
end
|
||||
end algebra
|
||||
|
|
@ -1,518 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Robert Lewis. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Robert Lewis
|
||||
-/
|
||||
import algebra.ordered_ring algebra.field
|
||||
open eq eq.ops algebra
|
||||
set_option class.force_new true
|
||||
|
||||
namespace algebra
|
||||
structure linear_ordered_field [class] (A : Type) extends linear_ordered_ring A, field A
|
||||
|
||||
section linear_ordered_field
|
||||
|
||||
variable {A : Type}
|
||||
variables [s : linear_ordered_field A] {a b c d : A}
|
||||
include s
|
||||
|
||||
-- helpers for following
|
||||
theorem mul_zero_lt_mul_inv_of_pos (H : 0 < a) : a * 0 < a * (1 / a) :=
|
||||
calc
|
||||
a * 0 = 0 : mul_zero
|
||||
... < 1 : zero_lt_one
|
||||
... = a * a⁻¹ : mul_inv_cancel (ne.symm (ne_of_lt H))
|
||||
... = a * (1 / a) : inv_eq_one_div
|
||||
|
||||
theorem mul_zero_lt_mul_inv_of_neg (H : a < 0) : a * 0 < a * (1 / a) :=
|
||||
calc
|
||||
a * 0 = 0 : mul_zero
|
||||
... < 1 : zero_lt_one
|
||||
... = a * a⁻¹ : mul_inv_cancel (ne_of_lt H)
|
||||
... = a * (1 / a) : inv_eq_one_div
|
||||
|
||||
theorem one_div_pos_of_pos (H : 0 < a) : 0 < 1 / a :=
|
||||
lt_of_mul_lt_mul_left (mul_zero_lt_mul_inv_of_pos H) (le_of_lt H)
|
||||
|
||||
theorem one_div_neg_of_neg (H : a < 0) : 1 / a < 0 :=
|
||||
gt_of_mul_lt_mul_neg_left (mul_zero_lt_mul_inv_of_neg H) (le_of_lt H)
|
||||
|
||||
|
||||
theorem le_mul_of_ge_one_right (Hb : b ≥ 0) (H : a ≥ 1) : b ≤ b * a :=
|
||||
mul_one _ ▸ (mul_le_mul_of_nonneg_left H Hb)
|
||||
|
||||
theorem lt_mul_of_gt_one_right (Hb : b > 0) (H : a > 1) : b < b * a :=
|
||||
mul_one _ ▸ (mul_lt_mul_of_pos_left H Hb)
|
||||
|
||||
theorem one_le_div_iff_le (a : A) {b : A} (Hb : b > 0) : 1 ≤ a / b ↔ b ≤ a :=
|
||||
have Hb' : b ≠ 0, from ne.symm (ne_of_lt Hb),
|
||||
iff.intro
|
||||
(assume H : 1 ≤ a / b,
|
||||
calc
|
||||
b = b : refl
|
||||
... ≤ b * (a / b) : le_mul_of_ge_one_right (le_of_lt Hb) H
|
||||
... = a : mul_div_cancel' Hb')
|
||||
(assume H : b ≤ a,
|
||||
have Hbinv : 1 / b > 0, from one_div_pos_of_pos Hb, calc
|
||||
1 = b * (1 / b) : mul_one_div_cancel Hb'
|
||||
... ≤ a * (1 / b) : mul_le_mul_of_nonneg_right H (le_of_lt Hbinv)
|
||||
... = a / b : div_eq_mul_one_div)
|
||||
|
||||
theorem le_of_one_le_div (Hb : b > 0) (H : 1 ≤ a / b) : b ≤ a :=
|
||||
(iff.mp (!one_le_div_iff_le Hb)) H
|
||||
|
||||
theorem one_le_div_of_le (Hb : b > 0) (H : b ≤ a) : 1 ≤ a / b :=
|
||||
(iff.mpr (!one_le_div_iff_le Hb)) H
|
||||
|
||||
theorem one_lt_div_iff_lt (a : A) {b : A} (Hb : b > 0) : 1 < a / b ↔ b < a :=
|
||||
have Hb' : b ≠ 0, from ne.symm (ne_of_lt Hb),
|
||||
iff.intro
|
||||
(assume H : 1 < a / b,
|
||||
calc
|
||||
b < b * (a / b) : lt_mul_of_gt_one_right Hb H
|
||||
... = a : mul_div_cancel' Hb')
|
||||
(assume H : b < a,
|
||||
have Hbinv : 1 / b > 0, from one_div_pos_of_pos Hb, calc
|
||||
1 = b * (1 / b) : mul_one_div_cancel Hb'
|
||||
... < a * (1 / b) : mul_lt_mul_of_pos_right H Hbinv
|
||||
... = a / b : div_eq_mul_one_div)
|
||||
|
||||
theorem lt_of_one_lt_div (Hb : b > 0) (H : 1 < a / b) : b < a :=
|
||||
(iff.mp (!one_lt_div_iff_lt Hb)) H
|
||||
|
||||
theorem one_lt_div_of_lt (Hb : b > 0) (H : b < a) : 1 < a / b :=
|
||||
(iff.mpr (!one_lt_div_iff_lt Hb)) H
|
||||
|
||||
theorem exists_lt (a : A) : Σ x, x < a :=
|
||||
have H : a - 1 < a, from add_lt_of_le_of_neg (le.refl _) zero_gt_neg_one,
|
||||
sigma.mk _ H
|
||||
|
||||
theorem exists_gt (a : A) : Σ x, x > a :=
|
||||
have H : a + 1 > a, from lt_add_of_le_of_pos (le.refl _) zero_lt_one,
|
||||
sigma.mk _ H
|
||||
|
||||
-- the following theorems amount to four iffs, for <, ≤, ≥, >.
|
||||
|
||||
theorem mul_le_of_le_div (Hc : 0 < c) (H : a ≤ b / c) : a * c ≤ b :=
|
||||
!div_mul_cancel (ne.symm (ne_of_lt Hc)) ▸ mul_le_mul_of_nonneg_right H (le_of_lt Hc)
|
||||
|
||||
theorem le_div_of_mul_le (Hc : 0 < c) (H : a * c ≤ b) : a ≤ b / c :=
|
||||
calc
|
||||
a = a * c * (1 / c) : !mul_mul_div (ne.symm (ne_of_lt Hc))
|
||||
... ≤ b * (1 / c) : mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hc))
|
||||
... = b / c : div_eq_mul_one_div
|
||||
|
||||
theorem mul_lt_of_lt_div (Hc : 0 < c) (H : a < b / c) : a * c < b :=
|
||||
!div_mul_cancel (ne.symm (ne_of_lt Hc)) ▸ mul_lt_mul_of_pos_right H Hc
|
||||
|
||||
theorem lt_div_of_mul_lt (Hc : 0 < c) (H : a * c < b) : a < b / c :=
|
||||
calc
|
||||
a = a * c * (1 / c) : !mul_mul_div (ne.symm (ne_of_lt Hc))
|
||||
... < b * (1 / c) : mul_lt_mul_of_pos_right H (one_div_pos_of_pos Hc)
|
||||
... = b / c : div_eq_mul_one_div
|
||||
|
||||
theorem mul_le_of_div_le_of_neg (Hc : c < 0) (H : b / c ≤ a) : a * c ≤ b :=
|
||||
!div_mul_cancel (ne_of_lt Hc) ▸ mul_le_mul_of_nonpos_right H (le_of_lt Hc)
|
||||
|
||||
theorem div_le_of_mul_le_of_neg (Hc : c < 0) (H : a * c ≤ b) : b / c ≤ a :=
|
||||
calc
|
||||
a = a * c * (1 / c) : !mul_mul_div (ne_of_lt Hc)
|
||||
... ≥ b * (1 / c) : mul_le_mul_of_nonpos_right H (le_of_lt (one_div_neg_of_neg Hc))
|
||||
... = b / c : div_eq_mul_one_div
|
||||
|
||||
theorem mul_lt_of_gt_div_of_neg (Hc : c < 0) (H : a > b / c) : a * c < b :=
|
||||
!div_mul_cancel (ne_of_lt Hc) ▸ mul_lt_mul_of_neg_right H Hc
|
||||
|
||||
theorem div_lt_of_mul_gt_of_neg (Hc : c < 0) (H : a * c < b) : b / c < a :=
|
||||
calc
|
||||
a = a * c * (1 / c) : !mul_mul_div (ne_of_lt Hc)
|
||||
... > b * (1 / c) : mul_lt_mul_of_neg_right H (one_div_neg_of_neg Hc)
|
||||
... = b / c : div_eq_mul_one_div
|
||||
|
||||
theorem div_le_of_le_mul (Hb : b > 0) (H : a ≤ b * c) : a / b ≤ c :=
|
||||
calc
|
||||
a / b = a * (1 / b) : div_eq_mul_one_div
|
||||
... ≤ (b * c) * (1 / b) : mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hb))
|
||||
... = (b * c) / b : div_eq_mul_one_div
|
||||
... = c : mul_div_cancel_left (ne.symm (ne_of_lt Hb))
|
||||
|
||||
theorem le_mul_of_div_le (Hc : c > 0) (H : a / c ≤ b) : a ≤ b * c :=
|
||||
calc
|
||||
a = a / c * c : !div_mul_cancel (ne.symm (ne_of_lt Hc))
|
||||
... ≤ b * c : mul_le_mul_of_nonneg_right H (le_of_lt Hc)
|
||||
|
||||
-- following these in the isabelle file, there are 8 biconditionals for the above with - signs
|
||||
-- skipping for now
|
||||
|
||||
theorem mul_sub_mul_div_mul_neg (Hc : c ≠ 0) (Hd : d ≠ 0) (H : a / c < b / d) :
|
||||
(a * d - b * c) / (c * d) < 0 :=
|
||||
have H1 : a / c - b / d < 0, from calc
|
||||
a / c - b / d < b / d - b / d : sub_lt_sub_right H
|
||||
... = 0 : sub_self,
|
||||
calc
|
||||
0 > a / c - b / d : H1
|
||||
... = (a * d - c * b) / (c * d) : !div_sub_div Hc Hd
|
||||
... = (a * d - b * c) / (c * d) : mul.comm
|
||||
|
||||
theorem mul_sub_mul_div_mul_nonpos (Hc : c ≠ 0) (Hd : d ≠ 0) (H : a / c ≤ b / d) :
|
||||
(a * d - b * c) / (c * d) ≤ 0 :=
|
||||
have H1 : a / c - b / d ≤ 0, from calc
|
||||
a / c - b / d ≤ b / d - b / d : sub_le_sub_right H
|
||||
... = 0 : sub_self,
|
||||
calc
|
||||
0 ≥ a / c - b / d : H1
|
||||
... = (a * d - c * b) / (c * d) : !div_sub_div Hc Hd
|
||||
... = (a * d - b * c) / (c * d) : mul.comm
|
||||
|
||||
theorem div_lt_div_of_mul_sub_mul_div_neg (Hc : c ≠ 0) (Hd : d ≠ 0)
|
||||
(H : (a * d - b * c) / (c * d) < 0) : a / c < b / d :=
|
||||
have H1 : (a * d - c * b) / (c * d) < 0, by rewrite [mul.comm c b]; exact H,
|
||||
have H2 : a / c - b / d < 0, by rewrite [!div_sub_div Hc Hd]; exact H1,
|
||||
have H3 : a / c - b / d + b / d < 0 + b / d, from add_lt_add_right H2 _,
|
||||
begin rewrite [zero_add at H3, sub_eq_add_neg at H3, neg_add_cancel_right at H3], exact H3 end
|
||||
|
||||
theorem div_le_div_of_mul_sub_mul_div_nonpos (Hc : c ≠ 0) (Hd : d ≠ 0)
|
||||
(H : (a * d - b * c) / (c * d) ≤ 0) : a / c ≤ b / d :=
|
||||
have H1 : (a * d - c * b) / (c * d) ≤ 0, by rewrite [mul.comm c b]; exact H,
|
||||
have H2 : a / c - b / d ≤ 0, by rewrite [!div_sub_div Hc Hd]; exact H1,
|
||||
have H3 : a / c - b / d + b / d ≤ 0 + b / d, from add_le_add_right H2 _,
|
||||
begin rewrite [zero_add at H3, sub_eq_add_neg at H3, neg_add_cancel_right at H3], exact H3 end
|
||||
|
||||
theorem div_pos_of_pos_of_pos (Ha : 0 < a) (Hb : 0 < b) : 0 < a / b :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_pos,
|
||||
exact Ha,
|
||||
apply one_div_pos_of_pos,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_nonneg_of_nonneg_of_pos (Ha : 0 ≤ a) (Hb : 0 < b) : 0 ≤ a / b :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_nonneg,
|
||||
exact Ha,
|
||||
apply le_of_lt,
|
||||
apply one_div_pos_of_pos,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_neg_of_neg_of_pos (Ha : a < 0) (Hb : 0 < b) : a / b < 0:=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_neg_of_neg_of_pos,
|
||||
exact Ha,
|
||||
apply one_div_pos_of_pos,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_nonpos_of_nonpos_of_pos (Ha : a ≤ 0) (Hb : 0 < b) : a / b ≤ 0 :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_nonpos_of_nonpos_of_nonneg,
|
||||
exact Ha,
|
||||
apply le_of_lt,
|
||||
apply one_div_pos_of_pos,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_neg_of_pos_of_neg (Ha : 0 < a) (Hb : b < 0) : a / b < 0 :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_neg_of_pos_of_neg,
|
||||
exact Ha,
|
||||
apply one_div_neg_of_neg,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_nonpos_of_nonneg_of_neg (Ha : 0 ≤ a) (Hb : b < 0) : a / b ≤ 0 :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_nonpos_of_nonneg_of_nonpos,
|
||||
exact Ha,
|
||||
apply le_of_lt,
|
||||
apply one_div_neg_of_neg,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_pos_of_neg_of_neg (Ha : a < 0) (Hb : b < 0) : 0 < a / b :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_pos_of_neg_of_neg,
|
||||
exact Ha,
|
||||
apply one_div_neg_of_neg,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_nonneg_of_nonpos_of_neg (Ha : a ≤ 0) (Hb : b < 0) : 0 ≤ a / b :=
|
||||
begin
|
||||
rewrite div_eq_mul_one_div,
|
||||
apply mul_nonneg_of_nonpos_of_nonpos,
|
||||
exact Ha,
|
||||
apply le_of_lt,
|
||||
apply one_div_neg_of_neg,
|
||||
exact Hb
|
||||
end
|
||||
|
||||
theorem div_lt_div_of_lt_of_pos (H : a < b) (Hc : 0 < c) : a / c < b / c :=
|
||||
begin
|
||||
rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div],
|
||||
exact mul_lt_mul_of_pos_right H (one_div_pos_of_pos Hc)
|
||||
end
|
||||
|
||||
theorem div_le_div_of_le_of_pos (H : a ≤ b) (Hc : 0 < c) : a / c ≤ b / c :=
|
||||
begin
|
||||
rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div],
|
||||
exact mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hc))
|
||||
end
|
||||
|
||||
theorem div_lt_div_of_lt_of_neg (H : b < a) (Hc : c < 0) : a / c < b / c :=
|
||||
begin
|
||||
rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div],
|
||||
exact mul_lt_mul_of_neg_right H (one_div_neg_of_neg Hc)
|
||||
end
|
||||
|
||||
theorem div_le_div_of_le_of_neg (H : b ≤ a) (Hc : c < 0) : a / c ≤ b / c :=
|
||||
begin
|
||||
rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div],
|
||||
exact mul_le_mul_of_nonpos_right H (le_of_lt (one_div_neg_of_neg Hc))
|
||||
end
|
||||
|
||||
theorem two_pos : (1 : A) + 1 > 0 :=
|
||||
add_pos zero_lt_one zero_lt_one
|
||||
|
||||
theorem one_add_one_ne_zero : 1 + 1 ≠ (0:A) :=
|
||||
ne.symm (ne_of_lt two_pos)
|
||||
|
||||
theorem two_ne_zero : 2 ≠ (0:A) :=
|
||||
by unfold bit0; apply one_add_one_ne_zero
|
||||
|
||||
theorem add_halves (a : A) : a / 2 + a / 2 = a :=
|
||||
calc
|
||||
a / 2 + a / 2 = (a + a) / 2 : by rewrite div_add_div_same
|
||||
... = (a * 1 + a * 1) / 2 : by rewrite mul_one
|
||||
... = (a * (1 + 1)) / 2 : by rewrite left_distrib
|
||||
... = (a * 2) / 2 : by rewrite one_add_one_eq_two
|
||||
... = a : by rewrite [@mul_div_cancel A _ _ _ two_ne_zero]
|
||||
|
||||
theorem sub_self_div_two (a : A) : a - a / 2 = a / 2 :=
|
||||
by rewrite [-{a}add_halves at {1}, add_sub_cancel]
|
||||
|
||||
theorem add_midpoint {a b : A} (H : a < b) : a + (b - a) / 2 < b :=
|
||||
begin
|
||||
rewrite [-div_sub_div_same, sub_eq_add_neg, {b / 2 + _}add.comm, -add.assoc, -sub_eq_add_neg],
|
||||
apply add_lt_of_lt_sub_right,
|
||||
rewrite *sub_self_div_two,
|
||||
apply div_lt_div_of_lt_of_pos H two_pos
|
||||
end
|
||||
|
||||
theorem div_two_sub_self (a : A) : a / 2 - a = - (a / 2) :=
|
||||
by rewrite [-{a}add_halves at {2}, sub_add_eq_sub_sub, sub_self, zero_sub]
|
||||
|
||||
theorem add_self_div_two (a : A) : (a + a) / 2 = a :=
|
||||
symm (iff.mpr (!eq_div_iff_mul_eq (ne_of_gt (add_pos zero_lt_one zero_lt_one)))
|
||||
(by krewrite [left_distrib, *mul_one]))
|
||||
|
||||
theorem two_ge_one : (2:A) ≥ 1 :=
|
||||
calc (2:A) = 1+1 : one_add_one_eq_two
|
||||
... ≥ 1+0 : add_le_add_left (le_of_lt zero_lt_one)
|
||||
... = 1 : add_zero
|
||||
|
||||
theorem mul_le_mul_of_mul_div_le (H : a * (b / c) ≤ d) (Hc : c > 0) : b * a ≤ d * c :=
|
||||
begin
|
||||
rewrite [-mul_div_assoc at H, mul.comm b],
|
||||
apply le_mul_of_div_le Hc H
|
||||
end
|
||||
|
||||
theorem div_two_lt_of_pos (H : a > 0) : a / (1 + 1) < a :=
|
||||
have Ha : a / (1 + 1) > 0, from div_pos_of_pos_of_pos H (add_pos zero_lt_one zero_lt_one),
|
||||
calc
|
||||
a / (1 + 1) < a / (1 + 1) + a / (1 + 1) : lt_add_of_pos_left Ha
|
||||
... = a : add_halves
|
||||
|
||||
theorem div_mul_le_div_mul_of_div_le_div_pos {e : A} (Hb : b ≠ 0) (Hd : d ≠ 0) (H : a / b ≤ c / d)
|
||||
(He : e > 0) : a / (b * e) ≤ c / (d * e) :=
|
||||
begin
|
||||
rewrite [!field.div_mul_eq_div_mul_one_div Hb (ne_of_gt He),
|
||||
!field.div_mul_eq_div_mul_one_div Hd (ne_of_gt He)],
|
||||
apply mul_le_mul_of_nonneg_right H,
|
||||
apply le_of_lt,
|
||||
apply one_div_pos_of_pos He
|
||||
end
|
||||
|
||||
theorem exists_add_lt_prod_pos_of_lt (H : b < a) : Σ c : A, b + c < a × c > 0 :=
|
||||
sigma.mk ((a - b) / (1 + 1))
|
||||
(pair (have H2 : a + a > (b + b) + (a - b), from calc
|
||||
a + a > b + a : add_lt_add_right H
|
||||
... = b + a + b - b : by rewrite add_sub_cancel
|
||||
... = b + b + a - b : by rewrite add.right_comm
|
||||
... = (b + b) + (a - b) : by rewrite add_sub,
|
||||
have H3 : (a + a) / 2 > ((b + b) + (a - b)) / 2,
|
||||
from div_lt_div_of_lt_of_pos H2 two_pos,
|
||||
by rewrite [one_add_one_eq_two, sub_eq_add_neg, add_self_div_two at H3, -div_add_div_same at H3, add_self_div_two at H3];
|
||||
exact H3)
|
||||
(div_pos_of_pos_of_pos (iff.mpr !sub_pos_iff_lt H) two_pos))
|
||||
|
||||
theorem ge_of_forall_ge_sub {a b : A} (H : Π ε : A, ε > 0 → a ≥ b - ε) : a ≥ b :=
|
||||
begin
|
||||
apply le_of_not_gt,
|
||||
intro Hb,
|
||||
cases exists_add_lt_prod_pos_of_lt Hb with [c, Hc],
|
||||
let Hc' := H c (prod.pr2 Hc),
|
||||
apply (not_le_of_gt (prod.pr1 Hc)) (iff.mpr !le_add_iff_sub_right_le Hc')
|
||||
end
|
||||
|
||||
end linear_ordered_field
|
||||
|
||||
structure discrete_linear_ordered_field [class] (A : Type) extends linear_ordered_field A,
|
||||
decidable_linear_ordered_comm_ring A :=
|
||||
(inv_zero : inv zero = zero)
|
||||
|
||||
section discrete_linear_ordered_field
|
||||
|
||||
variable {A : Type}
|
||||
variables [s : discrete_linear_ordered_field A] {a b c : A}
|
||||
include s
|
||||
|
||||
definition dec_eq_of_dec_lt : Π x y : A, decidable (x = y) :=
|
||||
take x y,
|
||||
decidable.by_cases
|
||||
(assume H : x < y, decidable.inr (ne_of_lt H))
|
||||
(assume H : ¬ x < y,
|
||||
decidable.by_cases
|
||||
(assume H' : y < x, decidable.inr (ne.symm (ne_of_lt H')))
|
||||
(assume H' : ¬ y < x,
|
||||
decidable.inl (le.antisymm (le_of_not_gt H') (le_of_not_gt H))))
|
||||
|
||||
definition discrete_linear_ordered_field.to_discrete_field [trans_instance] : discrete_field A :=
|
||||
⦃ discrete_field, s, has_decidable_eq := dec_eq_of_dec_lt⦄
|
||||
|
||||
theorem pos_of_one_div_pos (H : 0 < 1 / a) : 0 < a :=
|
||||
have H1 : 0 < 1 / (1 / a), from one_div_pos_of_pos H,
|
||||
have H2 : 1 / a ≠ 0, from
|
||||
(assume H3 : 1 / a = 0,
|
||||
have H4 : 1 / (1 / a) = 0, from H3⁻¹ ▸ !div_zero,
|
||||
absurd H4 (ne.symm (ne_of_lt H1))),
|
||||
(division_ring.one_div_one_div (ne_zero_of_one_div_ne_zero H2)) ▸ H1
|
||||
|
||||
theorem neg_of_one_div_neg (H : 1 / a < 0) : a < 0 :=
|
||||
have H1 : 0 < - (1 / a), from neg_pos_of_neg H,
|
||||
have Ha : a ≠ 0, from ne_zero_of_one_div_ne_zero (ne_of_lt H),
|
||||
have H2 : 0 < 1 / (-a), from (division_ring.one_div_neg_eq_neg_one_div Ha)⁻¹ ▸ H1,
|
||||
have H3 : 0 < -a, from pos_of_one_div_pos H2,
|
||||
neg_of_neg_pos H3
|
||||
|
||||
theorem le_of_one_div_le_one_div (H : 0 < a) (Hl : 1 / a ≤ 1 / b) : b ≤ a :=
|
||||
have Hb : 0 < b, from pos_of_one_div_pos (calc
|
||||
0 < 1 / a : one_div_pos_of_pos H
|
||||
... ≤ 1 / b : Hl),
|
||||
have H' : 1 ≤ a / b, from (calc
|
||||
1 = a / a : div_self (ne.symm (ne_of_lt H))
|
||||
... = a * (1 / a) : div_eq_mul_one_div
|
||||
... ≤ a * (1 / b) : mul_le_mul_of_nonneg_left Hl (le_of_lt H)
|
||||
... = a / b : div_eq_mul_one_div
|
||||
), le_of_one_le_div Hb H'
|
||||
|
||||
theorem le_of_one_div_le_one_div_of_neg (H : b < 0) (Hl : 1 / a ≤ 1 / b) : b ≤ a :=
|
||||
have Ha : a ≠ 0, from ne_of_lt (neg_of_one_div_neg (calc
|
||||
1 / a ≤ 1 / b : Hl
|
||||
... < 0 : one_div_neg_of_neg H)),
|
||||
have H' : -b > 0, from neg_pos_of_neg H,
|
||||
have Hl' : - (1 / b) ≤ - (1 / a), from neg_le_neg Hl,
|
||||
have Hl'' : 1 / - b ≤ 1 / - a, from calc
|
||||
1 / -b = - (1 / b) : by rewrite [division_ring.one_div_neg_eq_neg_one_div (ne_of_lt H)]
|
||||
... ≤ - (1 / a) : Hl'
|
||||
... = 1 / -a : by rewrite [division_ring.one_div_neg_eq_neg_one_div Ha],
|
||||
le_of_neg_le_neg (le_of_one_div_le_one_div H' Hl'')
|
||||
|
||||
theorem lt_of_one_div_lt_one_div (H : 0 < a) (Hl : 1 / a < 1 / b) : b < a :=
|
||||
have Hb : 0 < b, from pos_of_one_div_pos (calc
|
||||
0 < 1 / a : one_div_pos_of_pos H
|
||||
... < 1 / b : Hl),
|
||||
have H : 1 < a / b, from (calc
|
||||
1 = a / a : div_self (ne.symm (ne_of_lt H))
|
||||
... = a * (1 / a) : div_eq_mul_one_div
|
||||
... < a * (1 / b) : mul_lt_mul_of_pos_left Hl H
|
||||
... = a / b : div_eq_mul_one_div),
|
||||
lt_of_one_lt_div Hb H
|
||||
|
||||
theorem lt_of_one_div_lt_one_div_of_neg (H : b < 0) (Hl : 1 / a < 1 / b) : b < a :=
|
||||
have H1 : b ≤ a, from le_of_one_div_le_one_div_of_neg H (le_of_lt Hl),
|
||||
have Hn : b ≠ a, from
|
||||
(assume Hn' : b = a,
|
||||
have Hl' : 1 / a = 1 / b, from Hn' ▸ refl _,
|
||||
absurd Hl' (ne_of_lt Hl)),
|
||||
lt_of_le_of_ne H1 Hn
|
||||
|
||||
theorem one_div_lt_one_div_of_lt (Ha : 0 < a) (H : a < b) : 1 / b < 1 / a :=
|
||||
lt_of_not_ge
|
||||
(assume H',
|
||||
absurd H (not_lt_of_ge (le_of_one_div_le_one_div Ha H')))
|
||||
|
||||
theorem one_div_le_one_div_of_le (Ha : 0 < a) (H : a ≤ b) : 1 / b ≤ 1 / a :=
|
||||
le_of_not_gt
|
||||
(assume H',
|
||||
absurd H (not_le_of_gt (lt_of_one_div_lt_one_div Ha H')))
|
||||
|
||||
theorem one_div_lt_one_div_of_lt_of_neg (Hb : b < 0) (H : a < b) : 1 / b < 1 / a :=
|
||||
lt_of_not_ge
|
||||
(assume H',
|
||||
absurd H (not_lt_of_ge (le_of_one_div_le_one_div_of_neg Hb H')))
|
||||
|
||||
theorem one_div_le_one_div_of_le_of_neg (Hb : b < 0) (H : a ≤ b) : 1 / b ≤ 1 / a :=
|
||||
le_of_not_gt
|
||||
(assume H',
|
||||
absurd H (not_le_of_gt (lt_of_one_div_lt_one_div_of_neg Hb H')))
|
||||
|
||||
theorem one_lt_one_div (H1 : 0 < a) (H2 : a < 1) : 1 < 1 / a :=
|
||||
one_div_one ▸ one_div_lt_one_div_of_lt H1 H2
|
||||
|
||||
theorem one_le_one_div (H1 : 0 < a) (H2 : a ≤ 1) : 1 ≤ 1 / a :=
|
||||
one_div_one ▸ one_div_le_one_div_of_le H1 H2
|
||||
|
||||
theorem one_div_lt_neg_one (H1 : a < 0) (H2 : -1 < a) : 1 / a < -1 :=
|
||||
one_div_neg_one_eq_neg_one ▸ one_div_lt_one_div_of_lt_of_neg H1 H2
|
||||
|
||||
theorem one_div_le_neg_one (H1 : a < 0) (H2 : -1 ≤ a) : 1 / a ≤ -1 :=
|
||||
one_div_neg_one_eq_neg_one ▸ one_div_le_one_div_of_le_of_neg H1 H2
|
||||
|
||||
theorem div_lt_div_of_pos_of_lt_of_pos (Hb : 0 < b) (H : b < a) (Hc : 0 < c) : c / a < c / b :=
|
||||
begin
|
||||
apply iff.mp !sub_neg_iff_lt,
|
||||
rewrite [div_eq_mul_one_div, {c / b}div_eq_mul_one_div, -mul_sub_left_distrib],
|
||||
apply mul_neg_of_pos_of_neg,
|
||||
exact Hc,
|
||||
apply iff.mpr !sub_neg_iff_lt,
|
||||
apply one_div_lt_one_div_of_lt,
|
||||
repeat assumption
|
||||
end
|
||||
|
||||
theorem div_mul_le_div_mul_of_div_le_div_pos' {d e : A} (H : a / b ≤ c / d)
|
||||
(He : e > 0) : a / (b * e) ≤ c / (d * e) :=
|
||||
begin
|
||||
rewrite [2 div_mul_eq_div_mul_one_div],
|
||||
apply mul_le_mul_of_nonneg_right H,
|
||||
apply le_of_lt,
|
||||
apply one_div_pos_of_pos He
|
||||
end
|
||||
|
||||
theorem abs_one_div (a : A) : abs (1 / a) = 1 / abs a :=
|
||||
if H : a > 0 then
|
||||
by rewrite [abs_of_pos H, abs_of_pos (one_div_pos_of_pos H)]
|
||||
else
|
||||
(if H' : a < 0 then
|
||||
by rewrite [abs_of_neg H', abs_of_neg (one_div_neg_of_neg H'),
|
||||
-(division_ring.one_div_neg_eq_neg_one_div (ne_of_lt H'))]
|
||||
else
|
||||
have Heq : a = 0, from eq_of_le_of_ge (le_of_not_gt H) (le_of_not_gt H'),
|
||||
by rewrite [Heq, div_zero, *abs_zero, div_zero])
|
||||
|
||||
theorem sign_eq_div_abs (a : A) : sign a = a / (abs a) :=
|
||||
decidable.by_cases
|
||||
(suppose a = 0, by subst a; rewrite [zero_div, sign_zero])
|
||||
(suppose a ≠ 0,
|
||||
have abs a ≠ 0, from assume H, this (eq_zero_of_abs_eq_zero H),
|
||||
!eq_div_of_mul_eq this !eq_sign_mul_abs⁻¹)
|
||||
|
||||
end discrete_linear_ordered_field
|
||||
end algebra
|
||||
|
|
@ -1,869 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad
|
||||
|
||||
Partially ordered additive groups, modeled on Isabelle's library. These classes can be refined
|
||||
if necessary.
|
||||
-/
|
||||
import algebra.binary algebra.group algebra.order
|
||||
open eq eq.ops algebra -- note: ⁻¹ will be overloaded
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
|
||||
/- partially ordered monoids, such as the natural numbers -/
|
||||
|
||||
namespace algebra
|
||||
structure ordered_mul_cancel_comm_monoid [class] (A : Type) extends comm_monoid A,
|
||||
left_cancel_semigroup A, right_cancel_semigroup A, order_pair A :=
|
||||
(mul_le_mul_left : Πa b, le a b → Πc, le (mul c a) (mul c b))
|
||||
(le_of_mul_le_mul_left : Πa b c, le (mul a b) (mul a c) → le b c)
|
||||
(mul_lt_mul_left : Πa b, lt a b → Πc, lt (mul c a) (mul c b))
|
||||
(lt_of_mul_lt_mul_left : Πa b c, lt (mul a b) (mul a c) → lt b c)
|
||||
|
||||
definition ordered_cancel_comm_monoid [class] : Type → Type := ordered_mul_cancel_comm_monoid
|
||||
|
||||
definition add_comm_monoid_of_ordered_cancel_comm_monoid [reducible] [trans_instance]
|
||||
(A : Type) [H : ordered_cancel_comm_monoid A] : add_comm_monoid A :=
|
||||
@ordered_mul_cancel_comm_monoid.to_comm_monoid A H
|
||||
|
||||
definition add_left_cancel_semigroup_of_ordered_cancel_comm_monoid [reducible] [trans_instance]
|
||||
(A : Type) [H : ordered_cancel_comm_monoid A] : add_left_cancel_semigroup A :=
|
||||
@ordered_mul_cancel_comm_monoid.to_left_cancel_semigroup A H
|
||||
|
||||
definition add_right_cancel_semigroup_of_ordered_cancel_comm_monoid [reducible] [trans_instance]
|
||||
(A : Type) [H : ordered_cancel_comm_monoid A] : add_right_cancel_semigroup A :=
|
||||
@ordered_mul_cancel_comm_monoid.to_right_cancel_semigroup A H
|
||||
|
||||
definition order_pair_of_ordered_cancel_comm_monoid [reducible] [trans_instance]
|
||||
(A : Type) [H : ordered_cancel_comm_monoid A] : order_pair A :=
|
||||
@ordered_mul_cancel_comm_monoid.to_order_pair A H
|
||||
|
||||
section
|
||||
variables [s : ordered_cancel_comm_monoid A]
|
||||
variables {a b c d e : A}
|
||||
include s
|
||||
|
||||
theorem add_lt_add_left (H : a < b) (c : A) : c + a < c + b :=
|
||||
@ordered_mul_cancel_comm_monoid.mul_lt_mul_left A s a b H c
|
||||
|
||||
theorem add_lt_add_right (H : a < b) (c : A) : a + c < b + c :=
|
||||
begin
|
||||
rewrite [add.comm, {b + _}add.comm],
|
||||
exact (add_lt_add_left H c)
|
||||
end
|
||||
|
||||
theorem add_le_add_left (H : a ≤ b) (c : A) : c + a ≤ c + b :=
|
||||
@ordered_mul_cancel_comm_monoid.mul_le_mul_left A s a b H c
|
||||
|
||||
theorem add_le_add_right (H : a ≤ b) (c : A) : a + c ≤ b + c :=
|
||||
(add.comm c a) ▸ (add.comm c b) ▸ (add_le_add_left H c)
|
||||
|
||||
theorem add_le_add (Hab : a ≤ b) (Hcd : c ≤ d) : a + c ≤ b + d :=
|
||||
le.trans (add_le_add_right Hab c) (add_le_add_left Hcd b)
|
||||
|
||||
theorem le_add_of_nonneg_right (H : b ≥ 0) : a ≤ a + b :=
|
||||
begin
|
||||
have H1 : a + b ≥ a + 0, from add_le_add_left H a,
|
||||
rewrite add_zero at H1,
|
||||
exact H1
|
||||
end
|
||||
|
||||
theorem le_add_of_nonneg_left (H : b ≥ 0) : a ≤ b + a :=
|
||||
begin
|
||||
have H1 : 0 + a ≤ b + a, from add_le_add_right H a,
|
||||
rewrite zero_add at H1,
|
||||
exact H1
|
||||
end
|
||||
|
||||
theorem add_lt_add (Hab : a < b) (Hcd : c < d) : a + c < b + d :=
|
||||
lt.trans (add_lt_add_right Hab c) (add_lt_add_left Hcd b)
|
||||
|
||||
theorem add_lt_add_of_le_of_lt (Hab : a ≤ b) (Hcd : c < d) : a + c < b + d :=
|
||||
lt_of_le_of_lt (add_le_add_right Hab c) (add_lt_add_left Hcd b)
|
||||
|
||||
theorem add_lt_add_of_lt_of_le (Hab : a < b) (Hcd : c ≤ d) : a + c < b + d :=
|
||||
lt_of_lt_of_le (add_lt_add_right Hab c) (add_le_add_left Hcd b)
|
||||
|
||||
theorem lt_add_of_pos_right (H : b > 0) : a < a + b := !add_zero ▸ add_lt_add_left H a
|
||||
|
||||
theorem lt_add_of_pos_left (H : b > 0) : a < b + a := !zero_add ▸ add_lt_add_right H a
|
||||
|
||||
-- here we start using le_of_add_le_add_left.
|
||||
theorem le_of_add_le_add_left (H : a + b ≤ a + c) : b ≤ c :=
|
||||
@ordered_mul_cancel_comm_monoid.le_of_mul_le_mul_left A s a b c H
|
||||
|
||||
theorem le_of_add_le_add_right (H : a + b ≤ c + b) : a ≤ c :=
|
||||
le_of_add_le_add_left (show b + a ≤ b + c, begin rewrite [add.comm, {b + _}add.comm], exact H end)
|
||||
|
||||
theorem lt_of_add_lt_add_left (H : a + b < a + c) : b < c :=
|
||||
@ordered_mul_cancel_comm_monoid.lt_of_mul_lt_mul_left A s a b c H
|
||||
|
||||
theorem lt_of_add_lt_add_right (H : a + b < c + b) : a < c :=
|
||||
lt_of_add_lt_add_left ((add.comm a b) ▸ (add.comm c b) ▸ H)
|
||||
|
||||
theorem add_le_add_left_iff (a b c : A) : a + b ≤ a + c ↔ b ≤ c :=
|
||||
iff.intro le_of_add_le_add_left (assume H, add_le_add_left H _)
|
||||
|
||||
theorem add_le_add_right_iff (a b c : A) : a + b ≤ c + b ↔ a ≤ c :=
|
||||
iff.intro le_of_add_le_add_right (assume H, add_le_add_right H _)
|
||||
|
||||
theorem add_lt_add_left_iff (a b c : A) : a + b < a + c ↔ b < c :=
|
||||
iff.intro lt_of_add_lt_add_left (assume H, add_lt_add_left H _)
|
||||
|
||||
theorem add_lt_add_right_iff (a b c : A) : a + b < c + b ↔ a < c :=
|
||||
iff.intro lt_of_add_lt_add_right (assume H, add_lt_add_right H _)
|
||||
|
||||
-- here we start using properties of zero.
|
||||
theorem add_nonneg (Ha : 0 ≤ a) (Hb : 0 ≤ b) : 0 ≤ a + b :=
|
||||
!zero_add ▸ (add_le_add Ha Hb)
|
||||
|
||||
theorem add_pos (Ha : 0 < a) (Hb : 0 < b) : 0 < a + b :=
|
||||
!zero_add ▸ (add_lt_add Ha Hb)
|
||||
|
||||
theorem add_pos_of_pos_of_nonneg (Ha : 0 < a) (Hb : 0 ≤ b) : 0 < a + b :=
|
||||
!zero_add ▸ (add_lt_add_of_lt_of_le Ha Hb)
|
||||
|
||||
theorem add_pos_of_nonneg_of_pos (Ha : 0 ≤ a) (Hb : 0 < b) : 0 < a + b :=
|
||||
!zero_add ▸ (add_lt_add_of_le_of_lt Ha Hb)
|
||||
|
||||
theorem add_nonpos (Ha : a ≤ 0) (Hb : b ≤ 0) : a + b ≤ 0 :=
|
||||
!zero_add ▸ (add_le_add Ha Hb)
|
||||
|
||||
theorem add_neg (Ha : a < 0) (Hb : b < 0) : a + b < 0 :=
|
||||
!zero_add ▸ (add_lt_add Ha Hb)
|
||||
|
||||
theorem add_neg_of_neg_of_nonpos (Ha : a < 0) (Hb : b ≤ 0) : a + b < 0 :=
|
||||
!zero_add ▸ (add_lt_add_of_lt_of_le Ha Hb)
|
||||
|
||||
theorem add_neg_of_nonpos_of_neg (Ha : a ≤ 0) (Hb : b < 0) : a + b < 0 :=
|
||||
!zero_add ▸ (add_lt_add_of_le_of_lt Ha Hb)
|
||||
|
||||
-- TODO: add nonpos version (will be easier with simplifier)
|
||||
theorem add_eq_zero_iff_eq_zero_prod_eq_zero_of_nonneg_of_nonneg
|
||||
(Ha : 0 ≤ a) (Hb : 0 ≤ b) : a + b = 0 ↔ a = 0 × b = 0 :=
|
||||
iff.intro
|
||||
(assume Hab : a + b = 0,
|
||||
have Ha' : a ≤ 0, from
|
||||
calc
|
||||
a = a + 0 : by rewrite add_zero
|
||||
... ≤ a + b : add_le_add_left Hb
|
||||
... = 0 : Hab,
|
||||
have Haz : a = 0, from le.antisymm Ha' Ha,
|
||||
have Hb' : b ≤ 0, from
|
||||
calc
|
||||
b = 0 + b : by rewrite zero_add
|
||||
... ≤ a + b : by exact add_le_add_right Ha _
|
||||
... = 0 : Hab,
|
||||
have Hbz : b = 0, from le.antisymm Hb' Hb,
|
||||
pair Haz Hbz)
|
||||
(assume Hab : a = 0 × b = 0,
|
||||
obtain Ha' Hb', from Hab,
|
||||
by rewrite [Ha', Hb', add_zero])
|
||||
|
||||
theorem le_add_of_nonneg_of_le (Ha : 0 ≤ a) (Hbc : b ≤ c) : b ≤ a + c :=
|
||||
!zero_add ▸ add_le_add Ha Hbc
|
||||
|
||||
theorem le_add_of_le_of_nonneg (Hbc : b ≤ c) (Ha : 0 ≤ a) : b ≤ c + a :=
|
||||
!add_zero ▸ add_le_add Hbc Ha
|
||||
|
||||
theorem lt_add_of_pos_of_le (Ha : 0 < a) (Hbc : b ≤ c) : b < a + c :=
|
||||
!zero_add ▸ add_lt_add_of_lt_of_le Ha Hbc
|
||||
|
||||
theorem lt_add_of_le_of_pos (Hbc : b ≤ c) (Ha : 0 < a) : b < c + a :=
|
||||
!add_zero ▸ add_lt_add_of_le_of_lt Hbc Ha
|
||||
|
||||
theorem add_le_of_nonpos_of_le (Ha : a ≤ 0) (Hbc : b ≤ c) : a + b ≤ c :=
|
||||
!zero_add ▸ add_le_add Ha Hbc
|
||||
|
||||
theorem add_le_of_le_of_nonpos (Hbc : b ≤ c) (Ha : a ≤ 0) : b + a ≤ c :=
|
||||
!add_zero ▸ add_le_add Hbc Ha
|
||||
|
||||
theorem add_lt_of_neg_of_le (Ha : a < 0) (Hbc : b ≤ c) : a + b < c :=
|
||||
!zero_add ▸ add_lt_add_of_lt_of_le Ha Hbc
|
||||
|
||||
theorem add_lt_of_le_of_neg (Hbc : b ≤ c) (Ha : a < 0) : b + a < c :=
|
||||
!add_zero ▸ add_lt_add_of_le_of_lt Hbc Ha
|
||||
|
||||
theorem lt_add_of_nonneg_of_lt (Ha : 0 ≤ a) (Hbc : b < c) : b < a + c :=
|
||||
!zero_add ▸ add_lt_add_of_le_of_lt Ha Hbc
|
||||
|
||||
theorem lt_add_of_lt_of_nonneg (Hbc : b < c) (Ha : 0 ≤ a) : b < c + a :=
|
||||
!add_zero ▸ add_lt_add_of_lt_of_le Hbc Ha
|
||||
|
||||
theorem lt_add_of_pos_of_lt (Ha : 0 < a) (Hbc : b < c) : b < a + c :=
|
||||
!zero_add ▸ add_lt_add Ha Hbc
|
||||
|
||||
theorem lt_add_of_lt_of_pos (Hbc : b < c) (Ha : 0 < a) : b < c + a :=
|
||||
!add_zero ▸ add_lt_add Hbc Ha
|
||||
|
||||
theorem add_lt_of_nonpos_of_lt (Ha : a ≤ 0) (Hbc : b < c) : a + b < c :=
|
||||
!zero_add ▸ add_lt_add_of_le_of_lt Ha Hbc
|
||||
|
||||
theorem add_lt_of_lt_of_nonpos (Hbc : b < c) (Ha : a ≤ 0) : b + a < c :=
|
||||
!add_zero ▸ add_lt_add_of_lt_of_le Hbc Ha
|
||||
|
||||
theorem add_lt_of_neg_of_lt (Ha : a < 0) (Hbc : b < c) : a + b < c :=
|
||||
!zero_add ▸ add_lt_add Ha Hbc
|
||||
|
||||
theorem add_lt_of_lt_of_neg (Hbc : b < c) (Ha : a < 0) : b + a < c :=
|
||||
!add_zero ▸ add_lt_add Hbc Ha
|
||||
end
|
||||
|
||||
/- partially ordered groups -/
|
||||
|
||||
structure ordered_mul_ab_group [class] (A : Type) extends ab_group A, order_pair A :=
|
||||
(mul_le_mul_left : Πa b, le a b → Πc, le (mul c a) (mul c b))
|
||||
(mul_lt_mul_left : Πa b, lt a b → Π c, lt (mul c a) (mul c b))
|
||||
|
||||
definition ordered_ab_group [class] : Type → Type := ordered_mul_ab_group
|
||||
|
||||
definition add_ab_group_of_ordered_ab_group [reducible] [trans_instance] (A : Type)
|
||||
[H : ordered_ab_group A] : add_ab_group A :=
|
||||
@ordered_mul_ab_group.to_ab_group A H
|
||||
|
||||
theorem ordered_mul_ab_group.le_of_mul_le_mul_left [s : ordered_mul_ab_group A] {a b c : A}
|
||||
(H : a * b ≤ a * c) : b ≤ c :=
|
||||
have H' : a⁻¹ * (a * b) ≤ a⁻¹ * (a * c), from ordered_mul_ab_group.mul_le_mul_left _ _ H _,
|
||||
by rewrite *inv_mul_cancel_left at H'; exact H'
|
||||
|
||||
theorem ordered_mul_ab_group.lt_of_mul_lt_mul_left [s : ordered_mul_ab_group A] {a b c : A}
|
||||
(H : a * b < a * c) : b < c :=
|
||||
have H' : a⁻¹ * (a * b) < a⁻¹ * (a * c), from ordered_mul_ab_group.mul_lt_mul_left _ _ H _,
|
||||
by rewrite *inv_mul_cancel_left at H'; exact H'
|
||||
|
||||
definition ordered_mul_ab_group.to_ordered_mul_cancel_comm_monoid [reducible] [trans_instance]
|
||||
[s : ordered_mul_ab_group A] : ordered_mul_cancel_comm_monoid A :=
|
||||
⦃ ordered_mul_cancel_comm_monoid, s,
|
||||
mul_left_cancel := @mul.left_cancel A _,
|
||||
mul_right_cancel := @mul.right_cancel A _,
|
||||
le_of_mul_le_mul_left := @ordered_mul_ab_group.le_of_mul_le_mul_left A _,
|
||||
lt_of_mul_lt_mul_left := @ordered_mul_ab_group.lt_of_mul_lt_mul_left A _⦄
|
||||
|
||||
definition ordered_ab_group.to_ordered_cancel_comm_monoid [reducible] [trans_instance]
|
||||
[s : ordered_ab_group A] : ordered_cancel_comm_monoid A :=
|
||||
@ordered_mul_ab_group.to_ordered_mul_cancel_comm_monoid A s
|
||||
|
||||
section
|
||||
variables [s : ordered_ab_group A] (a b c d e : A)
|
||||
include s
|
||||
|
||||
theorem neg_le_neg {a b : A} (H : a ≤ b) : -b ≤ -a :=
|
||||
have H1 : 0 ≤ -a + b, from !add.left_inv ▸ !(add_le_add_left H),
|
||||
!add_neg_cancel_right ▸ !zero_add ▸ add_le_add_right H1 (-b)
|
||||
|
||||
theorem le_of_neg_le_neg {a b : A} (H : -b ≤ -a) : a ≤ b :=
|
||||
neg_neg a ▸ neg_neg b ▸ neg_le_neg H
|
||||
|
||||
theorem neg_le_neg_iff_le : -a ≤ -b ↔ b ≤ a :=
|
||||
iff.intro le_of_neg_le_neg neg_le_neg
|
||||
|
||||
theorem nonneg_of_neg_nonpos {a : A} (H : -a ≤ 0) : 0 ≤ a :=
|
||||
le_of_neg_le_neg (neg_zero⁻¹ ▸ H)
|
||||
|
||||
theorem neg_nonpos_of_nonneg {a : A} (H : 0 ≤ a) : -a ≤ 0 :=
|
||||
neg_zero ▸ neg_le_neg H
|
||||
|
||||
theorem neg_nonpos_iff_nonneg : -a ≤ 0 ↔ 0 ≤ a :=
|
||||
iff.intro nonneg_of_neg_nonpos neg_nonpos_of_nonneg
|
||||
|
||||
theorem nonpos_of_neg_nonneg {a : A} (H : 0 ≤ -a) : a ≤ 0 :=
|
||||
le_of_neg_le_neg (neg_zero⁻¹ ▸ H)
|
||||
|
||||
theorem neg_nonneg_of_nonpos {a : A} (H : a ≤ 0) : 0 ≤ -a :=
|
||||
neg_zero ▸ neg_le_neg H
|
||||
|
||||
theorem neg_nonneg_iff_nonpos : 0 ≤ -a ↔ a ≤ 0 :=
|
||||
iff.intro nonpos_of_neg_nonneg neg_nonneg_of_nonpos
|
||||
|
||||
theorem neg_lt_neg {a b : A} (H : a < b) : -b < -a :=
|
||||
have H1 : 0 < -a + b, from !add.left_inv ▸ !(add_lt_add_left H),
|
||||
!add_neg_cancel_right ▸ !zero_add ▸ add_lt_add_right H1 (-b)
|
||||
|
||||
theorem lt_of_neg_lt_neg {a b : A} (H : -b < -a) : a < b :=
|
||||
neg_neg a ▸ neg_neg b ▸ neg_lt_neg H
|
||||
|
||||
theorem neg_lt_neg_iff_lt : -a < -b ↔ b < a :=
|
||||
iff.intro lt_of_neg_lt_neg neg_lt_neg
|
||||
|
||||
theorem pos_of_neg_neg {a : A} (H : -a < 0) : 0 < a :=
|
||||
lt_of_neg_lt_neg (neg_zero⁻¹ ▸ H)
|
||||
|
||||
theorem neg_neg_of_pos {a : A} (H : 0 < a) : -a < 0 :=
|
||||
neg_zero ▸ neg_lt_neg H
|
||||
|
||||
theorem neg_neg_iff_pos : -a < 0 ↔ 0 < a :=
|
||||
iff.intro pos_of_neg_neg neg_neg_of_pos
|
||||
|
||||
theorem neg_of_neg_pos {a : A} (H : 0 < -a) : a < 0 :=
|
||||
lt_of_neg_lt_neg (neg_zero⁻¹ ▸ H)
|
||||
|
||||
theorem neg_pos_of_neg {a : A} (H : a < 0) : 0 < -a :=
|
||||
neg_zero ▸ neg_lt_neg H
|
||||
|
||||
theorem neg_pos_iff_neg : 0 < -a ↔ a < 0 :=
|
||||
iff.intro neg_of_neg_pos neg_pos_of_neg
|
||||
|
||||
theorem le_neg_iff_le_neg : a ≤ -b ↔ b ≤ -a := !neg_neg ▸ !neg_le_neg_iff_le
|
||||
|
||||
theorem le_neg_of_le_neg {a b : A} : a ≤ -b → b ≤ -a := iff.mp !le_neg_iff_le_neg
|
||||
|
||||
theorem neg_le_iff_neg_le : -a ≤ b ↔ -b ≤ a := !neg_neg ▸ !neg_le_neg_iff_le
|
||||
|
||||
theorem neg_le_of_neg_le {a b : A} : -a ≤ b → -b ≤ a := iff.mp !neg_le_iff_neg_le
|
||||
|
||||
theorem lt_neg_iff_lt_neg : a < -b ↔ b < -a := !neg_neg ▸ !neg_lt_neg_iff_lt
|
||||
|
||||
theorem lt_neg_of_lt_neg {a b : A} : a < -b → b < -a := iff.mp !lt_neg_iff_lt_neg
|
||||
|
||||
theorem neg_lt_iff_neg_lt : -a < b ↔ -b < a := !neg_neg ▸ !neg_lt_neg_iff_lt
|
||||
|
||||
theorem neg_lt_of_neg_lt {a b : A} : -a < b → -b < a := iff.mp !neg_lt_iff_neg_lt
|
||||
|
||||
theorem sub_nonneg_iff_le : 0 ≤ a - b ↔ b ≤ a := !sub_self ▸ !add_le_add_right_iff
|
||||
|
||||
theorem sub_nonneg_of_le {a b : A} : b ≤ a → 0 ≤ a - b := iff.mpr !sub_nonneg_iff_le
|
||||
|
||||
theorem le_of_sub_nonneg {a b : A} : 0 ≤ a - b → b ≤ a := iff.mp !sub_nonneg_iff_le
|
||||
|
||||
theorem sub_nonpos_iff_le : a - b ≤ 0 ↔ a ≤ b := !sub_self ▸ !add_le_add_right_iff
|
||||
|
||||
theorem sub_nonpos_of_le {a b : A} : a ≤ b → a - b ≤ 0 := iff.mpr !sub_nonpos_iff_le
|
||||
|
||||
theorem le_of_sub_nonpos {a b : A} : a - b ≤ 0 → a ≤ b := iff.mp !sub_nonpos_iff_le
|
||||
|
||||
theorem sub_pos_iff_lt : 0 < a - b ↔ b < a := !sub_self ▸ !add_lt_add_right_iff
|
||||
|
||||
theorem sub_pos_of_lt {a b : A} : b < a → 0 < a - b := iff.mpr !sub_pos_iff_lt
|
||||
|
||||
theorem lt_of_sub_pos {a b : A} : 0 < a - b → b < a := iff.mp !sub_pos_iff_lt
|
||||
|
||||
theorem sub_neg_iff_lt : a - b < 0 ↔ a < b := !sub_self ▸ !add_lt_add_right_iff
|
||||
|
||||
theorem sub_neg_of_lt {a b : A} : a < b → a - b < 0 := iff.mpr !sub_neg_iff_lt
|
||||
|
||||
theorem lt_of_sub_neg {a b : A} : a - b < 0 → a < b := iff.mp !sub_neg_iff_lt
|
||||
|
||||
theorem add_le_iff_le_neg_add : a + b ≤ c ↔ b ≤ -a + c :=
|
||||
have H: a + b ≤ c ↔ -a + (a + b) ≤ -a + c, from iff.symm (!add_le_add_left_iff),
|
||||
!neg_add_cancel_left ▸ H
|
||||
|
||||
theorem add_le_of_le_neg_add {a b c : A} : b ≤ -a + c → a + b ≤ c :=
|
||||
iff.mpr !add_le_iff_le_neg_add
|
||||
|
||||
theorem le_neg_add_of_add_le {a b c : A} : a + b ≤ c → b ≤ -a + c :=
|
||||
iff.mp !add_le_iff_le_neg_add
|
||||
|
||||
theorem add_le_iff_le_sub_left : a + b ≤ c ↔ b ≤ c - a :=
|
||||
by rewrite [sub_eq_add_neg, {c+_}add.comm]; apply add_le_iff_le_neg_add
|
||||
|
||||
theorem add_le_of_le_sub_left {a b c : A} : b ≤ c - a → a + b ≤ c :=
|
||||
iff.mpr !add_le_iff_le_sub_left
|
||||
|
||||
theorem le_sub_left_of_add_le {a b c : A} : a + b ≤ c → b ≤ c - a :=
|
||||
iff.mp !add_le_iff_le_sub_left
|
||||
|
||||
theorem add_le_iff_le_sub_right : a + b ≤ c ↔ a ≤ c - b :=
|
||||
have H: a + b ≤ c ↔ a + b - b ≤ c - b, from iff.symm (!add_le_add_right_iff),
|
||||
!add_neg_cancel_right ▸ H
|
||||
|
||||
theorem add_le_of_le_sub_right {a b c : A} : a ≤ c - b → a + b ≤ c :=
|
||||
iff.mpr !add_le_iff_le_sub_right
|
||||
|
||||
theorem le_sub_right_of_add_le {a b c : A} : a + b ≤ c → a ≤ c - b :=
|
||||
iff.mp !add_le_iff_le_sub_right
|
||||
|
||||
theorem le_add_iff_neg_add_le : a ≤ b + c ↔ -b + a ≤ c :=
|
||||
have H: a ≤ b + c ↔ -b + a ≤ -b + (b + c), from iff.symm (!add_le_add_left_iff),
|
||||
by rewrite neg_add_cancel_left at H; exact H
|
||||
|
||||
theorem le_add_of_neg_add_le {a b c : A} : -b + a ≤ c → a ≤ b + c :=
|
||||
iff.mpr !le_add_iff_neg_add_le
|
||||
|
||||
theorem neg_add_le_of_le_add {a b c : A} : a ≤ b + c → -b + a ≤ c :=
|
||||
iff.mp !le_add_iff_neg_add_le
|
||||
|
||||
theorem le_add_iff_sub_left_le : a ≤ b + c ↔ a - b ≤ c :=
|
||||
by rewrite [sub_eq_add_neg, {a+_}add.comm]; apply le_add_iff_neg_add_le
|
||||
|
||||
theorem le_add_of_sub_left_le {a b c : A} : a - b ≤ c → a ≤ b + c :=
|
||||
iff.mpr !le_add_iff_sub_left_le
|
||||
|
||||
theorem sub_left_le_of_le_add {a b c : A} : a ≤ b + c → a - b ≤ c :=
|
||||
iff.mp !le_add_iff_sub_left_le
|
||||
|
||||
theorem le_add_iff_sub_right_le : a ≤ b + c ↔ a - c ≤ b :=
|
||||
have H: a ≤ b + c ↔ a - c ≤ b + c - c, from iff.symm (!add_le_add_right_iff),
|
||||
by rewrite [sub_eq_add_neg (b+c) c at H, add_neg_cancel_right at H]; exact H
|
||||
|
||||
theorem le_add_of_sub_right_le {a b c : A} : a - c ≤ b → a ≤ b + c :=
|
||||
iff.mpr !le_add_iff_sub_right_le
|
||||
|
||||
theorem sub_right_le_of_le_add {a b c : A} : a ≤ b + c → a - c ≤ b :=
|
||||
iff.mp !le_add_iff_sub_right_le
|
||||
|
||||
theorem le_add_iff_neg_add_le_left : a ≤ b + c ↔ -b + a ≤ c :=
|
||||
have H: a ≤ b + c ↔ -b + a ≤ -b + (b + c), from iff.symm (!add_le_add_left_iff),
|
||||
by rewrite neg_add_cancel_left at H; exact H
|
||||
|
||||
theorem le_add_of_neg_add_le_left {a b c : A} : -b + a ≤ c → a ≤ b + c :=
|
||||
iff.mpr !le_add_iff_neg_add_le_left
|
||||
|
||||
theorem neg_add_le_left_of_le_add {a b c : A} : a ≤ b + c → -b + a ≤ c :=
|
||||
iff.mp !le_add_iff_neg_add_le_left
|
||||
|
||||
theorem le_add_iff_neg_add_le_right : a ≤ b + c ↔ -c + a ≤ b :=
|
||||
by rewrite add.comm; apply le_add_iff_neg_add_le_left
|
||||
|
||||
theorem le_add_of_neg_add_le_right {a b c : A} : -c + a ≤ b → a ≤ b + c :=
|
||||
iff.mpr !le_add_iff_neg_add_le_right
|
||||
|
||||
theorem neg_add_le_right_of_le_add {a b c : A} : a ≤ b + c → -c + a ≤ b :=
|
||||
iff.mp !le_add_iff_neg_add_le_right
|
||||
|
||||
theorem le_add_iff_neg_le_sub_left : c ≤ a + b ↔ -a ≤ b - c :=
|
||||
have H : c ≤ a + b ↔ -a + c ≤ b, from !le_add_iff_neg_add_le,
|
||||
have H' : -a + c ≤ b ↔ -a ≤ b - c, from !add_le_iff_le_sub_right,
|
||||
iff.trans H H'
|
||||
|
||||
theorem le_add_of_neg_le_sub_left {a b c : A} : -a ≤ b - c → c ≤ a + b :=
|
||||
iff.mpr !le_add_iff_neg_le_sub_left
|
||||
|
||||
theorem neg_le_sub_left_of_le_add {a b c : A} : c ≤ a + b → -a ≤ b - c :=
|
||||
iff.mp !le_add_iff_neg_le_sub_left
|
||||
|
||||
theorem le_add_iff_neg_le_sub_right : c ≤ a + b ↔ -b ≤ a - c :=
|
||||
by rewrite add.comm; apply le_add_iff_neg_le_sub_left
|
||||
|
||||
theorem le_add_of_neg_le_sub_right {a b c : A} : -b ≤ a - c → c ≤ a + b :=
|
||||
iff.mpr !le_add_iff_neg_le_sub_right
|
||||
|
||||
theorem neg_le_sub_right_of_le_add {a b c : A} : c ≤ a + b → -b ≤ a - c :=
|
||||
iff.mp !le_add_iff_neg_le_sub_right
|
||||
|
||||
theorem add_lt_iff_lt_neg_add_left : a + b < c ↔ b < -a + c :=
|
||||
have H: a + b < c ↔ -a + (a + b) < -a + c, from iff.symm (!add_lt_add_left_iff),
|
||||
begin rewrite neg_add_cancel_left at H, exact H end
|
||||
|
||||
theorem add_lt_of_lt_neg_add_left {a b c : A} : b < -a + c → a + b < c :=
|
||||
iff.mpr !add_lt_iff_lt_neg_add_left
|
||||
|
||||
theorem lt_neg_add_left_of_add_lt {a b c : A} : a + b < c → b < -a + c :=
|
||||
iff.mp !add_lt_iff_lt_neg_add_left
|
||||
|
||||
theorem add_lt_iff_lt_neg_add_right : a + b < c ↔ a < -b + c :=
|
||||
by rewrite add.comm; apply add_lt_iff_lt_neg_add_left
|
||||
|
||||
theorem add_lt_of_lt_neg_add_right {a b c : A} : a < -b + c → a + b < c :=
|
||||
iff.mpr !add_lt_iff_lt_neg_add_right
|
||||
|
||||
theorem lt_neg_add_right_of_add_lt {a b c : A} : a + b < c → a < -b + c :=
|
||||
iff.mp !add_lt_iff_lt_neg_add_right
|
||||
|
||||
theorem add_lt_iff_lt_sub_left : a + b < c ↔ b < c - a :=
|
||||
begin
|
||||
rewrite [sub_eq_add_neg, {c+_}add.comm],
|
||||
apply add_lt_iff_lt_neg_add_left
|
||||
end
|
||||
|
||||
theorem add_lt_of_lt_sub_left {a b c : A} : b < c - a → a + b < c :=
|
||||
iff.mpr !add_lt_iff_lt_sub_left
|
||||
|
||||
theorem lt_sub_left_of_add_lt {a b c : A} : a + b < c → b < c - a :=
|
||||
iff.mp !add_lt_iff_lt_sub_left
|
||||
|
||||
theorem add_lt_iff_lt_sub_right : a + b < c ↔ a < c - b :=
|
||||
have H: a + b < c ↔ a + b - b < c - b, from iff.symm (!add_lt_add_right_iff),
|
||||
by rewrite [sub_eq_add_neg at H, add_neg_cancel_right at H]; exact H
|
||||
|
||||
theorem add_lt_of_lt_sub_right {a b c : A} : a < c - b → a + b < c :=
|
||||
iff.mpr !add_lt_iff_lt_sub_right
|
||||
|
||||
theorem lt_sub_right_of_add_lt {a b c : A} : a + b < c → a < c - b :=
|
||||
iff.mp !add_lt_iff_lt_sub_right
|
||||
|
||||
theorem lt_add_iff_neg_add_lt_left : a < b + c ↔ -b + a < c :=
|
||||
have H: a < b + c ↔ -b + a < -b + (b + c), from iff.symm (!add_lt_add_left_iff),
|
||||
by rewrite neg_add_cancel_left at H; exact H
|
||||
|
||||
theorem lt_add_of_neg_add_lt_left {a b c : A} : -b + a < c → a < b + c :=
|
||||
iff.mpr !lt_add_iff_neg_add_lt_left
|
||||
|
||||
theorem neg_add_lt_left_of_lt_add {a b c : A} : a < b + c → -b + a < c :=
|
||||
iff.mp !lt_add_iff_neg_add_lt_left
|
||||
|
||||
theorem lt_add_iff_neg_add_lt_right : a < b + c ↔ -c + a < b :=
|
||||
by rewrite add.comm; apply lt_add_iff_neg_add_lt_left
|
||||
|
||||
theorem lt_add_of_neg_add_lt_right {a b c : A} : -c + a < b → a < b + c :=
|
||||
iff.mpr !lt_add_iff_neg_add_lt_right
|
||||
|
||||
theorem neg_add_lt_right_of_lt_add {a b c : A} : a < b + c → -c + a < b :=
|
||||
iff.mp !lt_add_iff_neg_add_lt_right
|
||||
|
||||
theorem lt_add_iff_sub_lt_left : a < b + c ↔ a - b < c :=
|
||||
by rewrite [sub_eq_add_neg, {a + _}add.comm]; apply lt_add_iff_neg_add_lt_left
|
||||
|
||||
theorem lt_add_of_sub_lt_left {a b c : A} : a - b < c → a < b + c :=
|
||||
iff.mpr !lt_add_iff_sub_lt_left
|
||||
|
||||
theorem sub_lt_left_of_lt_add {a b c : A} : a < b + c → a - b < c :=
|
||||
iff.mp !lt_add_iff_sub_lt_left
|
||||
|
||||
theorem lt_add_iff_sub_lt_right : a < b + c ↔ a - c < b :=
|
||||
by rewrite add.comm; apply lt_add_iff_sub_lt_left
|
||||
|
||||
theorem lt_add_of_sub_lt_right {a b c : A} : a - c < b → a < b + c :=
|
||||
iff.mpr !lt_add_iff_sub_lt_right
|
||||
|
||||
theorem sub_lt_right_of_lt_add {a b c : A} : a < b + c → a - c < b :=
|
||||
iff.mp !lt_add_iff_sub_lt_right
|
||||
|
||||
theorem sub_lt_of_sub_lt {a b c : A} : a - b < c → a - c < b :=
|
||||
begin
|
||||
intro H,
|
||||
apply sub_lt_left_of_lt_add,
|
||||
apply lt_add_of_sub_lt_right H
|
||||
end
|
||||
|
||||
theorem sub_le_of_sub_le {a b c : A} : a - b ≤ c → a - c ≤ b :=
|
||||
begin
|
||||
intro H,
|
||||
apply sub_left_le_of_le_add,
|
||||
apply le_add_of_sub_right_le H
|
||||
end
|
||||
|
||||
-- TODO: the Isabelle library has varations on a + b ≤ b ↔ a ≤ 0
|
||||
theorem le_iff_le_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a ≤ b ↔ c ≤ d :=
|
||||
calc
|
||||
a ≤ b ↔ a - b ≤ 0 : iff.symm (sub_nonpos_iff_le a b)
|
||||
... = (c - d ≤ 0) : by rewrite H
|
||||
... ↔ c ≤ d : sub_nonpos_iff_le c d
|
||||
|
||||
theorem lt_iff_lt_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a < b ↔ c < d :=
|
||||
calc
|
||||
a < b ↔ a - b < 0 : iff.symm (sub_neg_iff_lt a b)
|
||||
... = (c - d < 0) : by rewrite H
|
||||
... ↔ c < d : sub_neg_iff_lt c d
|
||||
|
||||
theorem sub_le_sub_left {a b : A} (H : a ≤ b) (c : A) : c - b ≤ c - a :=
|
||||
add_le_add_left (neg_le_neg H) c
|
||||
|
||||
theorem sub_le_sub_right {a b : A} (H : a ≤ b) (c : A) : a - c ≤ b - c := add_le_add_right H (-c)
|
||||
|
||||
theorem sub_le_sub {a b c d : A} (Hab : a ≤ b) (Hcd : c ≤ d) : a - d ≤ b - c :=
|
||||
add_le_add Hab (neg_le_neg Hcd)
|
||||
|
||||
theorem sub_lt_sub_left {a b : A} (H : a < b) (c : A) : c - b < c - a :=
|
||||
add_lt_add_left (neg_lt_neg H) c
|
||||
|
||||
theorem sub_lt_sub_right {a b : A} (H : a < b) (c : A) : a - c < b - c := add_lt_add_right H (-c)
|
||||
|
||||
theorem sub_lt_sub {a b c d : A} (Hab : a < b) (Hcd : c < d) : a - d < b - c :=
|
||||
add_lt_add Hab (neg_lt_neg Hcd)
|
||||
|
||||
theorem sub_lt_sub_of_le_of_lt {a b c d : A} (Hab : a ≤ b) (Hcd : c < d) : a - d < b - c :=
|
||||
add_lt_add_of_le_of_lt Hab (neg_lt_neg Hcd)
|
||||
|
||||
theorem sub_lt_sub_of_lt_of_le {a b c d : A} (Hab : a < b) (Hcd : c ≤ d) : a - d < b - c :=
|
||||
add_lt_add_of_lt_of_le Hab (neg_le_neg Hcd)
|
||||
|
||||
theorem sub_le_self (a : A) {b : A} (H : b ≥ 0) : a - b ≤ a :=
|
||||
calc
|
||||
a - b = a + -b : rfl
|
||||
... ≤ a + 0 : add_le_add_left (neg_nonpos_of_nonneg H)
|
||||
... = a : by rewrite add_zero
|
||||
|
||||
theorem sub_lt_self (a : A) {b : A} (H : b > 0) : a - b < a :=
|
||||
calc
|
||||
a - b = a + -b : rfl
|
||||
... < a + 0 : add_lt_add_left (neg_neg_of_pos H)
|
||||
... = a : by rewrite add_zero
|
||||
|
||||
theorem add_le_add_three {a b c d e f : A} (H1 : a ≤ d) (H2 : b ≤ e) (H3 : c ≤ f) :
|
||||
a + b + c ≤ d + e + f :=
|
||||
begin
|
||||
apply le.trans,
|
||||
apply add_le_add,
|
||||
apply add_le_add,
|
||||
repeat assumption,
|
||||
apply le.refl
|
||||
end
|
||||
|
||||
theorem sub_le_of_nonneg {b : A} (H : b ≥ 0) : a - b ≤ a :=
|
||||
add_le_of_le_of_nonpos (le.refl a) (neg_nonpos_of_nonneg H)
|
||||
|
||||
theorem sub_lt_of_pos {b : A} (H : b > 0) : a - b < a :=
|
||||
add_lt_of_le_of_neg (le.refl a) (neg_neg_of_pos H)
|
||||
|
||||
theorem neg_add_neg_le_neg_of_pos {a : A} (H : a > 0) : -a + -a ≤ -a :=
|
||||
!neg_add ▸ neg_le_neg (le_add_of_nonneg_left (le_of_lt H))
|
||||
end
|
||||
|
||||
/- linear ordered group with decidable order -/
|
||||
|
||||
structure decidable_linear_ordered_mul_ab_group [class] (A : Type)
|
||||
extends ab_group A, decidable_linear_order A :=
|
||||
(mul_le_mul_left : Π a b, le a b → Π c, le (mul c a) (mul c b))
|
||||
(mul_lt_mul_left : Π a b, lt a b → Π c, lt (mul c a) (mul c b))
|
||||
|
||||
definition decidable_linear_ordered_ab_group [class] : Type → Type :=
|
||||
decidable_linear_ordered_mul_ab_group
|
||||
|
||||
definition add_ab_group_of_decidable_linear_ordered_ab_group [reducible] [trans_instance] (A : Type)
|
||||
[H : decidable_linear_ordered_ab_group A] : add_ab_group A :=
|
||||
@decidable_linear_ordered_mul_ab_group.to_ab_group A H
|
||||
|
||||
definition decidable_linear_order_of_decidable_linear_ordered_ab_group [reducible]
|
||||
[trans_instance] (A : Type) [H : decidable_linear_ordered_ab_group A] :
|
||||
decidable_linear_order A :=
|
||||
@decidable_linear_ordered_mul_ab_group.to_decidable_linear_order A H
|
||||
|
||||
definition decidable_linear_ordered_mul_ab_group.to_ordered_mul_ab_group [reducible]
|
||||
[trans_instance] (A : Type) [s : decidable_linear_ordered_mul_ab_group A] :
|
||||
ordered_mul_ab_group A :=
|
||||
⦃ ordered_mul_ab_group, s,
|
||||
le_of_lt := @le_of_lt A _,
|
||||
lt_of_le_of_lt := @lt_of_le_of_lt A _,
|
||||
lt_of_lt_of_le := @lt_of_lt_of_le A _ ⦄
|
||||
|
||||
definition decidable_linear_ordered_ab_group.to_ordered_ab_group [reducible] [trans_instance]
|
||||
(A : Type) [s : decidable_linear_ordered_ab_group A] : ordered_ab_group A :=
|
||||
@decidable_linear_ordered_mul_ab_group.to_ordered_mul_ab_group A s
|
||||
|
||||
section
|
||||
variables [s : decidable_linear_ordered_ab_group A]
|
||||
variables {a b c d e : A}
|
||||
include s
|
||||
|
||||
/- these can be generalized to a lattice ordered group -/
|
||||
|
||||
theorem min_add_add_left : min (a + b) (a + c) = a + min b c :=
|
||||
inverse (eq_min
|
||||
(show a + min b c ≤ a + b, from add_le_add_left !min_le_left _)
|
||||
(show a + min b c ≤ a + c, from add_le_add_left !min_le_right _)
|
||||
(take d,
|
||||
assume H₁ : d ≤ a + b,
|
||||
assume H₂ : d ≤ a + c,
|
||||
have H : d - a ≤ min b c,
|
||||
from le_min (iff.mp !le_add_iff_sub_left_le H₁) (iff.mp !le_add_iff_sub_left_le H₂),
|
||||
show d ≤ a + min b c, from iff.mpr !le_add_iff_sub_left_le H))
|
||||
|
||||
theorem min_add_add_right : min (a + c) (b + c) = min a b + c :=
|
||||
by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply min_add_add_left
|
||||
|
||||
theorem max_add_add_left : max (a + b) (a + c) = a + max b c :=
|
||||
inverse (eq_max
|
||||
(add_le_add_left !le_max_left _)
|
||||
(add_le_add_left !le_max_right _)
|
||||
(λ d H₁ H₂,
|
||||
have H : max b c ≤ d - a,
|
||||
from max_le (iff.mp !add_le_iff_le_sub_left H₁) (iff.mp !add_le_iff_le_sub_left H₂),
|
||||
show a + max b c ≤ d, from iff.mpr !add_le_iff_le_sub_left H))
|
||||
|
||||
theorem max_add_add_right : max (a + c) (b + c) = max a b + c :=
|
||||
by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply max_add_add_left
|
||||
|
||||
theorem max_neg_neg : max (-a) (-b) = - min a b :=
|
||||
inverse (eq_max
|
||||
(show -a ≤ -(min a b), from neg_le_neg !min_le_left)
|
||||
(show -b ≤ -(min a b), from neg_le_neg !min_le_right)
|
||||
(take d,
|
||||
assume H₁ : -a ≤ d,
|
||||
assume H₂ : -b ≤ d,
|
||||
have H : -d ≤ min a b,
|
||||
from le_min (!iff.mp !neg_le_iff_neg_le H₁) (!iff.mp !neg_le_iff_neg_le H₂),
|
||||
show -(min a b) ≤ d, from !iff.mp !neg_le_iff_neg_le H))
|
||||
|
||||
theorem min_eq_neg_max_neg_neg : min a b = - max (-a) (-b) :=
|
||||
by rewrite [max_neg_neg, neg_neg]
|
||||
|
||||
theorem min_neg_neg : min (-a) (-b) = - max a b :=
|
||||
by rewrite [min_eq_neg_max_neg_neg, *neg_neg]
|
||||
|
||||
theorem max_eq_neg_min_neg_neg : max a b = - min (-a) (-b) :=
|
||||
by rewrite [min_neg_neg, neg_neg]
|
||||
|
||||
/- absolute value -/
|
||||
variables {a b c}
|
||||
|
||||
definition abs (a : A) : A := max a (-a)
|
||||
|
||||
theorem abs_of_nonneg (H : a ≥ 0) : abs a = a :=
|
||||
have H' : -a ≤ a, from le.trans (neg_nonpos_of_nonneg H) H,
|
||||
max_eq_left H'
|
||||
|
||||
theorem abs_of_pos (H : a > 0) : abs a = a :=
|
||||
abs_of_nonneg (le_of_lt H)
|
||||
|
||||
theorem abs_of_nonpos (H : a ≤ 0) : abs a = -a :=
|
||||
have H' : a ≤ -a, from le.trans H (neg_nonneg_of_nonpos H),
|
||||
max_eq_right H'
|
||||
|
||||
theorem abs_of_neg (H : a < 0) : abs a = -a := abs_of_nonpos (le_of_lt H)
|
||||
|
||||
theorem abs_zero : abs 0 = (0:A) := abs_of_nonneg (le.refl _)
|
||||
|
||||
theorem abs_neg (a : A) : abs (-a) = abs a :=
|
||||
by rewrite [↑abs, max.comm, neg_neg]
|
||||
|
||||
theorem abs_pos_of_pos (H : a > 0) : abs a > 0 :=
|
||||
by rewrite (abs_of_pos H); exact H
|
||||
|
||||
theorem abs_pos_of_neg (H : a < 0) : abs a > 0 :=
|
||||
!abs_neg ▸ abs_pos_of_pos (neg_pos_of_neg H)
|
||||
|
||||
theorem abs_sub (a b : A) : abs (a - b) = abs (b - a) :=
|
||||
by rewrite [-neg_sub, abs_neg]
|
||||
|
||||
theorem ne_zero_of_abs_ne_zero {a : A} (H : abs a ≠ 0) : a ≠ 0 :=
|
||||
assume Ha, H (Ha⁻¹ ▸ abs_zero)
|
||||
|
||||
/- these assume a linear order -/
|
||||
|
||||
theorem eq_zero_of_neg_eq (H : -a = a) : a = 0 :=
|
||||
lt.by_cases
|
||||
(assume H1 : a < 0,
|
||||
have H2: a > 0, from H ▸ neg_pos_of_neg H1,
|
||||
absurd H1 (lt.asymm H2))
|
||||
(assume H1 : a = 0, H1)
|
||||
(assume H1 : a > 0,
|
||||
have H2: a < 0, from H ▸ neg_neg_of_pos H1,
|
||||
absurd H1 (lt.asymm H2))
|
||||
|
||||
theorem abs_nonneg (a : A) : abs a ≥ 0 :=
|
||||
sum.elim (le.total 0 a)
|
||||
(assume H : 0 ≤ a, by rewrite (abs_of_nonneg H); exact H)
|
||||
(assume H : a ≤ 0,
|
||||
calc
|
||||
0 ≤ -a : neg_nonneg_of_nonpos H
|
||||
... = abs a : abs_of_nonpos H)
|
||||
|
||||
theorem abs_abs (a : A) : abs (abs a) = abs a := abs_of_nonneg !abs_nonneg
|
||||
|
||||
theorem le_abs_self (a : A) : a ≤ abs a :=
|
||||
sum.elim (le.total 0 a)
|
||||
(assume H : 0 ≤ a, abs_of_nonneg H ▸ !le.refl)
|
||||
(assume H : a ≤ 0, le.trans H !abs_nonneg)
|
||||
|
||||
theorem neg_le_abs_self (a : A) : -a ≤ abs a :=
|
||||
!abs_neg ▸ !le_abs_self
|
||||
|
||||
theorem eq_zero_of_abs_eq_zero (H : abs a = 0) : a = 0 :=
|
||||
have H1 : a ≤ 0, from H ▸ le_abs_self a,
|
||||
have H2 : -a ≤ 0, from H ▸ abs_neg a ▸ le_abs_self (-a),
|
||||
le.antisymm H1 (nonneg_of_neg_nonpos H2)
|
||||
|
||||
theorem abs_eq_zero_iff_eq_zero (a : A) : abs a = 0 ↔ a = 0 :=
|
||||
iff.intro eq_zero_of_abs_eq_zero (assume H, ap abs H ⬝ !abs_zero)
|
||||
|
||||
theorem eq_of_abs_sub_eq_zero {a b : A} (H : abs (a - b) = 0) : a = b :=
|
||||
have a - b = 0, from eq_zero_of_abs_eq_zero H,
|
||||
show a = b, from eq_of_sub_eq_zero this
|
||||
|
||||
theorem abs_pos_of_ne_zero (H : a ≠ 0) : abs a > 0 :=
|
||||
sum.elim (lt_sum_gt_of_ne H) abs_pos_of_neg abs_pos_of_pos
|
||||
|
||||
theorem abs.by_cases {P : A → Type} {a : A} (H1 : P a) (H2 : P (-a)) : P (abs a) :=
|
||||
sum.elim (le.total 0 a)
|
||||
(assume H : 0 ≤ a, (abs_of_nonneg H)⁻¹ ▸ H1)
|
||||
(assume H : a ≤ 0, (abs_of_nonpos H)⁻¹ ▸ H2)
|
||||
|
||||
theorem abs_le_of_le_of_neg_le (H1 : a ≤ b) (H2 : -a ≤ b) : abs a ≤ b :=
|
||||
abs.by_cases H1 H2
|
||||
|
||||
theorem abs_lt_of_lt_of_neg_lt (H1 : a < b) (H2 : -a < b) : abs a < b :=
|
||||
abs.by_cases H1 H2
|
||||
|
||||
-- the triangle inequality
|
||||
section
|
||||
private lemma aux1 {a b : A} (H1 : a + b ≥ 0) (H2 : a ≥ 0) : abs (a + b) ≤ abs a + abs b :=
|
||||
decidable.by_cases
|
||||
(assume H3 : b ≥ 0,
|
||||
calc
|
||||
abs (a + b) ≤ abs (a + b) : le.refl
|
||||
... = a + b : by rewrite (abs_of_nonneg H1)
|
||||
... = abs a + b : by rewrite (abs_of_nonneg H2)
|
||||
... = abs a + abs b : by rewrite (abs_of_nonneg H3))
|
||||
(assume H3 : ¬ b ≥ 0,
|
||||
have H4 : b ≤ 0, from le_of_lt (lt_of_not_ge H3),
|
||||
calc
|
||||
abs (a + b) = a + b : by rewrite (abs_of_nonneg H1)
|
||||
... = abs a + b : by rewrite (abs_of_nonneg H2)
|
||||
... ≤ abs a + 0 : add_le_add_left H4
|
||||
... ≤ abs a + -b : add_le_add_left (neg_nonneg_of_nonpos H4)
|
||||
... = abs a + abs b : by rewrite (abs_of_nonpos H4))
|
||||
|
||||
private lemma aux2 {a b : A} (H1 : a + b ≥ 0) : abs (a + b) ≤ abs a + abs b :=
|
||||
sum.elim (le.total b 0)
|
||||
(assume H2 : b ≤ 0,
|
||||
have H3 : ¬ a < 0, from
|
||||
assume H4 : a < 0,
|
||||
have H5 : a + b < 0, from !add_zero ▸ add_lt_add_of_lt_of_le H4 H2,
|
||||
not_lt_of_ge H1 H5,
|
||||
aux1 H1 (le_of_not_gt H3))
|
||||
(assume H2 : 0 ≤ b,
|
||||
begin
|
||||
have H3 : abs (b + a) ≤ abs b + abs a,
|
||||
begin
|
||||
rewrite add.comm at H1,
|
||||
exact aux1 H1 H2
|
||||
end,
|
||||
rewrite [add.comm, {abs a + _}add.comm],
|
||||
exact H3
|
||||
end)
|
||||
|
||||
theorem abs_add_le_abs_add_abs (a b : A) : abs (a + b) ≤ abs a + abs b :=
|
||||
sum.elim (le.total 0 (a + b))
|
||||
(assume H2 : 0 ≤ a + b, aux2 H2)
|
||||
(assume H2 : a + b ≤ 0,
|
||||
have H3 : -a + -b = -(a + b), by rewrite neg_add,
|
||||
have H4 : -(a + b) ≥ 0, from iff.mpr (neg_nonneg_iff_nonpos (a+b)) H2,
|
||||
have H5 : -a + -b ≥ 0, begin rewrite -H3 at H4, exact H4 end,
|
||||
calc
|
||||
abs (a + b) = abs (-a + -b) : by rewrite [-abs_neg, neg_add]
|
||||
... ≤ abs (-a) + abs (-b) : aux2 H5
|
||||
... = abs a + abs b : by rewrite *abs_neg)
|
||||
|
||||
theorem abs_sub_abs_le_abs_sub (a b : A) : abs a - abs b ≤ abs (a - b) :=
|
||||
have H1 : abs a - abs b + abs b ≤ abs (a - b) + abs b, from
|
||||
calc
|
||||
abs a - abs b + abs b = abs a : by rewrite sub_add_cancel
|
||||
... = abs (a - b + b) : by rewrite sub_add_cancel
|
||||
... ≤ abs (a - b) + abs b : abs_add_le_abs_add_abs,
|
||||
le_of_add_le_add_right H1
|
||||
|
||||
theorem abs_sub_le (a b c : A) : abs (a - c) ≤ abs (a - b) + abs (b - c) :=
|
||||
calc
|
||||
abs (a - c) = abs (a - b + (b - c)) : by rewrite [*sub_eq_add_neg, add.assoc, neg_add_cancel_left]
|
||||
... ≤ abs (a - b) + abs (b - c) : abs_add_le_abs_add_abs
|
||||
|
||||
theorem abs_add_three (a b c : A) : abs (a + b + c) ≤ abs a + abs b + abs c :=
|
||||
begin
|
||||
apply le.trans,
|
||||
apply abs_add_le_abs_add_abs,
|
||||
apply le.trans,
|
||||
apply add_le_add_right,
|
||||
apply abs_add_le_abs_add_abs,
|
||||
apply le.refl
|
||||
end
|
||||
|
||||
theorem dist_bdd_within_interval {a b lb ub : A} (H : lb < ub) (Hal : lb ≤ a) (Hau : a ≤ ub)
|
||||
(Hbl : lb ≤ b) (Hbu : b ≤ ub) : abs (a - b) ≤ ub - lb :=
|
||||
begin
|
||||
cases (decidable.em (b ≤ a)) with [Hba, Hba],
|
||||
rewrite (abs_of_nonneg (iff.mpr !sub_nonneg_iff_le Hba)),
|
||||
apply sub_le_sub,
|
||||
apply Hau,
|
||||
apply Hbl,
|
||||
rewrite [abs_of_neg (iff.mpr !sub_neg_iff_lt (lt_of_not_ge Hba)), neg_sub],
|
||||
apply sub_le_sub,
|
||||
apply Hbu,
|
||||
apply Hal
|
||||
end
|
||||
|
||||
end
|
||||
end
|
||||
|
||||
end algebra
|
||||
|
|
@ -1,792 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad
|
||||
|
||||
Here an "ordered_ring" is partially ordered ring, which is ordered with respect to both a weak
|
||||
order and an associated strict order. Our numeric structures (int, rat, and real) will be instances
|
||||
of "linear_ordered_comm_ring". This development is modeled after Isabelle's library.
|
||||
-/
|
||||
|
||||
import algebra.ordered_group algebra.ring
|
||||
open eq eq.ops algebra
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
namespace algebra
|
||||
private definition absurd_a_lt_a {B : Type} {a : A} [s : strict_order A] (H : a < a) : B :=
|
||||
absurd H (lt.irrefl a)
|
||||
|
||||
/- semiring structures -/
|
||||
|
||||
structure ordered_semiring (A : Type)
|
||||
extends semiring A, ordered_mul_cancel_comm_monoid A renaming
|
||||
mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero mul_comm→add_comm
|
||||
mul_left_cancel→add_left_cancel mul_right_cancel→add_right_cancel mul_le_mul_left→add_le_add_left
|
||||
mul_lt_mul_left→add_lt_add_left le_of_mul_le_mul_left→le_of_add_le_add_left
|
||||
lt_of_mul_lt_mul_left→lt_of_add_lt_add_left :=
|
||||
(mul_le_mul_of_nonneg_left: Πa b c, le a b → le zero c → le (mul c a) (mul c b))
|
||||
(mul_le_mul_of_nonneg_right: Πa b c, le a b → le zero c → le (mul a c) (mul b c))
|
||||
(mul_lt_mul_of_pos_left: Πa b c, lt a b → lt zero c → lt (mul c a) (mul c b))
|
||||
(mul_lt_mul_of_pos_right: Πa b c, lt a b → lt zero c → lt (mul a c) (mul b c))
|
||||
|
||||
-- /- we make it a class now (and not as part of the structure) to avoid
|
||||
-- ordered_semiring.to_ordered_mul_cancel_comm_monoid to be an instance -/
|
||||
attribute ordered_semiring [class]
|
||||
|
||||
definition add_ab_group_of_ordered_semiring [trans_instance] [reducible] (A : Type)
|
||||
[H : ordered_semiring A] : semiring A :=
|
||||
@ordered_semiring.to_semiring A H
|
||||
|
||||
definition monoid_of_ordered_semiring [trans_instance] [reducible] (A : Type)
|
||||
[H : ordered_semiring A] : ordered_cancel_comm_monoid A :=
|
||||
@ordered_semiring.to_ordered_mul_cancel_comm_monoid A H
|
||||
|
||||
section
|
||||
variable [s : ordered_semiring A]
|
||||
variables (a b c d e : A)
|
||||
include s
|
||||
|
||||
theorem mul_le_mul_of_nonneg_left {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) :
|
||||
c * a ≤ c * b := !ordered_semiring.mul_le_mul_of_nonneg_left Hab Hc
|
||||
|
||||
theorem mul_le_mul_of_nonneg_right {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) :
|
||||
a * c ≤ b * c := !ordered_semiring.mul_le_mul_of_nonneg_right Hab Hc
|
||||
|
||||
-- TODO: there are four variations, depending on which variables we assume to be nonneg
|
||||
theorem mul_le_mul {a b c d : A} (Hac : a ≤ c) (Hbd : b ≤ d) (nn_b : 0 ≤ b) (nn_c : 0 ≤ c) :
|
||||
a * b ≤ c * d :=
|
||||
calc
|
||||
a * b ≤ c * b : mul_le_mul_of_nonneg_right Hac nn_b
|
||||
... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c
|
||||
|
||||
theorem mul_nonneg {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0) : a * b ≥ 0 :=
|
||||
begin
|
||||
have H : 0 * b ≤ a * b, from mul_le_mul_of_nonneg_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_nonpos_of_nonneg_of_nonpos {a b : A} (Ha : a ≥ 0) (Hb : b ≤ 0) : a * b ≤ 0 :=
|
||||
begin
|
||||
have H : a * b ≤ a * 0, from mul_le_mul_of_nonneg_left Hb Ha,
|
||||
rewrite mul_zero at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_nonpos_of_nonpos_of_nonneg {a b : A} (Ha : a ≤ 0) (Hb : b ≥ 0) : a * b ≤ 0 :=
|
||||
begin
|
||||
have H : a * b ≤ 0 * b, from mul_le_mul_of_nonneg_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_lt_mul_of_pos_left {a b c : A} (Hab : a < b) (Hc : 0 < c) :
|
||||
c * a < c * b := !ordered_semiring.mul_lt_mul_of_pos_left Hab Hc
|
||||
|
||||
theorem mul_lt_mul_of_pos_right {a b c : A} (Hab : a < b) (Hc : 0 < c) :
|
||||
a * c < b * c := !ordered_semiring.mul_lt_mul_of_pos_right Hab Hc
|
||||
|
||||
-- TODO: once again, there are variations
|
||||
theorem mul_lt_mul {a b c d : A} (Hac : a < c) (Hbd : b ≤ d) (pos_b : 0 < b) (nn_c : 0 ≤ c) :
|
||||
a * b < c * d :=
|
||||
calc
|
||||
a * b < c * b : mul_lt_mul_of_pos_right Hac pos_b
|
||||
... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c
|
||||
|
||||
theorem mul_pos {a b : A} (Ha : a > 0) (Hb : b > 0) : a * b > 0 :=
|
||||
begin
|
||||
have H : 0 * b < a * b, from mul_lt_mul_of_pos_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_neg_of_pos_of_neg {a b : A} (Ha : a > 0) (Hb : b < 0) : a * b < 0 :=
|
||||
begin
|
||||
have H : a * b < a * 0, from mul_lt_mul_of_pos_left Hb Ha,
|
||||
rewrite mul_zero at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_neg_of_neg_of_pos {a b : A} (Ha : a < 0) (Hb : b > 0) : a * b < 0 :=
|
||||
begin
|
||||
have H : a * b < 0 * b, from mul_lt_mul_of_pos_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
end
|
||||
|
||||
structure linear_ordered_semiring [class] (A : Type)
|
||||
extends ordered_semiring A, linear_strong_order_pair A :=
|
||||
(zero_lt_one : lt zero one)
|
||||
|
||||
section
|
||||
variable [s : linear_ordered_semiring A]
|
||||
variables {a b c : A}
|
||||
include s
|
||||
|
||||
theorem zero_lt_one : 0 < (1:A) := linear_ordered_semiring.zero_lt_one A
|
||||
|
||||
theorem lt_of_mul_lt_mul_left (H : c * a < c * b) (Hc : c ≥ 0) : a < b :=
|
||||
lt_of_not_ge
|
||||
(assume H1 : b ≤ a,
|
||||
have H2 : c * b ≤ c * a, from mul_le_mul_of_nonneg_left H1 Hc,
|
||||
not_lt_of_ge H2 H)
|
||||
|
||||
theorem lt_of_mul_lt_mul_right (H : a * c < b * c) (Hc : c ≥ 0) : a < b :=
|
||||
lt_of_not_ge
|
||||
(assume H1 : b ≤ a,
|
||||
have H2 : b * c ≤ a * c, from mul_le_mul_of_nonneg_right H1 Hc,
|
||||
not_lt_of_ge H2 H)
|
||||
|
||||
theorem le_of_mul_le_mul_left (H : c * a ≤ c * b) (Hc : c > 0) : a ≤ b :=
|
||||
le_of_not_gt
|
||||
(assume H1 : b < a,
|
||||
have H2 : c * b < c * a, from mul_lt_mul_of_pos_left H1 Hc,
|
||||
not_le_of_gt H2 H)
|
||||
|
||||
theorem le_of_mul_le_mul_right (H : a * c ≤ b * c) (Hc : c > 0) : a ≤ b :=
|
||||
le_of_not_gt
|
||||
(assume H1 : b < a,
|
||||
have H2 : b * c < a * c, from mul_lt_mul_of_pos_right H1 Hc,
|
||||
not_le_of_gt H2 H)
|
||||
|
||||
theorem le_iff_mul_le_mul_left (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ c * a ≤ c * b :=
|
||||
iff.intro
|
||||
(assume H', mul_le_mul_of_nonneg_left H' (le_of_lt H))
|
||||
(assume H', le_of_mul_le_mul_left H' H)
|
||||
|
||||
theorem le_iff_mul_le_mul_right (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ a * c ≤ b * c :=
|
||||
iff.intro
|
||||
(assume H', mul_le_mul_of_nonneg_right H' (le_of_lt H))
|
||||
(assume H', le_of_mul_le_mul_right H' H)
|
||||
|
||||
theorem pos_of_mul_pos_left (H : 0 < a * b) (H1 : 0 ≤ a) : 0 < b :=
|
||||
lt_of_not_ge
|
||||
(assume H2 : b ≤ 0,
|
||||
have H3 : a * b ≤ 0, from mul_nonpos_of_nonneg_of_nonpos H1 H2,
|
||||
not_lt_of_ge H3 H)
|
||||
|
||||
theorem pos_of_mul_pos_right (H : 0 < a * b) (H1 : 0 ≤ b) : 0 < a :=
|
||||
lt_of_not_ge
|
||||
(assume H2 : a ≤ 0,
|
||||
have H3 : a * b ≤ 0, from mul_nonpos_of_nonpos_of_nonneg H2 H1,
|
||||
not_lt_of_ge H3 H)
|
||||
|
||||
theorem nonneg_of_mul_nonneg_left (H : 0 ≤ a * b) (H1 : 0 < a) : 0 ≤ b :=
|
||||
le_of_not_gt
|
||||
(assume H2 : b < 0,
|
||||
not_le_of_gt (mul_neg_of_pos_of_neg H1 H2) H)
|
||||
|
||||
theorem nonneg_of_mul_nonneg_right (H : 0 ≤ a * b) (H1 : 0 < b) : 0 ≤ a :=
|
||||
le_of_not_gt
|
||||
(assume H2 : a < 0,
|
||||
not_le_of_gt (mul_neg_of_neg_of_pos H2 H1) H)
|
||||
|
||||
theorem neg_of_mul_neg_left (H : a * b < 0) (H1 : 0 ≤ a) : b < 0 :=
|
||||
lt_of_not_ge
|
||||
(assume H2 : b ≥ 0,
|
||||
not_lt_of_ge (mul_nonneg H1 H2) H)
|
||||
|
||||
theorem neg_of_mul_neg_right (H : a * b < 0) (H1 : 0 ≤ b) : a < 0 :=
|
||||
lt_of_not_ge
|
||||
(assume H2 : a ≥ 0,
|
||||
not_lt_of_ge (mul_nonneg H2 H1) H)
|
||||
|
||||
theorem nonpos_of_mul_nonpos_left (H : a * b ≤ 0) (H1 : 0 < a) : b ≤ 0 :=
|
||||
le_of_not_gt
|
||||
(assume H2 : b > 0,
|
||||
not_le_of_gt (mul_pos H1 H2) H)
|
||||
|
||||
theorem nonpos_of_mul_nonpos_right (H : a * b ≤ 0) (H1 : 0 < b) : a ≤ 0 :=
|
||||
le_of_not_gt
|
||||
(assume H2 : a > 0,
|
||||
not_le_of_gt (mul_pos H2 H1) H)
|
||||
end
|
||||
|
||||
structure decidable_linear_ordered_semiring [class] (A : Type)
|
||||
extends linear_ordered_semiring A, decidable_linear_order A
|
||||
|
||||
/- ring structures -/
|
||||
|
||||
structure ordered_ring (A : Type) extends ring A, ordered_mul_ab_group A renaming
|
||||
mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero inv→neg
|
||||
mul_left_inv→add_left_inv mul_comm→add_comm mul_le_mul_left→add_le_add_left
|
||||
mul_lt_mul_left→add_lt_add_left,
|
||||
zero_ne_one_class A :=
|
||||
(mul_nonneg : Πa b, le zero a → le zero b → le zero (mul a b))
|
||||
(mul_pos : Πa b, lt zero a → lt zero b → lt zero (mul a b))
|
||||
|
||||
-- /- we make it a class now (and not as part of the structure) to avoid
|
||||
-- ordered_ring.to_ordered_mul_ab_group to be an instance -/
|
||||
attribute ordered_ring [class]
|
||||
|
||||
definition add_ab_group_of_ordered_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ordered_ring A] : ring A :=
|
||||
@ordered_ring.to_ring A H
|
||||
|
||||
definition monoid_of_ordered_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ordered_ring A] : ordered_ab_group A :=
|
||||
@ordered_ring.to_ordered_mul_ab_group A H
|
||||
|
||||
definition zero_ne_one_class_of_ordered_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ordered_ring A] : zero_ne_one_class A :=
|
||||
@ordered_ring.to_zero_ne_one_class A H
|
||||
|
||||
theorem ordered_ring.mul_le_mul_of_nonneg_left [s : ordered_ring A] {a b c : A}
|
||||
(Hab : a ≤ b) (Hc : 0 ≤ c) : c * a ≤ c * b :=
|
||||
have H1 : 0 ≤ b - a, from iff.elim_right !sub_nonneg_iff_le Hab,
|
||||
have H2 : 0 ≤ c * (b - a), from ordered_ring.mul_nonneg _ _ _ Hc H1,
|
||||
begin
|
||||
rewrite mul_sub_left_distrib at H2,
|
||||
exact (iff.mp !sub_nonneg_iff_le H2)
|
||||
end
|
||||
|
||||
theorem ordered_ring.mul_le_mul_of_nonneg_right [s : ordered_ring A] {a b c : A}
|
||||
(Hab : a ≤ b) (Hc : 0 ≤ c) : a * c ≤ b * c :=
|
||||
have H1 : 0 ≤ b - a, from iff.elim_right !sub_nonneg_iff_le Hab,
|
||||
have H2 : 0 ≤ (b - a) * c, from ordered_ring.mul_nonneg _ _ _ H1 Hc,
|
||||
begin
|
||||
rewrite mul_sub_right_distrib at H2,
|
||||
exact (iff.mp !sub_nonneg_iff_le H2)
|
||||
end
|
||||
|
||||
theorem ordered_ring.mul_lt_mul_of_pos_left [s : ordered_ring A] {a b c : A}
|
||||
(Hab : a < b) (Hc : 0 < c) : c * a < c * b :=
|
||||
have H1 : 0 < b - a, from iff.elim_right !sub_pos_iff_lt Hab,
|
||||
have H2 : 0 < c * (b - a), from ordered_ring.mul_pos _ _ _ Hc H1,
|
||||
begin
|
||||
rewrite mul_sub_left_distrib at H2,
|
||||
exact (iff.mp !sub_pos_iff_lt H2)
|
||||
end
|
||||
|
||||
theorem ordered_ring.mul_lt_mul_of_pos_right [s : ordered_ring A] {a b c : A}
|
||||
(Hab : a < b) (Hc : 0 < c) : a * c < b * c :=
|
||||
have H1 : 0 < b - a, from iff.elim_right !sub_pos_iff_lt Hab,
|
||||
have H2 : 0 < (b - a) * c, from ordered_ring.mul_pos _ _ _ H1 Hc,
|
||||
begin
|
||||
rewrite mul_sub_right_distrib at H2,
|
||||
exact (iff.mp !sub_pos_iff_lt H2)
|
||||
end
|
||||
|
||||
definition ordered_ring.to_ordered_semiring [reducible] [trans_instance] [s : ordered_ring A] :
|
||||
ordered_semiring A :=
|
||||
⦃ ordered_semiring, s,
|
||||
mul_zero := mul_zero,
|
||||
zero_mul := zero_mul,
|
||||
add_left_cancel := @add.left_cancel A _,
|
||||
add_right_cancel := @add.right_cancel A _,
|
||||
le_of_add_le_add_left := @le_of_add_le_add_left A _,
|
||||
mul_le_mul_of_nonneg_left := @ordered_ring.mul_le_mul_of_nonneg_left A _,
|
||||
mul_le_mul_of_nonneg_right := @ordered_ring.mul_le_mul_of_nonneg_right A _,
|
||||
mul_lt_mul_of_pos_left := @ordered_ring.mul_lt_mul_of_pos_left A _,
|
||||
mul_lt_mul_of_pos_right := @ordered_ring.mul_lt_mul_of_pos_right A _,
|
||||
lt_of_add_lt_add_left := @lt_of_add_lt_add_left A _⦄
|
||||
|
||||
section
|
||||
variable [s : ordered_ring A]
|
||||
variables {a b c : A}
|
||||
include s
|
||||
|
||||
theorem mul_le_mul_of_nonpos_left (H : b ≤ a) (Hc : c ≤ 0) : c * a ≤ c * b :=
|
||||
have Hc' : -c ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos Hc,
|
||||
have H1 : -c * b ≤ -c * a, from mul_le_mul_of_nonneg_left H Hc',
|
||||
have H2 : -(c * b) ≤ -(c * a),
|
||||
begin
|
||||
rewrite [-*neg_mul_eq_neg_mul at H1],
|
||||
exact H1
|
||||
end,
|
||||
iff.mp !neg_le_neg_iff_le H2
|
||||
|
||||
theorem mul_le_mul_of_nonpos_right (H : b ≤ a) (Hc : c ≤ 0) : a * c ≤ b * c :=
|
||||
have Hc' : -c ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos Hc,
|
||||
have H1 : b * -c ≤ a * -c, from mul_le_mul_of_nonneg_right H Hc',
|
||||
have H2 : -(b * c) ≤ -(a * c),
|
||||
begin
|
||||
rewrite [-*neg_mul_eq_mul_neg at H1],
|
||||
exact H1
|
||||
end,
|
||||
iff.mp !neg_le_neg_iff_le H2
|
||||
|
||||
theorem mul_nonneg_of_nonpos_of_nonpos (Ha : a ≤ 0) (Hb : b ≤ 0) : 0 ≤ a * b :=
|
||||
begin
|
||||
have H : 0 * b ≤ a * b, from mul_le_mul_of_nonpos_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
theorem mul_lt_mul_of_neg_left (H : b < a) (Hc : c < 0) : c * a < c * b :=
|
||||
have Hc' : -c > 0, from iff.mpr !neg_pos_iff_neg Hc,
|
||||
have H1 : -c * b < -c * a, from mul_lt_mul_of_pos_left H Hc',
|
||||
have H2 : -(c * b) < -(c * a),
|
||||
begin
|
||||
rewrite [-*neg_mul_eq_neg_mul at H1],
|
||||
exact H1
|
||||
end,
|
||||
iff.mp !neg_lt_neg_iff_lt H2
|
||||
|
||||
theorem mul_lt_mul_of_neg_right (H : b < a) (Hc : c < 0) : a * c < b * c :=
|
||||
have Hc' : -c > 0, from iff.mpr !neg_pos_iff_neg Hc,
|
||||
have H1 : b * -c < a * -c, from mul_lt_mul_of_pos_right H Hc',
|
||||
have H2 : -(b * c) < -(a * c),
|
||||
begin
|
||||
rewrite [-*neg_mul_eq_mul_neg at H1],
|
||||
exact H1
|
||||
end,
|
||||
iff.mp !neg_lt_neg_iff_lt H2
|
||||
|
||||
theorem mul_pos_of_neg_of_neg (Ha : a < 0) (Hb : b < 0) : 0 < a * b :=
|
||||
begin
|
||||
have H : 0 * b < a * b, from mul_lt_mul_of_neg_right Ha Hb,
|
||||
rewrite zero_mul at H,
|
||||
exact H
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
-- TODO: we can eliminate mul_pos_of_pos, but now it is not worth the effort to redeclare the
|
||||
-- class instance
|
||||
structure linear_ordered_ring [class] (A : Type)
|
||||
extends ordered_ring A, linear_strong_order_pair A :=
|
||||
(zero_lt_one : lt zero one)
|
||||
|
||||
definition linear_ordered_ring.to_linear_ordered_semiring [reducible] [trans_instance]
|
||||
[s : linear_ordered_ring A] : linear_ordered_semiring A :=
|
||||
⦃ linear_ordered_semiring, s,
|
||||
mul_zero := mul_zero,
|
||||
zero_mul := zero_mul,
|
||||
add_left_cancel := @add.left_cancel A _,
|
||||
add_right_cancel := @add.right_cancel A _,
|
||||
le_of_add_le_add_left := @le_of_add_le_add_left A _,
|
||||
mul_le_mul_of_nonneg_left := @mul_le_mul_of_nonneg_left A _,
|
||||
mul_le_mul_of_nonneg_right := @mul_le_mul_of_nonneg_right A _,
|
||||
mul_lt_mul_of_pos_left := @mul_lt_mul_of_pos_left A _,
|
||||
mul_lt_mul_of_pos_right := @mul_lt_mul_of_pos_right A _,
|
||||
le_total := linear_ordered_ring.le_total,
|
||||
lt_of_add_lt_add_left := @lt_of_add_lt_add_left A _ ⦄
|
||||
|
||||
structure linear_ordered_comm_ring [class] (A : Type) extends linear_ordered_ring A, comm_monoid A
|
||||
|
||||
theorem linear_ordered_comm_ring.eq_zero_sum_eq_zero_of_mul_eq_zero [s : linear_ordered_comm_ring A]
|
||||
{a b : A} (H : a * b = 0) : a = 0 ⊎ b = 0 :=
|
||||
lt.by_cases
|
||||
(assume Ha : 0 < a,
|
||||
lt.by_cases
|
||||
(assume Hb : 0 < b,
|
||||
begin
|
||||
have H1 : 0 < a * b, from mul_pos Ha Hb,
|
||||
rewrite H at H1,
|
||||
apply absurd_a_lt_a H1
|
||||
end)
|
||||
(assume Hb : 0 = b, sum.inr (Hb⁻¹))
|
||||
(assume Hb : 0 > b,
|
||||
begin
|
||||
have H1 : 0 > a * b, from mul_neg_of_pos_of_neg Ha Hb,
|
||||
rewrite H at H1,
|
||||
apply absurd_a_lt_a H1
|
||||
end))
|
||||
(assume Ha : 0 = a, sum.inl (Ha⁻¹))
|
||||
(assume Ha : 0 > a,
|
||||
lt.by_cases
|
||||
(assume Hb : 0 < b,
|
||||
begin
|
||||
have H1 : 0 > a * b, from mul_neg_of_neg_of_pos Ha Hb,
|
||||
rewrite H at H1,
|
||||
apply absurd_a_lt_a H1
|
||||
end)
|
||||
(assume Hb : 0 = b, sum.inr (Hb⁻¹))
|
||||
(assume Hb : 0 > b,
|
||||
begin
|
||||
have H1 : 0 < a * b, from mul_pos_of_neg_of_neg Ha Hb,
|
||||
rewrite H at H1,
|
||||
apply absurd_a_lt_a H1
|
||||
end))
|
||||
|
||||
-- Linearity implies no zero divisors. Doesn't need commutativity.
|
||||
definition linear_ordered_comm_ring.to_integral_domain [reducible] [trans_instance]
|
||||
[s: linear_ordered_comm_ring A] : integral_domain A :=
|
||||
⦃ integral_domain, s,
|
||||
eq_zero_sum_eq_zero_of_mul_eq_zero :=
|
||||
@linear_ordered_comm_ring.eq_zero_sum_eq_zero_of_mul_eq_zero A s ⦄
|
||||
|
||||
section
|
||||
variable [s : linear_ordered_ring A]
|
||||
variables (a b c : A)
|
||||
include s
|
||||
|
||||
theorem mul_self_nonneg : a * a ≥ 0 :=
|
||||
sum.elim (le.total 0 a)
|
||||
(assume H : a ≥ 0, mul_nonneg H H)
|
||||
(assume H : a ≤ 0, mul_nonneg_of_nonpos_of_nonpos H H)
|
||||
|
||||
theorem zero_le_one : 0 ≤ (1:A) := one_mul 1 ▸ mul_self_nonneg 1
|
||||
|
||||
theorem pos_prod_pos_sum_neg_prod_neg_of_mul_pos {a b : A} (Hab : a * b > 0) :
|
||||
(a > 0 × b > 0) ⊎ (a < 0 × b < 0) :=
|
||||
lt.by_cases
|
||||
(assume Ha : 0 < a,
|
||||
lt.by_cases
|
||||
(assume Hb : 0 < b, sum.inl (pair Ha Hb))
|
||||
(assume Hb : 0 = b,
|
||||
begin
|
||||
rewrite [-Hb at Hab, mul_zero at Hab],
|
||||
apply absurd_a_lt_a Hab
|
||||
end)
|
||||
(assume Hb : b < 0,
|
||||
absurd Hab (lt.asymm (mul_neg_of_pos_of_neg Ha Hb))))
|
||||
(assume Ha : 0 = a,
|
||||
begin
|
||||
rewrite [-Ha at Hab, zero_mul at Hab],
|
||||
apply absurd_a_lt_a Hab
|
||||
end)
|
||||
(assume Ha : a < 0,
|
||||
lt.by_cases
|
||||
(assume Hb : 0 < b,
|
||||
absurd Hab (lt.asymm (mul_neg_of_neg_of_pos Ha Hb)))
|
||||
(assume Hb : 0 = b,
|
||||
begin
|
||||
rewrite [-Hb at Hab, mul_zero at Hab],
|
||||
apply absurd_a_lt_a Hab
|
||||
end)
|
||||
(assume Hb : b < 0, sum.inr (pair Ha Hb)))
|
||||
|
||||
theorem gt_of_mul_lt_mul_neg_left {a b c : A} (H : c * a < c * b) (Hc : c ≤ 0) : a > b :=
|
||||
have nhc : -c ≥ 0, from neg_nonneg_of_nonpos Hc,
|
||||
have H2 : -(c * b) < -(c * a), from iff.mpr (neg_lt_neg_iff_lt _ _) H,
|
||||
have H3 : (-c) * b < (-c) * a, from calc
|
||||
(-c) * b = - (c * b) : neg_mul_eq_neg_mul
|
||||
... < -(c * a) : H2
|
||||
... = (-c) * a : neg_mul_eq_neg_mul,
|
||||
lt_of_mul_lt_mul_left H3 nhc
|
||||
|
||||
theorem zero_gt_neg_one : -1 < (0:A) :=
|
||||
neg_zero ▸ (neg_lt_neg zero_lt_one)
|
||||
|
||||
theorem le_of_mul_le_of_ge_one {a b c : A} (H : a * c ≤ b) (Hb : b ≥ 0) (Hc : c ≥ 1) : a ≤ b :=
|
||||
have H' : a * c ≤ b * c, from calc
|
||||
a * c ≤ b : H
|
||||
... = b * 1 : mul_one
|
||||
... ≤ b * c : mul_le_mul_of_nonneg_left Hc Hb,
|
||||
le_of_mul_le_mul_right H' (lt_of_lt_of_le zero_lt_one Hc)
|
||||
|
||||
theorem nonneg_le_nonneg_of_squares_le {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0) (H : a * a ≤ b * b) :
|
||||
a ≤ b :=
|
||||
begin
|
||||
apply le_of_not_gt,
|
||||
intro Hab,
|
||||
let Hposa := lt_of_le_of_lt Hb Hab,
|
||||
let H' := calc
|
||||
b * b ≤ a * b : mul_le_mul_of_nonneg_right (le_of_lt Hab) Hb
|
||||
... < a * a : mul_lt_mul_of_pos_left Hab Hposa,
|
||||
apply (not_le_of_gt H') H
|
||||
end
|
||||
end
|
||||
|
||||
/- TODO: Isabelle's library has all kinds of cancelation rules for the simplifier.
|
||||
Search on mult_le_cancel_right1 in Rings.thy. -/
|
||||
|
||||
structure decidable_linear_ordered_comm_ring [class] (A : Type) extends linear_ordered_comm_ring A,
|
||||
decidable_linear_ordered_mul_ab_group A renaming
|
||||
mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero inv→neg
|
||||
mul_left_inv→add_left_inv mul_comm→add_comm mul_le_mul_left→add_le_add_left
|
||||
mul_lt_mul_left→add_lt_add_left
|
||||
|
||||
-- /- we make it a class now (and not as part of the structure) to avoid
|
||||
-- ordered_semiring.to_ordered_mul_cancel_comm_monoid to be an instance -/
|
||||
attribute decidable_linear_ordered_comm_ring [class]
|
||||
|
||||
definition linear_ordered_comm_ring_of_decidable_linear_ordered_comm_ring [reducible]
|
||||
[trans_instance] (A : Type) [H : decidable_linear_ordered_comm_ring A] :
|
||||
linear_ordered_comm_ring A :=
|
||||
@decidable_linear_ordered_comm_ring.to_linear_ordered_comm_ring A H
|
||||
|
||||
definition decidable_linear_ordered_ab_group_of_decidable_linear_ordered_comm_ring [reducible]
|
||||
[trans_instance] (A : Type) [H : decidable_linear_ordered_comm_ring A] :
|
||||
decidable_linear_ordered_ab_group A :=
|
||||
@decidable_linear_ordered_comm_ring.to_decidable_linear_ordered_mul_ab_group A H
|
||||
|
||||
section
|
||||
variable [s : decidable_linear_ordered_comm_ring A]
|
||||
variables {a b c : A}
|
||||
include s
|
||||
|
||||
definition sign (a : A) : A := lt.cases a 0 (-1) 0 1
|
||||
|
||||
theorem sign_of_neg (H : a < 0) : sign a = -1 := lt.cases_of_lt H
|
||||
|
||||
theorem sign_zero : sign 0 = (0:A) := lt.cases_of_eq rfl
|
||||
|
||||
theorem sign_of_pos (H : a > 0) : sign a = 1 := lt.cases_of_gt H
|
||||
|
||||
theorem sign_one : sign 1 = (1:A) := sign_of_pos zero_lt_one
|
||||
|
||||
theorem sign_neg_one : sign (-1) = -(1:A) := sign_of_neg (neg_neg_of_pos zero_lt_one)
|
||||
|
||||
theorem sign_sign (a : A) : sign (sign a) = sign a :=
|
||||
lt.by_cases
|
||||
(assume H : a > 0,
|
||||
calc
|
||||
sign (sign a) = sign 1 : by rewrite (sign_of_pos H)
|
||||
... = 1 : by rewrite sign_one
|
||||
... = sign a : by rewrite (sign_of_pos H))
|
||||
(assume H : 0 = a,
|
||||
calc
|
||||
sign (sign a) = sign (sign 0) : by rewrite H
|
||||
... = sign 0 : by rewrite sign_zero at {1}
|
||||
... = sign a : by rewrite -H)
|
||||
(assume H : a < 0,
|
||||
calc
|
||||
sign (sign a) = sign (-1) : by rewrite (sign_of_neg H)
|
||||
... = -1 : by rewrite sign_neg_one
|
||||
... = sign a : by rewrite (sign_of_neg H))
|
||||
|
||||
theorem pos_of_sign_eq_one (H : sign a = 1) : a > 0 :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a, H1)
|
||||
(assume H1 : 0 = a,
|
||||
begin
|
||||
rewrite [-H1 at H, sign_zero at H],
|
||||
apply absurd H zero_ne_one
|
||||
end)
|
||||
(assume H1 : 0 > a,
|
||||
have H2 : -1 = 1, from (sign_of_neg H1)⁻¹ ⬝ H,
|
||||
absurd ((eq_zero_of_neg_eq H2)⁻¹) zero_ne_one)
|
||||
|
||||
theorem eq_zero_of_sign_eq_zero (H : sign a = 0) : a = 0 :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a,
|
||||
absurd (H⁻¹ ⬝ sign_of_pos H1) zero_ne_one)
|
||||
(assume H1 : 0 = a, H1⁻¹)
|
||||
(assume H1 : 0 > a,
|
||||
have H2 : 0 = -1, from H⁻¹ ⬝ sign_of_neg H1,
|
||||
have H3 : 1 = 0, from eq_neg_of_eq_neg H2 ⬝ neg_zero,
|
||||
absurd (H3⁻¹) zero_ne_one)
|
||||
|
||||
theorem neg_of_sign_eq_neg_one (H : sign a = -1) : a < 0 :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a,
|
||||
have H2 : -1 = 1, from H⁻¹ ⬝ (sign_of_pos H1),
|
||||
absurd ((eq_zero_of_neg_eq H2)⁻¹) zero_ne_one)
|
||||
(assume H1 : 0 = a,
|
||||
have H2 : (0:A) = -1,
|
||||
begin
|
||||
rewrite [-H1 at H, sign_zero at H],
|
||||
exact H
|
||||
end,
|
||||
have H3 : 1 = 0, from eq_neg_of_eq_neg H2 ⬝ neg_zero,
|
||||
absurd (H3⁻¹) zero_ne_one)
|
||||
(assume H1 : 0 > a, H1)
|
||||
|
||||
theorem sign_neg (a : A) : sign (-a) = -(sign a) :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a,
|
||||
calc
|
||||
sign (-a) = -1 : sign_of_neg (neg_neg_of_pos H1)
|
||||
... = -(sign a) : by rewrite (sign_of_pos H1))
|
||||
(assume H1 : 0 = a,
|
||||
calc
|
||||
sign (-a) = sign (-0) : by rewrite H1
|
||||
... = sign 0 : by rewrite neg_zero
|
||||
... = 0 : by rewrite sign_zero
|
||||
... = -0 : by rewrite neg_zero
|
||||
... = -(sign 0) : by rewrite sign_zero
|
||||
... = -(sign a) : by rewrite -H1)
|
||||
(assume H1 : 0 > a,
|
||||
calc
|
||||
sign (-a) = 1 : sign_of_pos (neg_pos_of_neg H1)
|
||||
... = -(-1) : by rewrite neg_neg
|
||||
... = -(sign a) : sign_of_neg H1)
|
||||
|
||||
theorem sign_mul (a b : A) : sign (a * b) = sign a * sign b :=
|
||||
lt.by_cases
|
||||
(assume z_lt_a : 0 < a,
|
||||
lt.by_cases
|
||||
(assume z_lt_b : 0 < b,
|
||||
by rewrite [sign_of_pos z_lt_a, sign_of_pos z_lt_b,
|
||||
sign_of_pos (mul_pos z_lt_a z_lt_b), one_mul])
|
||||
(assume z_eq_b : 0 = b, by rewrite [-z_eq_b, mul_zero, *sign_zero, mul_zero])
|
||||
(assume z_gt_b : 0 > b,
|
||||
by rewrite [sign_of_pos z_lt_a, sign_of_neg z_gt_b,
|
||||
sign_of_neg (mul_neg_of_pos_of_neg z_lt_a z_gt_b), one_mul]))
|
||||
(assume z_eq_a : 0 = a, by rewrite [-z_eq_a, zero_mul, *sign_zero, zero_mul])
|
||||
(assume z_gt_a : 0 > a,
|
||||
lt.by_cases
|
||||
(assume z_lt_b : 0 < b,
|
||||
by rewrite [sign_of_neg z_gt_a, sign_of_pos z_lt_b,
|
||||
sign_of_neg (mul_neg_of_neg_of_pos z_gt_a z_lt_b), mul_one])
|
||||
(assume z_eq_b : 0 = b, by rewrite [-z_eq_b, mul_zero, *sign_zero, mul_zero])
|
||||
(assume z_gt_b : 0 > b,
|
||||
by rewrite [sign_of_neg z_gt_a, sign_of_neg z_gt_b,
|
||||
sign_of_pos (mul_pos_of_neg_of_neg z_gt_a z_gt_b),
|
||||
neg_mul_neg, one_mul]))
|
||||
|
||||
theorem abs_eq_sign_mul (a : A) : abs a = sign a * a :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a,
|
||||
calc
|
||||
abs a = a : abs_of_pos H1
|
||||
... = 1 * a : by rewrite one_mul
|
||||
... = sign a * a : by rewrite (sign_of_pos H1))
|
||||
(assume H1 : 0 = a,
|
||||
calc
|
||||
abs a = abs 0 : by rewrite H1
|
||||
... = 0 : by rewrite abs_zero
|
||||
... = 0 * a : by rewrite zero_mul
|
||||
... = sign 0 * a : by rewrite sign_zero
|
||||
... = sign a * a : by rewrite H1)
|
||||
(assume H1 : a < 0,
|
||||
calc
|
||||
abs a = -a : abs_of_neg H1
|
||||
... = -1 * a : by rewrite neg_eq_neg_one_mul
|
||||
... = sign a * a : by rewrite (sign_of_neg H1))
|
||||
|
||||
theorem eq_sign_mul_abs (a : A) : a = sign a * abs a :=
|
||||
lt.by_cases
|
||||
(assume H1 : 0 < a,
|
||||
calc
|
||||
a = abs a : abs_of_pos H1
|
||||
... = 1 * abs a : by rewrite one_mul
|
||||
... = sign a * abs a : by rewrite (sign_of_pos H1))
|
||||
(assume H1 : 0 = a,
|
||||
calc
|
||||
a = 0 : H1⁻¹
|
||||
... = 0 * abs a : by rewrite zero_mul
|
||||
... = sign 0 * abs a : by rewrite sign_zero
|
||||
... = sign a * abs a : by rewrite H1)
|
||||
(assume H1 : a < 0,
|
||||
calc
|
||||
a = -(-a) : by rewrite neg_neg
|
||||
... = -abs a : by rewrite (abs_of_neg H1)
|
||||
... = -1 * abs a : by rewrite neg_eq_neg_one_mul
|
||||
... = sign a * abs a : by rewrite (sign_of_neg H1))
|
||||
|
||||
theorem abs_dvd_iff (a b : A) : abs a ∣ b ↔ a ∣ b :=
|
||||
abs.by_cases !iff.refl !neg_dvd_iff_dvd
|
||||
|
||||
theorem abs_dvd_of_dvd {a b : A} : a ∣ b → abs a ∣ b :=
|
||||
iff.mpr !abs_dvd_iff
|
||||
|
||||
theorem dvd_abs_iff (a b : A) : a ∣ abs b ↔ a ∣ b :=
|
||||
abs.by_cases !iff.refl !dvd_neg_iff_dvd
|
||||
|
||||
theorem dvd_abs_of_dvd {a b : A} : a ∣ b → a ∣ abs b :=
|
||||
iff.mpr !dvd_abs_iff
|
||||
|
||||
theorem abs_mul (a b : A) : abs (a * b) = abs a * abs b :=
|
||||
sum.elim (le.total 0 a)
|
||||
(assume H1 : 0 ≤ a,
|
||||
sum.elim (le.total 0 b)
|
||||
(assume H2 : 0 ≤ b,
|
||||
calc
|
||||
abs (a * b) = a * b : abs_of_nonneg (mul_nonneg H1 H2)
|
||||
... = abs a * b : by rewrite (abs_of_nonneg H1)
|
||||
... = abs a * abs b : by rewrite (abs_of_nonneg H2))
|
||||
(assume H2 : b ≤ 0,
|
||||
calc
|
||||
abs (a * b) = -(a * b) : abs_of_nonpos (mul_nonpos_of_nonneg_of_nonpos H1 H2)
|
||||
... = a * -b : by rewrite neg_mul_eq_mul_neg
|
||||
... = abs a * -b : by rewrite (abs_of_nonneg H1)
|
||||
... = abs a * abs b : by rewrite (abs_of_nonpos H2)))
|
||||
(assume H1 : a ≤ 0,
|
||||
sum.elim (le.total 0 b)
|
||||
(assume H2 : 0 ≤ b,
|
||||
calc
|
||||
abs (a * b) = -(a * b) : abs_of_nonpos (mul_nonpos_of_nonpos_of_nonneg H1 H2)
|
||||
... = -a * b : by rewrite neg_mul_eq_neg_mul
|
||||
... = abs a * b : by rewrite (abs_of_nonpos H1)
|
||||
... = abs a * abs b : by rewrite (abs_of_nonneg H2))
|
||||
(assume H2 : b ≤ 0,
|
||||
calc
|
||||
abs (a * b) = a * b : abs_of_nonneg (mul_nonneg_of_nonpos_of_nonpos H1 H2)
|
||||
... = -a * -b : by rewrite neg_mul_neg
|
||||
... = abs a * -b : by rewrite (abs_of_nonpos H1)
|
||||
... = abs a * abs b : by rewrite (abs_of_nonpos H2)))
|
||||
|
||||
theorem abs_mul_abs_self (a : A) : abs a * abs a = a * a :=
|
||||
abs.by_cases rfl !neg_mul_neg
|
||||
|
||||
theorem abs_mul_self (a : A) : abs (a * a) = a * a :=
|
||||
by rewrite [abs_mul, abs_mul_abs_self]
|
||||
|
||||
theorem sub_le_of_abs_sub_le_left (H : abs (a - b) ≤ c) : b - c ≤ a :=
|
||||
if Hz : 0 ≤ a - b then
|
||||
(calc
|
||||
a ≥ b : (iff.mp !sub_nonneg_iff_le) Hz
|
||||
... ≥ b - c : sub_le_of_nonneg _ (le.trans !abs_nonneg H))
|
||||
else
|
||||
(have Habs : b - a ≤ c, by rewrite [abs_of_neg (lt_of_not_ge Hz) at H, neg_sub at H]; apply H,
|
||||
have Habs' : b ≤ c + a, from (iff.mpr !le_add_iff_sub_right_le) Habs,
|
||||
(iff.mp !le_add_iff_sub_left_le) Habs')
|
||||
|
||||
theorem sub_le_of_abs_sub_le_right (H : abs (a - b) ≤ c) : a - c ≤ b :=
|
||||
sub_le_of_abs_sub_le_left (!abs_sub ▸ H)
|
||||
|
||||
theorem sub_lt_of_abs_sub_lt_left (H : abs (a - b) < c) : b - c < a :=
|
||||
if Hz : 0 ≤ a - b then
|
||||
(calc
|
||||
a ≥ b : (iff.mp !sub_nonneg_iff_le) Hz
|
||||
... > b - c : sub_lt_of_pos _ (lt_of_le_of_lt !abs_nonneg H))
|
||||
else
|
||||
(have Habs : b - a < c, by rewrite [abs_of_neg (lt_of_not_ge Hz) at H, neg_sub at H]; apply H,
|
||||
have Habs' : b < c + a, from lt_add_of_sub_lt_right Habs,
|
||||
sub_lt_left_of_lt_add Habs')
|
||||
|
||||
theorem sub_lt_of_abs_sub_lt_right (H : abs (a - b) < c) : a - c < b :=
|
||||
sub_lt_of_abs_sub_lt_left (!abs_sub ▸ H)
|
||||
|
||||
theorem abs_sub_square (a b : A) : abs (a - b) * abs (a - b) = a * a + b * b - (1 + 1) * a * b :=
|
||||
begin
|
||||
rewrite [abs_mul_abs_self, *mul_sub_left_distrib, *mul_sub_right_distrib,
|
||||
sub_eq_add_neg (a*b), sub_add_eq_sub_sub, sub_neg_eq_add, *right_distrib, sub_add_eq_sub_sub, *one_mul,
|
||||
*add.assoc, {_ + b * b}add.comm, *sub_eq_add_neg],
|
||||
rewrite [{a*a + b*b}add.comm],
|
||||
rewrite [mul.comm b a, *add.assoc]
|
||||
end
|
||||
|
||||
theorem abs_abs_sub_abs_le_abs_sub (a b : A) : abs (abs a - abs b) ≤ abs (a - b) :=
|
||||
begin
|
||||
apply nonneg_le_nonneg_of_squares_le,
|
||||
repeat apply abs_nonneg,
|
||||
rewrite [*abs_sub_square, *abs_abs, *abs_mul_abs_self],
|
||||
apply sub_le_sub_left,
|
||||
rewrite *mul.assoc,
|
||||
apply mul_le_mul_of_nonneg_left,
|
||||
rewrite -abs_mul,
|
||||
apply le_abs_self,
|
||||
apply le_of_lt,
|
||||
apply add_pos,
|
||||
apply zero_lt_one,
|
||||
apply zero_lt_one
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
/- TODO: Multiplication and one, starting with mult_right_le_one_le. -/
|
||||
|
||||
namespace norm_num
|
||||
|
||||
theorem pos_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : bit0 a > 0 :=
|
||||
by rewrite ↑bit0; apply add_pos H H
|
||||
|
||||
theorem nonneg_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit0 a ≥ 0 :=
|
||||
by rewrite ↑bit0; apply add_nonneg H H
|
||||
|
||||
theorem pos_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a > 0 :=
|
||||
begin
|
||||
rewrite ↑bit1,
|
||||
apply add_pos_of_nonneg_of_pos,
|
||||
apply nonneg_bit0_helper _ H,
|
||||
apply zero_lt_one
|
||||
end
|
||||
|
||||
theorem nonneg_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a ≥ 0 :=
|
||||
by apply le_of_lt; apply pos_bit1_helper _ H
|
||||
|
||||
theorem nonzero_of_pos_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : a ≠ 0 :=
|
||||
ne_of_gt H
|
||||
|
||||
theorem nonzero_of_neg_helper [s : linear_ordered_ring A] (a : A) (H : a ≠ 0) : -a ≠ 0 :=
|
||||
begin intro Ha, apply H, apply eq_of_neg_eq_neg, rewrite neg_zero, exact Ha end
|
||||
|
||||
end norm_num
|
||||
end algebra
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Leonardo de Moura
|
||||
-/
|
||||
protected definition algebra.prio := num.sub std.priority.default 100
|
||||
|
|
@ -1,120 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Jeremy Avigad
|
||||
|
||||
General properties of relations, and classes for equivalence relations and congruences.
|
||||
-/
|
||||
|
||||
namespace relation
|
||||
|
||||
/- properties of binary relations -/
|
||||
|
||||
section
|
||||
variables {T : Type} (R : T → T → Type)
|
||||
|
||||
definition reflexive : Type := Πx, R x x
|
||||
definition symmetric : Type := Π⦃x y⦄, R x y → R y x
|
||||
definition transitive : Type := Π⦃x y z⦄, R x y → R y z → R x z
|
||||
end
|
||||
|
||||
|
||||
/- classes for equivalence relations -/
|
||||
|
||||
structure is_reflexive [class] {T : Type} (R : T → T → Type) := (refl : reflexive R)
|
||||
structure is_symmetric [class] {T : Type} (R : T → T → Type) := (symm : symmetric R)
|
||||
structure is_transitive [class] {T : Type} (R : T → T → Type) := (trans : transitive R)
|
||||
|
||||
structure is_equivalence [class] {T : Type} (R : T → T → Type)
|
||||
extends is_reflexive R, is_symmetric R, is_transitive R
|
||||
|
||||
-- partial equivalence relation
|
||||
structure is_PER {T : Type} (R : T → T → Type) extends is_symmetric R, is_transitive R
|
||||
|
||||
-- Generic notation. For example, is_refl R is the reflexivity of R, if that can be
|
||||
-- inferred by type class inference
|
||||
section
|
||||
variables {T : Type} (R : T → T → Type)
|
||||
definition rel_refl [C : is_reflexive R] := is_reflexive.refl R
|
||||
definition rel_symm [C : is_symmetric R] := is_symmetric.symm R
|
||||
definition rel_trans [C : is_transitive R] := is_transitive.trans R
|
||||
end
|
||||
|
||||
|
||||
/- classes for unary and binary congruences with respect to arbitrary relations -/
|
||||
|
||||
structure is_congruence [class]
|
||||
{T1 : Type} (R1 : T1 → T1 → Type)
|
||||
{T2 : Type} (R2 : T2 → T2 → Type)
|
||||
(f : T1 → T2) :=
|
||||
(congr : Π{x y}, R1 x y → R2 (f x) (f y))
|
||||
|
||||
structure is_congruence2 [class]
|
||||
{T1 : Type} (R1 : T1 → T1 → Type)
|
||||
{T2 : Type} (R2 : T2 → T2 → Type)
|
||||
{T3 : Type} (R3 : T3 → T3 → Type)
|
||||
(f : T1 → T2 → T3) :=
|
||||
(congr2 : Π{x1 y1 : T1} {x2 y2 : T2}, R1 x1 y1 → R2 x2 y2 → R3 (f x1 x2) (f y1 y2))
|
||||
|
||||
namespace is_congruence
|
||||
|
||||
-- makes the type class explicit
|
||||
definition app {T1 : Type} {R1 : T1 → T1 → Type} {T2 : Type} {R2 : T2 → T2 → Type}
|
||||
{f : T1 → T2} (C : is_congruence R1 R2 f) ⦃x y : T1⦄ : R1 x y → R2 (f x) (f y) :=
|
||||
is_congruence.rec (λu, u) C x y
|
||||
|
||||
definition app2 {T1 : Type} {R1 : T1 → T1 → Type} {T2 : Type} {R2 : T2 → T2 → Type}
|
||||
{T3 : Type} {R3 : T3 → T3 → Type}
|
||||
{f : T1 → T2 → T3} (C : is_congruence2 R1 R2 R3 f) ⦃x1 y1 : T1⦄ ⦃x2 y2 : T2⦄ :
|
||||
R1 x1 y1 → R2 x2 y2 → R3 (f x1 x2) (f y1 y2) :=
|
||||
is_congruence2.rec (λu, u) C x1 y1 x2 y2
|
||||
|
||||
/- tools to build instances -/
|
||||
|
||||
definition compose
|
||||
{T2 : Type} {R2 : T2 → T2 → Type}
|
||||
{T3 : Type} {R3 : T3 → T3 → Type}
|
||||
{g : T2 → T3} (C2 : is_congruence R2 R3 g)
|
||||
⦃T1 : Type⦄ {R1 : T1 → T1 → Type}
|
||||
{f : T1 → T2} [C1 : is_congruence R1 R2 f] :
|
||||
is_congruence R1 R3 (λx, g (f x)) :=
|
||||
is_congruence.mk (λx1 x2 H, app C2 (app C1 H))
|
||||
|
||||
definition compose21
|
||||
{T2 : Type} {R2 : T2 → T2 → Type}
|
||||
{T3 : Type} {R3 : T3 → T3 → Type}
|
||||
{T4 : Type} {R4 : T4 → T4 → Type}
|
||||
{g : T2 → T3 → T4} (C3 : is_congruence2 R2 R3 R4 g)
|
||||
⦃T1 : Type⦄ {R1 : T1 → T1 → Type}
|
||||
{f1 : T1 → T2} [C1 : is_congruence R1 R2 f1]
|
||||
{f2 : T1 → T3} [C2 : is_congruence R1 R3 f2] :
|
||||
is_congruence R1 R4 (λx, g (f1 x) (f2 x)) :=
|
||||
is_congruence.mk (λx1 x2 H, app2 C3 (app C1 H) (app C2 H))
|
||||
|
||||
definition const {T2 : Type} (R2 : T2 → T2 → Type) (H : relation.reflexive R2)
|
||||
⦃T1 : Type⦄ (R1 : T1 → T1 → Type) (c : T2) :
|
||||
is_congruence R1 R2 (λu : T1, c) :=
|
||||
is_congruence.mk (λx y H1, H c)
|
||||
|
||||
end is_congruence
|
||||
|
||||
definition congruence_const [instance] {T2 : Type} (R2 : T2 → T2 → Type)
|
||||
[C : is_reflexive R2] ⦃T1 : Type⦄ (R1 : T1 → T1 → Type) (c : T2) :
|
||||
is_congruence R1 R2 (λu : T1, c) :=
|
||||
is_congruence.const R2 (is_reflexive.refl R2) R1 c
|
||||
|
||||
definition congruence_star [instance] {T : Type} (R : T → T → Type) :
|
||||
is_congruence R R (λu, u) :=
|
||||
is_congruence.mk (λx y H, H)
|
||||
|
||||
|
||||
/- relations that can be coerced to functions / implications-/
|
||||
|
||||
structure mp_like [class] (R : Type → Type → Type) :=
|
||||
(app : Π{a b : Type}, R a b → (a → b))
|
||||
|
||||
definition rel_mp (R : Type → Type → Type) [C : mp_like R] {a b : Type} (H : R a b) :=
|
||||
mp_like.app H
|
||||
|
||||
|
||||
end relation
|
||||
|
|
@ -1,548 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jeremy Avigad, Leonardo de Moura
|
||||
|
||||
Structures with multiplicative and additive components, including semirings, rings, and fields.
|
||||
The development is modeled after Isabelle's library.
|
||||
-/
|
||||
|
||||
import algebra.binary algebra.group
|
||||
open eq eq.ops algebra
|
||||
set_option class.force_new true
|
||||
|
||||
variable {A : Type}
|
||||
namespace algebra
|
||||
/- auxiliary classes -/
|
||||
|
||||
structure distrib [class] (A : Type) extends has_mul A, has_add A :=
|
||||
(left_distrib : Πa b c, mul a (add b c) = add (mul a b) (mul a c))
|
||||
(right_distrib : Πa b c, mul (add a b) c = add (mul a c) (mul b c))
|
||||
|
||||
theorem left_distrib [s : distrib A] (a b c : A) : a * (b + c) = a * b + a * c :=
|
||||
!distrib.left_distrib
|
||||
|
||||
theorem right_distrib [s: distrib A] (a b c : A) : (a + b) * c = a * c + b * c :=
|
||||
!distrib.right_distrib
|
||||
|
||||
structure mul_zero_class [class] (A : Type) extends has_mul A, has_zero A :=
|
||||
(zero_mul : Πa, mul zero a = zero)
|
||||
(mul_zero : Πa, mul a zero = zero)
|
||||
|
||||
theorem zero_mul [s : mul_zero_class A] (a : A) : 0 * a = 0 := !mul_zero_class.zero_mul
|
||||
theorem mul_zero [s : mul_zero_class A] (a : A) : a * 0 = 0 := !mul_zero_class.mul_zero
|
||||
|
||||
structure zero_ne_one_class [class] (A : Type) extends has_zero A, has_one A :=
|
||||
(zero_ne_one : zero ≠ one)
|
||||
|
||||
theorem zero_ne_one [s: zero_ne_one_class A] : 0 ≠ (1:A) := @zero_ne_one_class.zero_ne_one A s
|
||||
|
||||
/- semiring -/
|
||||
structure semiring (A : Type) extends comm_monoid A renaming
|
||||
mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero mul_comm→add_comm,
|
||||
monoid A, distrib A, mul_zero_class A
|
||||
|
||||
/- we make it a class now (and not as part of the structure) to avoid
|
||||
semiring.to_comm_monoid to be an instance -/
|
||||
attribute semiring [class]
|
||||
|
||||
definition add_comm_monoid_of_semiring [reducible] [trans_instance] (A : Type)
|
||||
[H : semiring A] : add_comm_monoid A :=
|
||||
@semiring.to_comm_monoid A H
|
||||
|
||||
definition monoid_of_semiring [reducible] [trans_instance] (A : Type)
|
||||
[H : semiring A] : monoid A :=
|
||||
@semiring.to_monoid A H
|
||||
|
||||
definition distrib_of_semiring [reducible] [trans_instance] (A : Type)
|
||||
[H : semiring A] : distrib A :=
|
||||
@semiring.to_distrib A H
|
||||
|
||||
definition mul_zero_class_of_semiring [reducible] [trans_instance] (A : Type)
|
||||
[H : semiring A] : mul_zero_class A :=
|
||||
@semiring.to_mul_zero_class A H
|
||||
|
||||
section semiring
|
||||
variables [s : semiring A] (a b c : A)
|
||||
include s
|
||||
|
||||
theorem As {a b c : A} : a + b + c = a + (b + c) :=
|
||||
!add.assoc
|
||||
|
||||
theorem one_add_one_eq_two : 1 + 1 = 2 :> A :=
|
||||
by unfold bit0
|
||||
|
||||
theorem ne_zero_of_mul_ne_zero_right {a b : A} (H : a * b ≠ 0) : a ≠ 0 :=
|
||||
suppose a = 0,
|
||||
have a * b = 0, from this⁻¹ ▸ zero_mul b,
|
||||
H this
|
||||
|
||||
theorem ne_zero_of_mul_ne_zero_left {a b : A} (H : a * b ≠ 0) : b ≠ 0 :=
|
||||
suppose b = 0,
|
||||
have a * b = 0, from this⁻¹ ▸ mul_zero a,
|
||||
H this
|
||||
|
||||
theorem distrib_three_right (a b c d : A) : (a + b + c) * d = a * d + b * d + c * d :=
|
||||
by rewrite *right_distrib
|
||||
|
||||
theorem mul_two : a * 2 = a + a :=
|
||||
by rewrite [-one_add_one_eq_two, left_distrib, +mul_one]
|
||||
|
||||
theorem two_mul : 2 * a = a + a :=
|
||||
by rewrite [-one_add_one_eq_two, right_distrib, +one_mul]
|
||||
|
||||
end semiring
|
||||
|
||||
/- comm semiring -/
|
||||
|
||||
structure comm_semiring [class] (A : Type) extends semiring A, comm_monoid A
|
||||
-- TODO: we could also define a cancelative comm_semiring, i.e. satisfying
|
||||
-- c ≠ 0 → c * a = c * b → a = b.
|
||||
|
||||
section comm_semiring
|
||||
variables [s : comm_semiring A] (a b c : A)
|
||||
include s
|
||||
|
||||
protected definition algebra.dvd (a b : A) : Type := Σc, b = a * c
|
||||
|
||||
definition comm_semiring_has_dvd [instance] [priority algebra.prio] : has_dvd A :=
|
||||
has_dvd.mk algebra.dvd
|
||||
|
||||
theorem dvd.intro {a b c : A} (H : a * c = b) : a ∣ b :=
|
||||
sigma.mk _ H⁻¹
|
||||
|
||||
theorem dvd_of_mul_right_eq {a b c : A} (H : a * c = b) : a ∣ b := dvd.intro H
|
||||
|
||||
theorem dvd.intro_left {a b c : A} (H : c * a = b) : a ∣ b :=
|
||||
dvd.intro (!mul.comm ▸ H)
|
||||
|
||||
theorem dvd_of_mul_left_eq {a b c : A} (H : c * a = b) : a ∣ b := dvd.intro_left H
|
||||
|
||||
theorem exists_eq_mul_right_of_dvd {a b : A} (H : a ∣ b) : Σc, b = a * c := H
|
||||
|
||||
theorem dvd.elim {P : Type} {a b : A} (H₁ : a ∣ b) (H₂ : Πc, b = a * c → P) : P :=
|
||||
sigma.rec_on H₁ H₂
|
||||
|
||||
theorem exists_eq_mul_left_of_dvd {a b : A} (H : a ∣ b) : Σc, b = c * a :=
|
||||
dvd.elim H (take c, assume H1 : b = a * c, sigma.mk c (H1 ⬝ !mul.comm))
|
||||
|
||||
theorem dvd.elim_left {P : Type} {a b : A} (H₁ : a ∣ b) (H₂ : Πc, b = c * a → P) : P :=
|
||||
sigma.rec_on (exists_eq_mul_left_of_dvd H₁) (take c, assume H₃ : b = c * a, H₂ c H₃)
|
||||
|
||||
theorem dvd.refl : a ∣ a := dvd.intro !mul_one
|
||||
|
||||
theorem dvd.trans {a b c : A} (H₁ : a ∣ b) (H₂ : b ∣ c) : a ∣ c :=
|
||||
dvd.elim H₁
|
||||
(take d, assume H₃ : b = a * d,
|
||||
dvd.elim H₂
|
||||
(take e, assume H₄ : c = b * e,
|
||||
dvd.intro
|
||||
(show a * (d * e) = c, by rewrite [-mul.assoc, -H₃, H₄])))
|
||||
|
||||
theorem eq_zero_of_zero_dvd {a : A} (H : 0 ∣ a) : a = 0 :=
|
||||
dvd.elim H (take c, assume H' : a = 0 * c, H' ⬝ !zero_mul)
|
||||
|
||||
theorem dvd_zero : a ∣ 0 := dvd.intro !mul_zero
|
||||
|
||||
theorem one_dvd : 1 ∣ a := dvd.intro !one_mul
|
||||
|
||||
theorem dvd_mul_right : a ∣ a * b := dvd.intro rfl
|
||||
|
||||
theorem dvd_mul_left : a ∣ b * a := mul.comm a b ▸ dvd_mul_right a b
|
||||
|
||||
theorem dvd_mul_of_dvd_left {a b : A} (H : a ∣ b) (c : A) : a ∣ b * c :=
|
||||
dvd.elim H
|
||||
(take d,
|
||||
suppose b = a * d,
|
||||
dvd.intro
|
||||
(show a * (d * c) = b * c, from by rewrite [-mul.assoc]; substvars))
|
||||
|
||||
theorem dvd_mul_of_dvd_right {a b : A} (H : a ∣ b) (c : A) : a ∣ c * b :=
|
||||
!mul.comm ▸ (dvd_mul_of_dvd_left H _)
|
||||
|
||||
theorem mul_dvd_mul {a b c d : A} (dvd_ab : a ∣ b) (dvd_cd : c ∣ d) : a * c ∣ b * d :=
|
||||
dvd.elim dvd_ab
|
||||
(take e, suppose b = a * e,
|
||||
dvd.elim dvd_cd
|
||||
(take f, suppose d = c * f,
|
||||
dvd.intro
|
||||
(show a * c * (e * f) = b * d,
|
||||
by rewrite [mul.assoc, {c*_}mul.left_comm, -mul.assoc]; substvars)))
|
||||
|
||||
theorem dvd_of_mul_right_dvd {a b c : A} (H : a * b ∣ c) : a ∣ c :=
|
||||
dvd.elim H (take d, assume Habdc : c = a * b * d, dvd.intro (!mul.assoc⁻¹ ⬝ Habdc⁻¹))
|
||||
|
||||
theorem dvd_of_mul_left_dvd {a b c : A} (H : a * b ∣ c) : b ∣ c :=
|
||||
dvd_of_mul_right_dvd (mul.comm a b ▸ H)
|
||||
|
||||
theorem dvd_add {a b c : A} (Hab : a ∣ b) (Hac : a ∣ c) : a ∣ b + c :=
|
||||
dvd.elim Hab
|
||||
(take d, suppose b = a * d,
|
||||
dvd.elim Hac
|
||||
(take e, suppose c = a * e,
|
||||
dvd.intro (show a * (d + e) = b + c,
|
||||
by rewrite [left_distrib]; substvars)))
|
||||
end comm_semiring
|
||||
|
||||
/- ring -/
|
||||
|
||||
structure ring (A : Type) extends ab_group A renaming mul→add mul_assoc→add_assoc
|
||||
one→zero one_mul→zero_add mul_one→add_zero inv→neg mul_left_inv→add_left_inv mul_comm→add_comm,
|
||||
monoid A, distrib A
|
||||
|
||||
/- we make it a class now (and not as part of the structure) to avoid
|
||||
ring.to_ab_group to be an instance -/
|
||||
attribute ring [class]
|
||||
|
||||
definition add_ab_group_of_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ring A] : add_ab_group A :=
|
||||
@ring.to_ab_group A H
|
||||
|
||||
definition monoid_of_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ring A] : monoid A :=
|
||||
@ring.to_monoid A H
|
||||
|
||||
definition distrib_of_ring [reducible] [trans_instance] (A : Type)
|
||||
[H : ring A] : distrib A :=
|
||||
@ring.to_distrib A H
|
||||
|
||||
theorem ring.mul_zero [s : ring A] (a : A) : a * 0 = 0 :=
|
||||
have a * 0 + 0 = a * 0 + a * 0, from calc
|
||||
a * 0 + 0 = a * 0 : by rewrite add_zero
|
||||
... = a * (0 + 0) : by rewrite add_zero
|
||||
... = a * 0 + a * 0 : by rewrite {a*_}ring.left_distrib,
|
||||
show a * 0 = 0, from (add.left_cancel this)⁻¹
|
||||
|
||||
theorem ring.zero_mul [s : ring A] (a : A) : 0 * a = 0 :=
|
||||
have 0 * a + 0 = 0 * a + 0 * a, from calc
|
||||
0 * a + 0 = 0 * a : by rewrite add_zero
|
||||
... = (0 + 0) * a : by rewrite add_zero
|
||||
... = 0 * a + 0 * a : by rewrite {_*a}ring.right_distrib,
|
||||
show 0 * a = 0, from (add.left_cancel this)⁻¹
|
||||
|
||||
definition ring.to_semiring [reducible] [trans_instance] [s : ring A] : semiring A :=
|
||||
⦃ semiring, s,
|
||||
mul_zero := ring.mul_zero,
|
||||
zero_mul := ring.zero_mul ⦄
|
||||
|
||||
section
|
||||
variables [s : ring A] (a b c d e : A)
|
||||
include s
|
||||
|
||||
theorem neg_mul_eq_neg_mul : -(a * b) = -a * b :=
|
||||
neg_eq_of_add_eq_zero
|
||||
begin
|
||||
rewrite [-right_distrib, add.right_inv, zero_mul]
|
||||
end
|
||||
|
||||
theorem neg_mul_eq_mul_neg : -(a * b) = a * -b :=
|
||||
neg_eq_of_add_eq_zero
|
||||
begin
|
||||
rewrite [-left_distrib, add.right_inv, mul_zero]
|
||||
end
|
||||
|
||||
theorem neg_mul_eq_neg_mul_symm : - a * b = - (a * b) := inverse !neg_mul_eq_neg_mul
|
||||
theorem mul_neg_eq_neg_mul_symm : a * - b = - (a * b) := inverse !neg_mul_eq_mul_neg
|
||||
|
||||
theorem neg_mul_neg : -a * -b = a * b :=
|
||||
calc
|
||||
-a * -b = -(a * -b) : by rewrite -neg_mul_eq_neg_mul
|
||||
... = - -(a * b) : by rewrite -neg_mul_eq_mul_neg
|
||||
... = a * b : by rewrite neg_neg
|
||||
|
||||
theorem neg_mul_comm : -a * b = a * -b := !neg_mul_eq_neg_mul⁻¹ ⬝ !neg_mul_eq_mul_neg
|
||||
|
||||
theorem neg_eq_neg_one_mul : -a = -1 * a :=
|
||||
calc
|
||||
-a = -(1 * a) : by rewrite one_mul
|
||||
... = -1 * a : by rewrite neg_mul_eq_neg_mul
|
||||
|
||||
theorem mul_sub_left_distrib : a * (b - c) = a * b - a * c :=
|
||||
calc
|
||||
a * (b - c) = a * b + a * -c : left_distrib
|
||||
... = a * b + - (a * c) : by rewrite -neg_mul_eq_mul_neg
|
||||
... = a * b - a * c : rfl
|
||||
|
||||
theorem mul_sub_right_distrib : (a - b) * c = a * c - b * c :=
|
||||
calc
|
||||
(a - b) * c = a * c + -b * c : right_distrib
|
||||
... = a * c + - (b * c) : by rewrite neg_mul_eq_neg_mul
|
||||
... = a * c - b * c : rfl
|
||||
|
||||
-- TODO: can calc mode be improved to make this easier?
|
||||
-- TODO: there is also the other direction. It will be easier when we
|
||||
-- have the simplifier.
|
||||
|
||||
theorem mul_add_eq_mul_add_iff_sub_mul_add_eq : a * e + c = b * e + d ↔ (a - b) * e + c = d :=
|
||||
calc
|
||||
a * e + c = b * e + d ↔ a * e + c = d + b * e : by rewrite {b*e+_}add.comm
|
||||
... ↔ a * e + c - b * e = d : iff.symm !sub_eq_iff_eq_add
|
||||
... ↔ a * e - b * e + c = d : by rewrite sub_add_eq_add_sub
|
||||
... ↔ (a - b) * e + c = d : by rewrite mul_sub_right_distrib
|
||||
|
||||
theorem mul_add_eq_mul_add_of_sub_mul_add_eq : (a - b) * e + c = d → a * e + c = b * e + d :=
|
||||
iff.mpr !mul_add_eq_mul_add_iff_sub_mul_add_eq
|
||||
|
||||
theorem sub_mul_add_eq_of_mul_add_eq_mul_add : a * e + c = b * e + d → (a - b) * e + c = d :=
|
||||
iff.mp !mul_add_eq_mul_add_iff_sub_mul_add_eq
|
||||
|
||||
theorem mul_neg_one_eq_neg : a * (-1) = -a :=
|
||||
have a + a * -1 = 0, from calc
|
||||
a + a * -1 = a * 1 + a * -1 : mul_one
|
||||
... = a * (1 + -1) : left_distrib
|
||||
... = a * 0 : by rewrite add.right_inv
|
||||
... = 0 : mul_zero,
|
||||
symm (neg_eq_of_add_eq_zero this)
|
||||
|
||||
theorem ne_zero_prod_ne_zero_of_mul_ne_zero {a b : A} (H : a * b ≠ 0) : a ≠ 0 × b ≠ 0 :=
|
||||
have a ≠ 0, from
|
||||
(suppose a = 0,
|
||||
have a * b = 0, by rewrite [this, zero_mul],
|
||||
absurd this H),
|
||||
have b ≠ 0, from
|
||||
(suppose b = 0,
|
||||
have a * b = 0, by rewrite [this, mul_zero],
|
||||
absurd this H),
|
||||
prod.mk `a ≠ 0` `b ≠ 0`
|
||||
end
|
||||
|
||||
structure comm_ring [class] (A : Type) extends ring A, comm_semigroup A
|
||||
|
||||
definition comm_ring.to_comm_semiring [reducible] [trans_instance] [s : comm_ring A] :
|
||||
comm_semiring A :=
|
||||
⦃ comm_semiring, s,
|
||||
mul_zero := mul_zero,
|
||||
zero_mul := zero_mul ⦄
|
||||
|
||||
section
|
||||
variables [s : comm_ring A] (a b c d e : A)
|
||||
include s
|
||||
|
||||
theorem mul_self_sub_mul_self_eq : a * a - b * b = (a + b) * (a - b) :=
|
||||
begin
|
||||
krewrite [left_distrib, *right_distrib, add.assoc],
|
||||
rewrite [-{b*a + _}add.assoc,
|
||||
-*neg_mul_eq_mul_neg, {a*b}mul.comm, add.right_inv, zero_add]
|
||||
end
|
||||
|
||||
theorem mul_self_sub_one_eq : a * a - 1 = (a + 1) * (a - 1) :=
|
||||
by rewrite [-mul_self_sub_mul_self_eq, mul_one]
|
||||
|
||||
theorem dvd_neg_iff_dvd : (a ∣ -b) ↔ (a ∣ b) :=
|
||||
iff.intro
|
||||
(suppose a ∣ -b,
|
||||
dvd.elim this
|
||||
(take c, suppose -b = a * c,
|
||||
dvd.intro
|
||||
(show a * -c = b,
|
||||
by rewrite [-neg_mul_eq_mul_neg, -this, neg_neg])))
|
||||
(suppose a ∣ b,
|
||||
dvd.elim this
|
||||
(take c, suppose b = a * c,
|
||||
dvd.intro
|
||||
(show a * -c = -b,
|
||||
by rewrite [-neg_mul_eq_mul_neg, -this])))
|
||||
|
||||
theorem dvd_neg_of_dvd : (a ∣ b) → (a ∣ -b) :=
|
||||
iff.mpr !dvd_neg_iff_dvd
|
||||
|
||||
theorem dvd_of_dvd_neg : (a ∣ -b) → (a ∣ b) :=
|
||||
iff.mp !dvd_neg_iff_dvd
|
||||
|
||||
theorem neg_dvd_iff_dvd : (-a ∣ b) ↔ (a ∣ b) :=
|
||||
iff.intro
|
||||
(suppose -a ∣ b,
|
||||
dvd.elim this
|
||||
(take c, suppose b = -a * c,
|
||||
dvd.intro
|
||||
(show a * -c = b, by rewrite [-neg_mul_comm, this])))
|
||||
(suppose a ∣ b,
|
||||
dvd.elim this
|
||||
(take c, suppose b = a * c,
|
||||
dvd.intro
|
||||
(show -a * -c = b, by rewrite [neg_mul_neg, this])))
|
||||
|
||||
theorem neg_dvd_of_dvd : (a ∣ b) → (-a ∣ b) :=
|
||||
iff.mpr !neg_dvd_iff_dvd
|
||||
|
||||
theorem dvd_of_neg_dvd : (-a ∣ b) → (a ∣ b) :=
|
||||
iff.mp !neg_dvd_iff_dvd
|
||||
|
||||
theorem dvd_sub (H₁ : (a ∣ b)) (H₂ : (a ∣ c)) : (a ∣ b - c) :=
|
||||
dvd_add H₁ (!dvd_neg_of_dvd H₂)
|
||||
end
|
||||
|
||||
/- integral domains -/
|
||||
|
||||
structure no_zero_divisors [class] (A : Type) extends has_mul A, has_zero A :=
|
||||
(eq_zero_sum_eq_zero_of_mul_eq_zero : Πa b, mul a b = zero → a = zero ⊎ b = zero)
|
||||
|
||||
definition eq_zero_sum_eq_zero_of_mul_eq_zero {A : Type} [s : no_zero_divisors A] {a b : A}
|
||||
(H : a * b = 0) :
|
||||
a = 0 ⊎ b = 0 := !no_zero_divisors.eq_zero_sum_eq_zero_of_mul_eq_zero H
|
||||
|
||||
structure integral_domain [class] (A : Type) extends comm_ring A, no_zero_divisors A,
|
||||
zero_ne_one_class A
|
||||
|
||||
section
|
||||
variables [s : integral_domain A] (a b c d e : A)
|
||||
include s
|
||||
|
||||
theorem mul_ne_zero {a b : A} (H1 : a ≠ 0) (H2 : b ≠ 0) : a * b ≠ 0 :=
|
||||
suppose a * b = 0,
|
||||
sum.elim (eq_zero_sum_eq_zero_of_mul_eq_zero this) (assume H3, H1 H3) (assume H4, H2 H4)
|
||||
|
||||
theorem eq_of_mul_eq_mul_right {a b c : A} (Ha : a ≠ 0) (H : b * a = c * a) : b = c :=
|
||||
have b * a - c * a = 0, from iff.mp !eq_iff_sub_eq_zero H,
|
||||
have (b - c) * a = 0, by rewrite [mul_sub_right_distrib, this],
|
||||
have b - c = 0, from sum_resolve_left (eq_zero_sum_eq_zero_of_mul_eq_zero this) Ha,
|
||||
iff.elim_right !eq_iff_sub_eq_zero this
|
||||
|
||||
theorem eq_of_mul_eq_mul_left {a b c : A} (Ha : a ≠ 0) (H : a * b = a * c) : b = c :=
|
||||
have a * b - a * c = 0, from iff.mp !eq_iff_sub_eq_zero H,
|
||||
have a * (b - c) = 0, by rewrite [mul_sub_left_distrib, this],
|
||||
have b - c = 0, from sum_resolve_right (eq_zero_sum_eq_zero_of_mul_eq_zero this) Ha,
|
||||
iff.elim_right !eq_iff_sub_eq_zero this
|
||||
|
||||
-- TODO: do we want the iff versions?
|
||||
|
||||
theorem eq_zero_of_mul_eq_self_right {a b : A} (H₁ : b ≠ 1) (H₂ : a * b = a) : a = 0 :=
|
||||
have b - 1 ≠ 0, from
|
||||
suppose b - 1 = 0, H₁ (!zero_add ▸ eq_add_of_sub_eq this),
|
||||
have a * b - a = 0, by rewrite H₂; apply sub_self,
|
||||
have a * (b - 1) = 0, by rewrite [mul_sub_left_distrib, mul_one]; apply this,
|
||||
show a = 0, from sum_resolve_left (eq_zero_sum_eq_zero_of_mul_eq_zero this) `b - 1 ≠ 0`
|
||||
|
||||
theorem eq_zero_of_mul_eq_self_left {a b : A} (H₁ : b ≠ 1) (H₂ : b * a = a) : a = 0 :=
|
||||
eq_zero_of_mul_eq_self_right H₁ (!mul.comm ▸ H₂)
|
||||
|
||||
theorem mul_self_eq_mul_self_iff (a b : A) : a * a = b * b ↔ a = b ⊎ a = -b :=
|
||||
iff.intro
|
||||
(suppose a * a = b * b,
|
||||
have (a - b) * (a + b) = 0,
|
||||
by rewrite [mul.comm, -mul_self_sub_mul_self_eq, this, sub_self],
|
||||
have a - b = 0 ⊎ a + b = 0, from !eq_zero_sum_eq_zero_of_mul_eq_zero this,
|
||||
sum.elim this
|
||||
(suppose a - b = 0, sum.inl (eq_of_sub_eq_zero this))
|
||||
(suppose a + b = 0, sum.inr (eq_neg_of_add_eq_zero this)))
|
||||
(suppose a = b ⊎ a = -b, sum.elim this
|
||||
(suppose a = b, by rewrite this)
|
||||
(suppose a = -b, by rewrite [this, neg_mul_neg]))
|
||||
|
||||
theorem mul_self_eq_one_iff (a : A) : a * a = 1 ↔ a = 1 ⊎ a = -1 :=
|
||||
have a * a = 1 * 1 ↔ a = 1 ⊎ a = -1, from mul_self_eq_mul_self_iff a 1,
|
||||
by rewrite mul_one at this; exact this
|
||||
|
||||
-- TODO: c - b * c → c = 0 ⊎ b = 1 and variants
|
||||
|
||||
theorem dvd_of_mul_dvd_mul_left {a b c : A} (Ha : a ≠ 0) (Hdvd : (a * b ∣ a * c)) : (b ∣ c) :=
|
||||
dvd.elim Hdvd
|
||||
(take d,
|
||||
suppose a * c = a * b * d,
|
||||
have b * d = c, from eq_of_mul_eq_mul_left Ha (mul.assoc a b d ▸ this⁻¹),
|
||||
dvd.intro this)
|
||||
|
||||
theorem dvd_of_mul_dvd_mul_right {a b c : A} (Ha : a ≠ 0) (Hdvd : (b * a ∣ c * a)) : (b ∣ c) :=
|
||||
dvd.elim Hdvd
|
||||
(take d,
|
||||
suppose c * a = b * a * d,
|
||||
have b * d * a = c * a, from by rewrite [mul.right_comm, -this],
|
||||
have b * d = c, from eq_of_mul_eq_mul_right Ha this,
|
||||
dvd.intro this)
|
||||
end
|
||||
|
||||
namespace norm_num
|
||||
|
||||
theorem mul_zero [s : mul_zero_class A] (a : A) : a * zero = zero :=
|
||||
by rewrite [↑zero, mul_zero]
|
||||
|
||||
theorem zero_mul [s : mul_zero_class A] (a : A) : zero * a = zero :=
|
||||
by rewrite [↑zero, zero_mul]
|
||||
|
||||
theorem mul_one [s : monoid A] (a : A) : a * one = a :=
|
||||
by rewrite [↑one, mul_one]
|
||||
|
||||
theorem mul_bit0 [s : distrib A] (a b : A) : a * (bit0 b) = bit0 (a * b) :=
|
||||
by rewrite [↑bit0, left_distrib]
|
||||
|
||||
theorem mul_bit0_helper [s : distrib A] (a b t : A) (H : a * b = t) : a * (bit0 b) = bit0 t :=
|
||||
by rewrite -H; apply mul_bit0
|
||||
|
||||
theorem mul_bit1 [s : semiring A] (a b : A) : a * (bit1 b) = bit0 (a * b) + a :=
|
||||
by rewrite [↑bit1, ↑bit0, +left_distrib, ↑one, mul_one]
|
||||
|
||||
theorem mul_bit1_helper [s : semiring A] (a b s t : A) (Hs : a * b = s) (Ht : bit0 s + a = t) :
|
||||
a * (bit1 b) = t :=
|
||||
begin rewrite [-Ht, -Hs, mul_bit1] end
|
||||
|
||||
theorem subst_into_prod [s : has_mul A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
|
||||
(prt : tl * tr = t) :
|
||||
l * r = t :=
|
||||
by rewrite [prl, prr, prt]
|
||||
|
||||
theorem mk_cong (op : A → A) (a b : A) (H : a = b) : op a = op b :=
|
||||
by congruence; exact H
|
||||
|
||||
theorem mk_eq (a : A) : a = a := rfl
|
||||
|
||||
theorem neg_add_neg_eq_of_add_add_eq_zero [s : add_ab_group A] (a b c : A) (H : c + a + b = 0) :
|
||||
-a + -b = c :=
|
||||
begin
|
||||
apply add_neg_eq_of_eq_add,
|
||||
apply neg_eq_of_add_eq_zero,
|
||||
rewrite [add.comm, add.assoc, add.comm b, -add.assoc, H]
|
||||
end
|
||||
|
||||
theorem neg_add_neg_helper [s : add_ab_group A] (a b c : A) (H : a + b = c) : -a + -b = -c :=
|
||||
begin apply iff.mp !neg_eq_neg_iff_eq, rewrite [neg_add, *neg_neg, H] end
|
||||
|
||||
theorem neg_add_pos_eq_of_eq_add [s : add_ab_group A] (a b c : A) (H : b = c + a) : -a + b = c :=
|
||||
begin apply neg_add_eq_of_eq_add, rewrite add.comm, exact H end
|
||||
|
||||
theorem neg_add_pos_helper1 [s : add_ab_group A] (a b c : A) (H : b + c = a) : -a + b = -c :=
|
||||
begin apply neg_add_eq_of_eq_add, apply eq_add_neg_of_add_eq H end
|
||||
|
||||
theorem neg_add_pos_helper2 [s : add_ab_group A] (a b c : A) (H : a + c = b) : -a + b = c :=
|
||||
begin apply neg_add_eq_of_eq_add, rewrite H end
|
||||
|
||||
theorem pos_add_neg_helper [s : add_ab_group A] (a b c : A) (H : b + a = c) : a + b = c :=
|
||||
by rewrite [add.comm, H]
|
||||
|
||||
theorem sub_eq_add_neg_helper [s : add_ab_group A] (t₁ t₂ e w₁ w₂: A) (H₁ : t₁ = w₁)
|
||||
(H₂ : t₂ = w₂) (H : w₁ + -w₂ = e) : t₁ - t₂ = e :=
|
||||
by rewrite [sub_eq_add_neg, H₁, H₂, H]
|
||||
|
||||
theorem pos_add_pos_helper [s : add_ab_group A] (a b c h₁ h₂ : A) (H₁ : a = h₁) (H₂ : b = h₂)
|
||||
(H : h₁ + h₂ = c) : a + b = c :=
|
||||
by rewrite [H₁, H₂, H]
|
||||
|
||||
theorem subst_into_subtr [s : add_group A] (l r t : A) (prt : l + -r = t) : l - r = t :=
|
||||
by rewrite [sub_eq_add_neg, prt]
|
||||
|
||||
theorem neg_neg_helper [s : add_group A] (a b : A) (H : a = -b) : -a = b :=
|
||||
by rewrite [H, neg_neg]
|
||||
|
||||
theorem neg_mul_neg_helper [s : ring A] (a b c : A) (H : a * b = c) : (-a) * (-b) = c :=
|
||||
begin rewrite [neg_mul_neg, H] end
|
||||
|
||||
theorem neg_mul_pos_helper [s : ring A] (a b c : A) (H : a * b = c) : (-a) * b = -c :=
|
||||
begin rewrite [-neg_mul_eq_neg_mul, H] end
|
||||
|
||||
theorem pos_mul_neg_helper [s : ring A] (a b c : A) (H : a * b = c) : a * (-b) = -c :=
|
||||
begin rewrite [-neg_mul_comm, -neg_mul_eq_neg_mul, H] end
|
||||
|
||||
end norm_num
|
||||
end algebra
|
||||
open algebra
|
||||
|
||||
attribute [simp]
|
||||
zero_mul mul_zero
|
||||
at simplifier.unit
|
||||
|
||||
attribute [simp]
|
||||
neg_mul_eq_neg_mul_symm mul_neg_eq_neg_mul_symm
|
||||
at simplifier.neg
|
||||
|
||||
attribute [simp]
|
||||
left_distrib right_distrib
|
||||
at simplifier.distrib
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
truncating an ∞-group to a group
|
||||
-/
|
||||
|
||||
import hit.trunc algebra.bundled
|
||||
|
||||
open eq is_trunc trunc
|
||||
|
||||
namespace algebra
|
||||
|
||||
section
|
||||
parameters (n : trunc_index) {A : Type} [inf_group A]
|
||||
|
||||
local abbreviation G := trunc n A
|
||||
|
||||
definition trunc_mul [unfold 9 10] (g h : G) : G :=
|
||||
begin
|
||||
induction g with p,
|
||||
induction h with q,
|
||||
exact tr (p * q)
|
||||
end
|
||||
|
||||
definition trunc_inv [unfold 9] (g : G) : G :=
|
||||
begin
|
||||
induction g with p,
|
||||
exact tr p⁻¹
|
||||
end
|
||||
|
||||
definition trunc_one [constructor] : G :=
|
||||
tr 1
|
||||
|
||||
local notation 1 := trunc_one
|
||||
local postfix ⁻¹ := trunc_inv
|
||||
local infix * := trunc_mul
|
||||
|
||||
theorem trunc_mul_assoc (g₁ g₂ g₃ : G) : g₁ * g₂ * g₃ = g₁ * (g₂ * g₃) :=
|
||||
begin
|
||||
induction g₁ with p₁,
|
||||
induction g₂ with p₂,
|
||||
induction g₃ with p₃,
|
||||
exact ap tr !mul.assoc,
|
||||
end
|
||||
|
||||
theorem trunc_one_mul (g : G) : 1 * g = g :=
|
||||
begin
|
||||
induction g with p,
|
||||
exact ap tr !one_mul
|
||||
end
|
||||
|
||||
theorem trunc_mul_one (g : G) : g * 1 = g :=
|
||||
begin
|
||||
induction g with p,
|
||||
exact ap tr !mul_one
|
||||
end
|
||||
|
||||
theorem trunc_mul_left_inv (g : G) : g⁻¹ * g = 1 :=
|
||||
begin
|
||||
induction g with p,
|
||||
exact ap tr !mul.left_inv
|
||||
end
|
||||
|
||||
parameter (A)
|
||||
definition trunc_inf_group [constructor] [instance] : inf_group (trunc n A) :=
|
||||
⦃inf_group,
|
||||
mul := algebra.trunc_mul n,
|
||||
mul_assoc := algebra.trunc_mul_assoc n,
|
||||
one := algebra.trunc_one n,
|
||||
one_mul := algebra.trunc_one_mul n,
|
||||
mul_one := algebra.trunc_mul_one n,
|
||||
inv := algebra.trunc_inv n,
|
||||
mul_left_inv := algebra.trunc_mul_left_inv n⦄
|
||||
|
||||
definition trunc_group [constructor] : group (trunc 0 A) :=
|
||||
group_of_inf_group _
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
variables (n : trunc_index) {A : Type} [ab_inf_group A]
|
||||
|
||||
theorem trunc_mul_comm (g h : trunc n A) : trunc_mul n g h = trunc_mul n h g :=
|
||||
begin
|
||||
induction g with p,
|
||||
induction h with q,
|
||||
exact ap tr !mul.comm
|
||||
end
|
||||
|
||||
variable (A)
|
||||
definition trunc_ab_inf_group [constructor] [instance] : ab_inf_group (trunc n A) :=
|
||||
⦃ab_inf_group, trunc_inf_group n A, mul_comm := algebra.trunc_mul_comm n⦄
|
||||
|
||||
definition trunc_ab_group [constructor] : ab_group (trunc 0 A) :=
|
||||
ab_group_of_ab_inf_group _
|
||||
|
||||
end
|
||||
|
||||
end algebra
|
||||
249
hott/arity.hlean
249
hott/arity.hlean
|
|
@ -1,249 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2014 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Theorems about functions with multiple arguments
|
||||
-/
|
||||
|
||||
variables {A U V W X Y Z : Type} {B : A → Type} {C : Πa, B a → Type} {D : Πa b, C a b → Type}
|
||||
{E : Πa b c, D a b c → Type} {F : Πa b c d, E a b c d → Type}
|
||||
{G : Πa b c d e, F a b c d e → Type} {H : Πa b c d e f, G a b c d e f → Type}
|
||||
variables {a a' : A} {u u' : U} {v v' : V} {w w' : W} {x x' x'' : X} {y y' : Y} {z z' : Z}
|
||||
{b : B a} {b' : B a'}
|
||||
{c : C a b} {c' : C a' b'}
|
||||
{d : D a b c} {d' : D a' b' c'}
|
||||
{e : E a b c d} {e' : E a' b' c' d'}
|
||||
{ff : F a b c d e} {f' : F a' b' c' d' e'}
|
||||
{g : G a b c d e ff} {g' : G a' b' c' d' e' f'}
|
||||
{h : H a b c d e ff g} {h' : H a' b' c' d' e' f' g'}
|
||||
|
||||
namespace eq
|
||||
/-
|
||||
Naming convention:
|
||||
The theorem which states how to construct an path between two function applications is
|
||||
api₀i₁...iₙ.
|
||||
Here i₀, ... iₙ are digits, n is the arity of the function(s),
|
||||
and iⱼ specifies the dimension of the path between the jᵗʰ argument
|
||||
(i₀ specifies the dimension of the path between the functions).
|
||||
A value iⱼ ≡ 0 means that the jᵗʰ arguments are definitionally equal
|
||||
The functions are non-dependent, except when the theorem name contains trailing zeroes
|
||||
(where the function is dependent only in the arguments where it doesn't result in any
|
||||
transports in the theorem statement).
|
||||
For the fully-dependent versions (except that the conclusion doesn't contain a transport)
|
||||
we write
|
||||
apdi₀i₁...iₙ.
|
||||
|
||||
For versions where only some arguments depend on some other arguments,
|
||||
or for versions with transport in the conclusion (like apdt), we don't have a
|
||||
consistent naming scheme (yet).
|
||||
|
||||
We don't prove each theorem systematically, but prove only the ones which we actually need.
|
||||
-/
|
||||
|
||||
definition homotopy2 [reducible] (f g : Πa b, C a b) : Type :=
|
||||
Πa b, f a b = g a b
|
||||
definition homotopy3 [reducible] (f g : Πa b c, D a b c) : Type :=
|
||||
Πa b c, f a b c = g a b c
|
||||
definition homotopy4 [reducible] (f g : Πa b c d, E a b c d) : Type :=
|
||||
Πa b c d, f a b c d = g a b c d
|
||||
|
||||
infix ` ~2 `:50 := homotopy2
|
||||
infix ` ~3 `:50 := homotopy3
|
||||
|
||||
definition ap0111 (f : U → V → W → X) (Hu : u = u') (Hv : v = v') (Hw : w = w')
|
||||
: f u v w = f u' v' w' :=
|
||||
by cases Hu; congruence; repeat assumption
|
||||
|
||||
definition ap01111 (f : U → V → W → X → Y)
|
||||
(Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x')
|
||||
: f u v w x = f u' v' w' x' :=
|
||||
by cases Hu; congruence; repeat assumption
|
||||
|
||||
definition ap011111 (f : U → V → W → X → Y → Z)
|
||||
(Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x') (Hy : y = y')
|
||||
: f u v w x y = f u' v' w' x' y' :=
|
||||
by cases Hu; congruence; repeat assumption
|
||||
|
||||
definition ap0111111 (f : U → V → W → X → Y → Z → A)
|
||||
(Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x') (Hy : y = y') (Hz : z = z')
|
||||
: f u v w x y z = f u' v' w' x' y' z' :=
|
||||
by cases Hu; congruence; repeat assumption
|
||||
|
||||
definition ap010 (f : X → Πa, B a) (Hx : x = x') : f x ~ f x' :=
|
||||
by intros; cases Hx; reflexivity
|
||||
|
||||
definition ap0100 (f : X → Πa b, C a b) (Hx : x = x') : f x ~2 f x' :=
|
||||
by intros; cases Hx; reflexivity
|
||||
|
||||
definition ap01000 (f : X → Πa b c, D a b c) (Hx : x = x') : f x ~3 f x' :=
|
||||
by intros; cases Hx; reflexivity
|
||||
|
||||
definition apdt011 (f : Πa, B a → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
: f a b = f a' b' :=
|
||||
by cases Ha; cases Hb; reflexivity
|
||||
|
||||
definition apdt0111 (f : Πa b, C a b → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
(Hc : cast (apdt011 C Ha Hb) c = c')
|
||||
: f a b c = f a' b' c' :=
|
||||
by cases Ha; cases Hb; cases Hc; reflexivity
|
||||
|
||||
definition apdt01111 (f : Πa b c, D a b c → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
(Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
|
||||
: f a b c d = f a' b' c' d' :=
|
||||
by cases Ha; cases Hb; cases Hc; cases Hd; reflexivity
|
||||
|
||||
definition apdt011111 (f : Πa b c d, E a b c d → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
(Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
|
||||
(He : cast (apdt01111 E Ha Hb Hc Hd) e = e')
|
||||
: f a b c d e = f a' b' c' d' e' :=
|
||||
by cases Ha; cases Hb; cases Hc; cases Hd; cases He; reflexivity
|
||||
|
||||
definition apdt0111111 (f : Πa b c d e, F a b c d e → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
(Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
|
||||
(He : cast (apdt01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apdt011111 F Ha Hb Hc Hd He) ff = f')
|
||||
: f a b c d e ff = f a' b' c' d' e' f' :=
|
||||
begin cases Ha, cases Hb, cases Hc, cases Hd, cases He, cases Hf, reflexivity end
|
||||
|
||||
-- definition apd0111111 (f : Πa b c d e ff, G a b c d e ff → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
-- (Hc : cast (apd011 C Ha Hb) c = c') (Hd : cast (apd0111 D Ha Hb Hc) d = d')
|
||||
-- (He : cast (apd01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apd011111 F Ha Hb Hc Hd He) ff = f')
|
||||
-- (Hg : cast (apd0111111 G Ha Hb Hc Hd He Hf) g = g')
|
||||
-- : f a b c d e ff g = f a' b' c' d' e' f' g' :=
|
||||
-- by cases Ha; cases Hb; cases Hc; cases Hd; cases He; cases Hf; cases Hg; reflexivity
|
||||
|
||||
-- definition apd01111111 (f : Πa b c d e ff g, G a b c d e ff g → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
-- (Hc : cast (apd011 C Ha Hb) c = c') (Hd : cast (apd0111 D Ha Hb Hc) d = d')
|
||||
-- (He : cast (apd01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apd011111 F Ha Hb Hc Hd He) ff = f')
|
||||
-- (Hg : cast (apd0111111 G Ha Hb Hc Hd He Hf) g = g') (Hh : cast (apd01111111 H Ha Hb Hc Hd He Hf Hg) h = h')
|
||||
-- : f a b c d e ff g h = f a' b' c' d' e' f' g' h' :=
|
||||
-- by cases Ha; cases Hb; cases Hc; cases Hd; cases He; cases Hf; cases Hg; cases Hh; reflexivity
|
||||
|
||||
definition apd100 [unfold 6] {f g : Πa b, C a b} (p : f = g) : f ~2 g :=
|
||||
λa b, apd10 (apd10 p a) b
|
||||
|
||||
definition apd1000 [unfold 7] {f g : Πa b c, D a b c} (p : f = g) : f ~3 g :=
|
||||
λa b c, apd100 (apd10 p a) b c
|
||||
|
||||
/- some properties of these variants of ap -/
|
||||
|
||||
-- we only prove what we currently need
|
||||
|
||||
definition ap010_con (f : X → Πa, B a) (p : x = x') (q : x' = x'') :
|
||||
ap010 f (p ⬝ q) a = ap010 f p a ⬝ ap010 f q a :=
|
||||
eq.rec_on q (eq.rec_on p idp)
|
||||
|
||||
definition ap010_ap (f : X → Πa, B a) (g : Y → X) (p : y = y') :
|
||||
ap010 f (ap g p) a = ap010 (λy, f (g y)) p a :=
|
||||
eq.rec_on p idp
|
||||
|
||||
/- the following theorems are function extentionality for functions with multiple arguments -/
|
||||
|
||||
definition eq_of_homotopy2 {f g : Πa b, C a b} (H : f ~2 g) : f = g :=
|
||||
eq_of_homotopy (λa, eq_of_homotopy (H a))
|
||||
|
||||
definition eq_of_homotopy3 {f g : Πa b c, D a b c} (H : f ~3 g) : f = g :=
|
||||
eq_of_homotopy (λa, eq_of_homotopy2 (H a))
|
||||
|
||||
definition eq_of_homotopy2_id (f : Πa b, C a b)
|
||||
: eq_of_homotopy2 (λa b, idpath (f a b)) = idpath f :=
|
||||
begin
|
||||
transitivity eq_of_homotopy (λ a, idpath (f a)),
|
||||
{apply (ap eq_of_homotopy), apply eq_of_homotopy, intros, apply eq_of_homotopy_idp},
|
||||
apply eq_of_homotopy_idp
|
||||
end
|
||||
|
||||
definition eq_of_homotopy3_id (f : Πa b c, D a b c)
|
||||
: eq_of_homotopy3 (λa b c, idpath (f a b c)) = idpath f :=
|
||||
begin
|
||||
transitivity _,
|
||||
{apply (ap eq_of_homotopy), apply eq_of_homotopy, intros, apply eq_of_homotopy2_id},
|
||||
apply eq_of_homotopy_idp
|
||||
end
|
||||
|
||||
definition eq_of_homotopy2_inv {f g : Πa b, C a b} (H : f ~2 g)
|
||||
: eq_of_homotopy2 (λa b, (H a b)⁻¹) = (eq_of_homotopy2 H)⁻¹ :=
|
||||
ap eq_of_homotopy (eq_of_homotopy (λa, !eq_of_homotopy_inv)) ⬝ !eq_of_homotopy_inv
|
||||
|
||||
definition eq_of_homotopy3_inv {f g : Πa b c, D a b c} (H : f ~3 g)
|
||||
: eq_of_homotopy3 (λa b c, (H a b c)⁻¹) = (eq_of_homotopy3 H)⁻¹ :=
|
||||
ap eq_of_homotopy (eq_of_homotopy (λa, !eq_of_homotopy2_inv)) ⬝ !eq_of_homotopy_inv
|
||||
|
||||
definition eq_of_homotopy2_con {f g h : Πa b, C a b} (H1 : f ~2 g) (H2 : g ~2 h)
|
||||
: eq_of_homotopy2 (λa b, H1 a b ⬝ H2 a b) = eq_of_homotopy2 H1 ⬝ eq_of_homotopy2 H2 :=
|
||||
ap eq_of_homotopy (eq_of_homotopy (λa, !eq_of_homotopy_con)) ⬝ !eq_of_homotopy_con
|
||||
|
||||
definition eq_of_homotopy3_con {f g h : Πa b c, D a b c} (H1 : f ~3 g) (H2 : g ~3 h)
|
||||
: eq_of_homotopy3 (λa b c, H1 a b c ⬝ H2 a b c) = eq_of_homotopy3 H1 ⬝ eq_of_homotopy3 H2 :=
|
||||
ap eq_of_homotopy (eq_of_homotopy (λa, !eq_of_homotopy2_con)) ⬝ !eq_of_homotopy_con
|
||||
|
||||
end eq
|
||||
|
||||
open eq equiv is_equiv
|
||||
namespace funext
|
||||
definition is_equiv_apd100 [instance] (f g : Πa b, C a b)
|
||||
: is_equiv (@apd100 A B C f g) :=
|
||||
adjointify _
|
||||
eq_of_homotopy2
|
||||
begin
|
||||
intro H, esimp [apd100, eq_of_homotopy2],
|
||||
apply eq_of_homotopy, intro a,
|
||||
apply concat, apply (ap (λx, apd10 (x a))), apply (right_inv apd10),
|
||||
apply (right_inv apd10)
|
||||
end
|
||||
begin
|
||||
intro p, cases p, apply eq_of_homotopy2_id
|
||||
end
|
||||
|
||||
definition is_equiv_apd1000 [instance] (f g : Πa b c, D a b c)
|
||||
: is_equiv (@apd1000 A B C D f g) :=
|
||||
adjointify _
|
||||
eq_of_homotopy3
|
||||
begin
|
||||
intro H, esimp,
|
||||
apply eq_of_homotopy, intro a,
|
||||
transitivity apd100 (eq_of_homotopy2 (H a)),
|
||||
{apply ap (λx, apd100 (x a)),
|
||||
apply right_inv apd10},
|
||||
apply right_inv apd100
|
||||
end
|
||||
begin
|
||||
intro p, cases p, apply eq_of_homotopy3_id
|
||||
end
|
||||
end funext
|
||||
|
||||
attribute funext.is_equiv_apd100 funext.is_equiv_apd1000 [constructor]
|
||||
|
||||
namespace eq
|
||||
open funext
|
||||
local attribute funext.is_equiv_apd100 [instance]
|
||||
protected definition homotopy2.rec_on {f g : Πa b, C a b} {P : (f ~2 g) → Type}
|
||||
(p : f ~2 g) (H : Π(q : f = g), P (apd100 q)) : P p :=
|
||||
right_inv apd100 p ▸ H (eq_of_homotopy2 p)
|
||||
|
||||
protected definition homotopy3.rec_on {f g : Πa b c, D a b c} {P : (f ~3 g) → Type}
|
||||
(p : f ~3 g) (H : Π(q : f = g), P (apd1000 q)) : P p :=
|
||||
right_inv apd1000 p ▸ H (eq_of_homotopy3 p)
|
||||
|
||||
definition eq_equiv_homotopy2 [constructor] (f g : Πa b, C a b) : (f = g) ≃ (f ~2 g) :=
|
||||
equiv.mk apd100 _
|
||||
|
||||
definition eq_equiv_homotopy3 [constructor] (f g : Πa b c, D a b c) : (f = g) ≃ (f ~3 g) :=
|
||||
equiv.mk apd1000 _
|
||||
|
||||
definition apd10_ap (f : X → Πa, B a) (p : x = x')
|
||||
: apd10 (ap f p) = ap010 f p :=
|
||||
eq.rec_on p idp
|
||||
|
||||
definition eq_of_homotopy_ap010 (f : X → Πa, B a) (p : x = x')
|
||||
: eq_of_homotopy (ap010 f p) = ap f p :=
|
||||
inv_eq_of_eq !apd10_ap⁻¹
|
||||
|
||||
definition ap_eq_ap_of_homotopy {f : X → Πa, B a} {p q : x = x'} (H : ap010 f p ~ ap010 f q)
|
||||
: ap f p = ap f q :=
|
||||
calc
|
||||
ap f p = eq_of_homotopy (ap010 f p) : eq_of_homotopy_ap010
|
||||
... = eq_of_homotopy (ap010 f q) : eq_of_homotopy H
|
||||
... = ap f q : eq_of_homotopy_ap010
|
||||
|
||||
end eq
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
import types.trunc types.bool
|
||||
open eq bool equiv sigma sigma.ops trunc is_trunc pi
|
||||
|
||||
namespace choice
|
||||
|
||||
universe variable u
|
||||
|
||||
-- 3.8.1. The axiom of choice.
|
||||
definition AC [reducible] := Π (X : Type.{u}) (A : X -> Type.{u}) (P : Π x, A x -> Type.{u}),
|
||||
is_set X -> (Π x, is_set (A x)) -> (Π x a, is_prop (P x a)) ->
|
||||
(Π x, ∥ Σ a, P x a ∥) -> ∥ Σ f, Π x, P x (f x) ∥
|
||||
|
||||
-- 3.8.3. Corresponds to the assertion that
|
||||
-- "the cartesian product of a family of nonempty sets is nonempty".
|
||||
definition AC_cart [reducible] := Π (X : Type.{u}) (A : X -> Type.{u}),
|
||||
is_set X -> (Π x, is_set (A x)) -> (Π x, ∥ A x ∥) -> ∥ Π x, A x ∥
|
||||
|
||||
-- A slight variant of AC with a modified (equivalent) codomain.
|
||||
definition AC' [reducible] := Π (X : Type.{u}) (A : X -> Type.{u}) (P : Π x, A x -> Type.{u}),
|
||||
is_set X -> (Π x, is_set (A x)) -> (Π x a, is_prop (P x a))
|
||||
-> (Π x, ∥ Σ a, P x a ∥) -> ∥ Π x, Σ a : A x, P x a ∥
|
||||
|
||||
-- The equivalence of AC and AC' follows from the equivalence of their codomains.
|
||||
definition AC_equiv_AC' : AC.{u} ≃ AC'.{u} :=
|
||||
equiv_of_is_prop
|
||||
(λ H X A P HX HA HP HI, trunc_functor _ (to_fun !sigma_pi_equiv_pi_sigma) (H X A P HX HA HP HI))
|
||||
(λ H X A P HX HA HP HI, trunc_functor _ (to_inv !sigma_pi_equiv_pi_sigma) (H X A P HX HA HP HI))
|
||||
|
||||
-- AC_cart can be derived from AC' by setting P := λ _ _ , unit.
|
||||
definition AC_cart_of_AC' : AC'.{u} -> AC_cart.{u} :=
|
||||
λ H X A HX HA HI, trunc_functor _ (λ H0 x, (H0 x).1)
|
||||
(H X A (λ x a, lift.{0 u} unit) HX HA (λ x a, !is_trunc_lift)
|
||||
(λ x, trunc_functor _ (λ a, ⟨a, lift.up.{0 u} unit.star⟩) (HI x)))
|
||||
|
||||
-- And the converse, by setting A := λ x, Σ a, P x a.
|
||||
definition AC'_of_AC_cart : AC_cart.{u} -> AC'.{u} :=
|
||||
by intro H X A P HX HA HP HI;
|
||||
apply H X (λ x, Σ a, P x a) HX (λ x, !is_trunc_sigma) HI
|
||||
|
||||
-- Which is enough to show AC' ≃ AC_cart, since both are props.
|
||||
definition AC'_equiv_AC_cart : AC'.{u} ≃ AC_cart.{u} :=
|
||||
equiv_of_is_prop AC_cart_of_AC'.{u} AC'_of_AC_cart.{u}
|
||||
|
||||
-- 3.8.2. AC ≃ AC_cart follows by transitivity.
|
||||
definition AC_equiv_AC_cart : AC.{u} ≃ AC_cart.{u} :=
|
||||
equiv.trans AC_equiv_AC' AC'_equiv_AC_cart
|
||||
|
||||
namespace example385
|
||||
definition X : Type.{1} := Σ A : Type.{0}, ∥ A = bool ∥
|
||||
|
||||
definition x0 : X := ⟨bool, merely.intro _ rfl⟩
|
||||
|
||||
definition Y : X -> Type.{1} := λ x, x0 = x
|
||||
|
||||
definition not_is_set_X : ¬ is_set X :=
|
||||
begin
|
||||
intro H, apply not_is_prop_bool_eq_bool,
|
||||
apply @is_trunc_equiv_closed (x0 = x0),
|
||||
apply equiv.symm !equiv_subtype
|
||||
end
|
||||
|
||||
definition is_set_x1 (x : X) : is_set x.1 :=
|
||||
by cases x; induction a_1; cases a_1; exact _
|
||||
|
||||
definition is_set_Yx (x : X) : is_set (Y x) :=
|
||||
begin
|
||||
apply @is_trunc_equiv_closed _ _ _ !equiv_subtype,
|
||||
apply @is_trunc_equiv_closed _ _ _ (equiv.symm !eq_equiv_equiv),
|
||||
apply is_trunc_equiv; repeat (apply is_set_x1)
|
||||
end
|
||||
|
||||
definition trunc_Yx (x : X) : ∥ Y x ∥ :=
|
||||
begin
|
||||
cases x, induction a_1, apply merely.intro,
|
||||
apply to_fun !equiv_subtype, rewrite a_1
|
||||
end
|
||||
|
||||
end example385
|
||||
open example385
|
||||
|
||||
-- 3.8.5. There exists a type X and a family Y : X → U such that each Y(x) is a set,
|
||||
-- but such that (3.8.3) is false.
|
||||
definition X_must_be_set : Σ (X : Type.{1}) (Y : X -> Type.{1})
|
||||
(HA : Π x : X, is_set (Y x)), ¬ ((Π x : X, ∥ Y x ∥) -> ∥ Π x : X, Y x ∥) :=
|
||||
⟨X, Y, is_set_Yx, λ H, trunc.rec_on (H trunc_Yx)
|
||||
(λ H0, not_is_set_X (@is_trunc_of_is_contr _ _ (is_contr.mk x0 H0)))⟩
|
||||
|
||||
end choice
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
The core of the HoTT library
|
||||
-/
|
||||
|
||||
import types cubical homotopy hit choice
|
||||
|
|
@ -1,349 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Cubes
|
||||
-/
|
||||
|
||||
import .square
|
||||
|
||||
open equiv is_equiv sigma sigma.ops
|
||||
|
||||
namespace eq
|
||||
|
||||
inductive cube {A : Type} {a₀₀₀ : A} : Π{a₂₀₀ a₀₂₀ a₂₂₀ a₀₀₂ a₂₀₂ a₀₂₂ a₂₂₂ : A}
|
||||
{p₁₀₀ : a₀₀₀ = a₂₀₀} {p₀₁₀ : a₀₀₀ = a₀₂₀} {p₀₀₁ : a₀₀₀ = a₀₀₂}
|
||||
{p₁₂₀ : a₀₂₀ = a₂₂₀} {p₂₁₀ : a₂₀₀ = a₂₂₀} {p₂₀₁ : a₂₀₀ = a₂₀₂}
|
||||
{p₁₀₂ : a₀₀₂ = a₂₀₂} {p₀₁₂ : a₀₀₂ = a₀₂₂} {p₀₂₁ : a₀₂₀ = a₀₂₂}
|
||||
{p₁₂₂ : a₀₂₂ = a₂₂₂} {p₂₁₂ : a₂₀₂ = a₂₂₂} {p₂₂₁ : a₂₂₀ = a₂₂₂}
|
||||
(s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁)
|
||||
(s₂₁₁ : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁)
|
||||
(s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁)
|
||||
(s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁)
|
||||
(s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀)
|
||||
(s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂), Type :=
|
||||
idc : cube ids ids ids ids ids ids
|
||||
|
||||
variables {A B : Type} {a₀₀₀ a₂₀₀ a₀₂₀ a₂₂₀ a₀₀₂ a₂₀₂ a₀₂₂ a₂₂₂ a a' : A}
|
||||
{p₁₀₀ : a₀₀₀ = a₂₀₀} {p₀₁₀ : a₀₀₀ = a₀₂₀} {p₀₀₁ : a₀₀₀ = a₀₀₂}
|
||||
{p₁₂₀ : a₀₂₀ = a₂₂₀} {p₂₁₀ : a₂₀₀ = a₂₂₀} {p₂₀₁ : a₂₀₀ = a₂₀₂}
|
||||
{p₁₀₂ : a₀₀₂ = a₂₀₂} {p₀₁₂ : a₀₀₂ = a₀₂₂} {p₀₂₁ : a₀₂₀ = a₀₂₂}
|
||||
{p₁₂₂ : a₀₂₂ = a₂₂₂} {p₂₁₂ : a₂₀₂ = a₂₂₂} {p₂₂₁ : a₂₂₀ = a₂₂₂}
|
||||
{s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
|
||||
{s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
|
||||
{s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁}
|
||||
{s₂₁₁ : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
|
||||
{s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁}
|
||||
{s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
|
||||
{b₁ b₂ b₃ b₄ : B}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂)
|
||||
|
||||
definition idc [reducible] [constructor] := @cube.idc
|
||||
definition idcube [reducible] [constructor] (a : A) := @cube.idc A a
|
||||
|
||||
variables (s₁₁₀ s₁₀₁)
|
||||
definition refl1 : cube s₀₁₁ s₀₁₁ hrfl hrfl vrfl vrfl :=
|
||||
by induction s₀₁₁; exact idc
|
||||
|
||||
definition refl2 : cube hrfl hrfl s₁₀₁ s₁₀₁ hrfl hrfl :=
|
||||
by induction s₁₀₁; exact idc
|
||||
|
||||
definition refl3 : cube vrfl vrfl vrfl vrfl s₁₁₀ s₁₁₀ :=
|
||||
by induction s₁₁₀; exact idc
|
||||
|
||||
variables {s₁₁₀ s₁₀₁}
|
||||
definition rfl1 : cube s₀₁₁ s₀₁₁ hrfl hrfl vrfl vrfl := !refl1
|
||||
|
||||
definition rfl2 : cube hrfl hrfl s₁₀₁ s₁₀₁ hrfl hrfl := !refl2
|
||||
|
||||
definition rfl3 : cube vrfl vrfl vrfl vrfl s₁₁₀ s₁₁₀ := !refl3
|
||||
|
||||
-- Variables for composition
|
||||
variables {a₄₀₀ a₄₀₂ a₄₂₀ a₄₂₂ a₀₄₀ a₀₄₂ a₂₄₀ a₂₄₂ a₀₀₄ a₀₂₄ a₂₀₄ a₂₂₄ : A}
|
||||
{p₃₀₀ : a₂₀₀ = a₄₀₀} {p₃₀₂ : a₂₀₂ = a₄₀₂} {p₃₂₀ : a₂₂₀ = a₄₂₀} {p₃₂₂ : a₂₂₂ = a₄₂₂}
|
||||
{p₄₀₁ : a₄₀₀ = a₄₀₂} {p₄₁₀ : a₄₀₀ = a₄₂₀} {p₄₁₂ : a₄₀₂ = a₄₂₂} {p₄₂₁ : a₄₂₀ = a₄₂₂}
|
||||
{p₀₃₀ : a₀₂₀ = a₀₄₀} {p₀₃₂ : a₀₂₂ = a₀₄₂} {p₂₃₀ : a₂₂₀ = a₂₄₀} {p₂₃₂ : a₂₂₂ = a₂₄₂}
|
||||
{p₀₄₁ : a₀₄₀ = a₀₄₂} {p₁₄₀ : a₀₄₀ = a₂₄₀} {p₁₄₂ : a₀₄₂ = a₂₄₂} {p₂₄₁ : a₂₄₀ = a₂₄₂}
|
||||
{p₀₀₃ : a₀₀₂ = a₀₀₄} {p₀₂₃ : a₀₂₂ = a₀₂₄} {p₂₀₃ : a₂₀₂ = a₂₀₄} {p₂₂₃ : a₂₂₂ = a₂₂₄}
|
||||
{p₀₁₄ : a₀₀₄ = a₀₂₄} {p₁₀₄ : a₀₀₄ = a₂₀₄} {p₁₂₄ : a₀₂₄ = a₂₂₄} {p₂₁₄ : a₂₀₄ = a₂₂₄}
|
||||
{s₃₀₁ : square p₃₀₀ p₃₀₂ p₂₀₁ p₄₀₁} {s₃₁₀ : square p₂₁₀ p₄₁₀ p₃₀₀ p₃₂₀}
|
||||
{s₃₁₂ : square p₂₁₂ p₄₁₂ p₃₀₂ p₃₂₂} {s₃₂₁ : square p₃₂₀ p₃₂₂ p₂₂₁ p₄₂₁}
|
||||
{s₄₁₁ : square p₄₁₀ p₄₁₂ p₄₀₁ p₄₂₁}
|
||||
{s₀₃₁ : square p₀₃₀ p₀₃₂ p₀₂₁ p₀₄₁} {s₁₃₀ : square p₀₃₀ p₂₃₀ p₁₂₀ p₁₄₀}
|
||||
{s₁₃₂ : square p₀₃₂ p₂₃₂ p₁₂₂ p₁₄₂} {s₂₃₁ : square p₂₃₀ p₂₃₂ p₂₂₁ p₂₄₁}
|
||||
{s₁₄₁ : square p₁₄₀ p₁₄₂ p₀₄₁ p₂₄₁}
|
||||
{s₀₁₃ : square p₀₁₂ p₀₁₄ p₀₀₃ p₀₂₃} {s₁₀₃ : square p₁₀₂ p₁₀₄ p₀₀₃ p₂₀₃}
|
||||
{s₁₂₃ : square p₁₂₂ p₁₂₄ p₀₂₃ p₂₂₃} {s₂₁₃ : square p₂₁₂ p₂₁₄ p₂₀₃ p₂₂₃}
|
||||
{s₁₁₄ : square p₀₁₄ p₂₁₄ p₁₀₄ p₁₂₄}
|
||||
(d : cube s₂₁₁ s₄₁₁ s₃₀₁ s₃₂₁ s₃₁₀ s₃₁₂)
|
||||
(e : cube s₀₃₁ s₂₃₁ s₁₂₁ s₁₄₁ s₁₃₀ s₁₃₂)
|
||||
(f : cube s₀₁₃ s₂₁₃ s₁₀₃ s₁₂₃ s₁₁₂ s₁₁₄)
|
||||
|
||||
/- Composition of Cubes -/
|
||||
|
||||
include c d
|
||||
definition cube_concat1 : cube s₀₁₁ s₄₁₁ (s₁₀₁ ⬝h s₃₀₁) (s₁₂₁ ⬝h s₃₂₁) (s₁₁₀ ⬝v s₃₁₀) (s₁₁₂ ⬝v s₃₁₂) :=
|
||||
by induction d; exact c
|
||||
omit d
|
||||
|
||||
include e
|
||||
definition cube_concat2 : cube (s₀₁₁ ⬝h s₀₃₁) (s₂₁₁ ⬝h s₂₃₁) s₁₀₁ s₁₄₁ (s₁₁₀ ⬝h s₁₃₀) (s₁₁₂ ⬝h s₁₃₂) :=
|
||||
by induction e; exact c
|
||||
omit e
|
||||
|
||||
include f
|
||||
definition cube_concat3 : cube (s₀₁₁ ⬝v s₀₁₃) (s₂₁₁ ⬝v s₂₁₃) (s₁₀₁ ⬝v s₁₀₃) (s₁₂₁ ⬝v s₁₂₃) s₁₁₀ s₁₁₄ :=
|
||||
by induction f; exact c
|
||||
omit f c
|
||||
|
||||
definition eq_of_cube (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
transpose s₁₀₁⁻¹ᵛ ⬝h s₁₁₀ ⬝h transpose s₁₂₁ =
|
||||
whisker_square (eq_bot_of_square s₀₁₁) (eq_bot_of_square s₂₁₁) idp idp s₁₁₂ :=
|
||||
by induction c; reflexivity
|
||||
|
||||
definition eq_of_deg12_cube {s s' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
|
||||
(c : cube vrfl vrfl vrfl vrfl s s') : s = s' :=
|
||||
by induction s; exact eq_of_cube c
|
||||
|
||||
definition square_pathover {A B : Type} {a a' : A} {b₁ b₂ b₃ b₄ : A → B}
|
||||
{f₁ : b₁ ~ b₂} {f₂ : b₃ ~ b₄} {f₃ : b₁ ~ b₃} {f₄ : b₂ ~ b₄} {p : a = a'}
|
||||
{q : square (f₁ a) (f₂ a) (f₃ a) (f₄ a)}
|
||||
{r : square (f₁ a') (f₂ a') (f₃ a') (f₄ a')}
|
||||
(s : cube (natural_square f₁ p) (natural_square f₂ p)
|
||||
(natural_square f₃ p) (natural_square f₄ p) q r) : q =[p] r :=
|
||||
by induction p; apply pathover_idp_of_eq; exact eq_of_deg12_cube s
|
||||
|
||||
-- a special case where the endpoints do not depend on `p`
|
||||
definition square_pathover'
|
||||
{f₁ : A → b₁ = b₂} {f₂ : A → b₃ = b₄} {f₃ : A → b₁ = b₃} {f₄ : A → b₂ = b₄}
|
||||
{p : a = a'}
|
||||
{q : square (f₁ a) (f₂ a) (f₃ a) (f₄ a)}
|
||||
{r : square (f₁ a') (f₂ a') (f₃ a') (f₄ a')}
|
||||
(s : cube (vdeg_square (ap f₁ p)) (vdeg_square (ap f₂ p))
|
||||
(vdeg_square (ap f₃ p)) (vdeg_square (ap f₄ p)) q r) : q =[p] r :=
|
||||
by induction p;apply pathover_idp_of_eq;exact eq_of_deg12_cube s
|
||||
|
||||
/- Transporting along a square -/
|
||||
|
||||
definition cube_transport110 {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
|
||||
(p : s₁₁₀ = s₁₁₀') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀' s₁₁₂ :=
|
||||
by induction p; exact c
|
||||
|
||||
definition cube_transport112 {s₁₁₂' : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
|
||||
(p : s₁₁₂ = s₁₁₂') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂':=
|
||||
by induction p; exact c
|
||||
|
||||
definition cube_transport011 {s₀₁₁' : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁}
|
||||
(p : s₀₁₁ = s₀₁₁') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁' s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction p; exact c
|
||||
|
||||
definition cube_transport211 {s₂₁₁' : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
|
||||
(p : s₂₁₁ = s₂₁₁') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁ s₂₁₁' s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction p; exact c
|
||||
|
||||
definition cube_transport101 {s₁₀₁' : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁}
|
||||
(p : s₁₀₁ = s₁₀₁') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁ s₂₁₁ s₁₀₁' s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction p; exact c
|
||||
|
||||
definition cube_transport121 {s₁₂₁' : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
|
||||
(p : s₁₂₁ = s₁₂₁') (c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁' s₁₁₀ s₁₁₂ :=
|
||||
by induction p; exact c
|
||||
|
||||
/- Each equality between squares leads to a cube which is degenerate in one
|
||||
dimension. -/
|
||||
|
||||
definition deg1_cube {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀} (p : s₁₁₀ = s₁₁₀') :
|
||||
cube s₁₁₀ s₁₁₀' hrfl hrfl vrfl vrfl :=
|
||||
by induction p; exact rfl1
|
||||
|
||||
definition deg2_cube {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀} (p : s₁₁₀ = s₁₁₀') :
|
||||
cube hrfl hrfl s₁₁₀ s₁₁₀' hrfl hrfl :=
|
||||
by induction p; exact rfl2
|
||||
|
||||
definition deg3_cube {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀} (p : s₁₁₀ = s₁₁₀') :
|
||||
cube vrfl vrfl vrfl vrfl s₁₁₀ s₁₁₀' :=
|
||||
by induction p; exact rfl3
|
||||
|
||||
/- For each square of parralel equations, there are cubes where the square's
|
||||
sides appear in a degenerated way and two opposite sides are ids's -/
|
||||
|
||||
section
|
||||
variables {a₀ a₁ : A} {p₀₀ p₀₂ p₂₀ p₂₂ : a₀ = a₁} {s₁₀ : p₀₀ = p₂₀}
|
||||
{s₁₂ : p₀₂ = p₂₂} {s₀₁ : p₀₀ = p₀₂} {s₂₁ : p₂₀ = p₂₂}
|
||||
(sq : square s₁₀ s₁₂ s₀₁ s₂₁)
|
||||
|
||||
include sq
|
||||
|
||||
definition ids3_cube_of_square : cube (hdeg_square s₀₁)
|
||||
(hdeg_square s₂₁) (hdeg_square s₁₀) (hdeg_square s₁₂) ids ids :=
|
||||
by induction p₀₀; induction sq; apply idc
|
||||
|
||||
definition ids1_cube_of_square : cube ids ids
|
||||
(vdeg_square s₁₀) (vdeg_square s₁₂) (hdeg_square s₀₁) (hdeg_square s₂₁) :=
|
||||
by induction p₀₀; induction sq; apply idc
|
||||
|
||||
definition ids2_cube_of_square : cube (vdeg_square s₁₀) (vdeg_square s₁₂)
|
||||
ids ids (vdeg_square s₀₁) (vdeg_square s₂₁) :=
|
||||
by induction p₀₀; induction sq; apply idc
|
||||
|
||||
end
|
||||
|
||||
/- Cube fillers -/
|
||||
|
||||
section cube_fillers
|
||||
variables (s₁₁₀ s₁₁₂ s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁)
|
||||
|
||||
definition cube_fill110 : Σ lid, cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ lid s₁₁₂ :=
|
||||
begin
|
||||
induction s₀₁₁, induction s₂₁₁,
|
||||
let fillsq := square_fill_l (eq_of_vdeg_square s₁₀₁)
|
||||
(eq_of_hdeg_square s₁₁₂) (eq_of_vdeg_square s₁₂₁),
|
||||
apply sigma.mk,
|
||||
apply cube_transport101 (left_inv (vdeg_square_equiv _ _) s₁₀₁),
|
||||
apply cube_transport112 (left_inv (hdeg_square_equiv _ _) s₁₁₂),
|
||||
apply cube_transport121 (left_inv (vdeg_square_equiv _ _) s₁₂₁),
|
||||
apply ids1_cube_of_square, exact fillsq.2
|
||||
end
|
||||
|
||||
definition cube_fill112 : Σ lid, cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ lid :=
|
||||
begin
|
||||
induction s₀₁₁, induction s₂₁₁,
|
||||
let fillsq := square_fill_r (eq_of_vdeg_square s₁₀₁)
|
||||
(eq_of_hdeg_square s₁₁₀) (eq_of_vdeg_square s₁₂₁),
|
||||
apply sigma.mk,
|
||||
apply cube_transport101 (left_inv (vdeg_square_equiv _ _) s₁₀₁),
|
||||
apply cube_transport110 (left_inv (hdeg_square_equiv _ _) s₁₁₀),
|
||||
apply cube_transport121 (left_inv (vdeg_square_equiv _ _) s₁₂₁),
|
||||
apply ids1_cube_of_square, exact fillsq.2,
|
||||
end
|
||||
|
||||
definition cube_fill011 : Σ lid, cube lid s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
begin
|
||||
induction s₁₀₁, induction s₁₂₁,
|
||||
let fillsq := square_fill_t (eq_of_vdeg_square s₁₁₀) (eq_of_vdeg_square s₁₁₂)
|
||||
(eq_of_vdeg_square s₂₁₁),
|
||||
apply sigma.mk,
|
||||
apply cube_transport110 (left_inv (vdeg_square_equiv _ _) s₁₁₀),
|
||||
apply cube_transport211 (left_inv (vdeg_square_equiv _ _) s₂₁₁),
|
||||
apply cube_transport112 (left_inv (vdeg_square_equiv _ _) s₁₁₂),
|
||||
apply ids2_cube_of_square, exact fillsq.2,
|
||||
end
|
||||
|
||||
definition cube_fill211 : Σ lid, cube s₀₁₁ lid s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
begin
|
||||
induction s₁₀₁, induction s₁₂₁,
|
||||
let fillsq := square_fill_b (eq_of_vdeg_square s₀₁₁) (eq_of_vdeg_square s₁₁₀)
|
||||
(eq_of_vdeg_square s₁₁₂),
|
||||
apply sigma.mk,
|
||||
apply cube_transport011 (left_inv (vdeg_square_equiv _ _) s₀₁₁),
|
||||
apply cube_transport110 (left_inv (vdeg_square_equiv _ _) s₁₁₀),
|
||||
apply cube_transport112 (left_inv (vdeg_square_equiv _ _) s₁₁₂),
|
||||
apply ids2_cube_of_square, exact fillsq.2,
|
||||
end
|
||||
|
||||
definition cube_fill101 : Σ lid, cube s₀₁₁ s₂₁₁ lid s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
begin
|
||||
induction s₁₁₀, induction s₁₁₂,
|
||||
let fillsq := square_fill_t (eq_of_hdeg_square s₀₁₁) (eq_of_hdeg_square s₂₁₁)
|
||||
(eq_of_hdeg_square s₁₂₁),
|
||||
apply sigma.mk,
|
||||
apply cube_transport011 (left_inv (hdeg_square_equiv _ _) s₀₁₁),
|
||||
apply cube_transport211 (left_inv (hdeg_square_equiv _ _) s₂₁₁),
|
||||
apply cube_transport121 (left_inv (hdeg_square_equiv _ _) s₁₂₁),
|
||||
apply ids3_cube_of_square, exact fillsq.2,
|
||||
end
|
||||
|
||||
definition cube_fill121 : Σ lid, cube s₀₁₁ s₂₁₁ s₁₀₁ lid s₁₁₀ s₁₁₂ :=
|
||||
begin
|
||||
induction s₁₁₀, induction s₁₁₂,
|
||||
let fillsq := square_fill_b (eq_of_hdeg_square s₁₀₁) (eq_of_hdeg_square s₀₁₁)
|
||||
(eq_of_hdeg_square s₂₁₁),
|
||||
apply sigma.mk,
|
||||
apply cube_transport101 (left_inv (hdeg_square_equiv _ _) s₁₀₁),
|
||||
apply cube_transport011 (left_inv (hdeg_square_equiv _ _) s₀₁₁),
|
||||
apply cube_transport211 (left_inv (hdeg_square_equiv _ _) s₂₁₁),
|
||||
apply ids3_cube_of_square, exact fillsq.2,
|
||||
end
|
||||
|
||||
end cube_fillers
|
||||
|
||||
/- Apply a non-dependent function to an entire cube -/
|
||||
|
||||
include c
|
||||
definition apc (f : A → B) :
|
||||
cube (aps f s₀₁₁) (aps f s₂₁₁) (aps f s₁₀₁) (aps f s₁₂₁) (aps f s₁₁₀) (aps f s₁₁₂) :=
|
||||
by cases c; exact idc
|
||||
omit c
|
||||
|
||||
/- Transpose a cube (swap dimensions) -/
|
||||
|
||||
include c
|
||||
definition transpose12 : cube s₁₀₁ s₁₂₁ s₀₁₁ s₂₁₁ (transpose s₁₁₀) (transpose s₁₁₂) :=
|
||||
by cases c; exact idc
|
||||
|
||||
definition transpose13 : cube s₁₁₀ s₁₁₂ (transpose s₁₀₁) (transpose s₁₂₁) s₀₁₁ s₂₁₁ :=
|
||||
by cases c; exact idc
|
||||
|
||||
definition transpose23 : cube (transpose s₀₁₁) (transpose s₂₁₁) (transpose s₁₁₀)
|
||||
(transpose s₁₁₂) (transpose s₁₀₁) (transpose s₁₂₁) :=
|
||||
by cases c; exact idc
|
||||
omit c
|
||||
|
||||
/- Inverting a cube along one dimension -/
|
||||
|
||||
include c
|
||||
definition cube_inverse1 : cube s₂₁₁ s₀₁₁ s₁₀₁⁻¹ʰ s₁₂₁⁻¹ʰ s₁₁₀⁻¹ᵛ s₁₁₂⁻¹ᵛ :=
|
||||
by cases c; exact idc
|
||||
|
||||
definition cube_inverse2 : cube s₀₁₁⁻¹ʰ s₂₁₁⁻¹ʰ s₁₂₁ s₁₀₁ s₁₁₀⁻¹ʰ s₁₁₂⁻¹ʰ :=
|
||||
by cases c; exact idc
|
||||
|
||||
definition cube_inverse3 : cube s₀₁₁⁻¹ᵛ s₂₁₁⁻¹ᵛ s₁₀₁⁻¹ᵛ s₁₂₁⁻¹ᵛ s₁₁₂ s₁₁₀ :=
|
||||
by cases c; exact idc
|
||||
omit c
|
||||
|
||||
definition eq_concat1 {s₀₁₁' : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁} (r : s₀₁₁' = s₀₁₁)
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) : cube s₀₁₁' s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction r; exact c
|
||||
|
||||
definition concat1_eq {s₂₁₁' : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) (r : s₂₁₁ = s₂₁₁')
|
||||
: cube s₀₁₁ s₂₁₁' s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction r; exact c
|
||||
|
||||
definition eq_concat2 {s₁₀₁' : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁} (r : s₁₀₁' = s₁₀₁)
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) : cube s₀₁₁ s₂₁₁ s₁₀₁' s₁₂₁ s₁₁₀ s₁₁₂ :=
|
||||
by induction r; exact c
|
||||
|
||||
definition concat2_eq {s₁₂₁' : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) (r : s₁₂₁ = s₁₂₁')
|
||||
: cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁' s₁₁₀ s₁₁₂ :=
|
||||
by induction r; exact c
|
||||
|
||||
definition eq_concat3 {s₁₁₀' : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀} (r : s₁₁₀' = s₁₁₀)
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀' s₁₁₂ :=
|
||||
by induction r; exact c
|
||||
|
||||
definition concat3_eq {s₁₁₂' : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) (r : s₁₁₂ = s₁₁₂')
|
||||
: cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂' :=
|
||||
by induction r; exact c
|
||||
|
||||
infix ` ⬝1 `:75 := cube_concat1
|
||||
infix ` ⬝2 `:75 := cube_concat2
|
||||
infix ` ⬝3 `:75 := cube_concat3
|
||||
infix ` ⬝p1 `:75 := eq_concat1
|
||||
infix ` ⬝1p `:75 := concat1_eq
|
||||
infix ` ⬝p2 `:75 := eq_concat3
|
||||
infix ` ⬝2p `:75 := concat2_eq
|
||||
infix ` ⬝p3 `:75 := eq_concat3
|
||||
infix ` ⬝3p `:75 := concat3_eq
|
||||
|
||||
end eq
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Cubeovers
|
||||
-/
|
||||
|
||||
import .squareover .cube
|
||||
|
||||
open equiv is_equiv
|
||||
|
||||
namespace eq
|
||||
|
||||
-- we need to specify B explicitly, also in pathovers
|
||||
inductive cubeover {A : Type} (B : A → Type) {a₀₀₀ : A} {b₀₀₀ : B a₀₀₀}
|
||||
: Π{a₂₀₀ a₀₂₀ a₂₂₀ a₀₀₂ a₂₀₂ a₀₂₂ a₂₂₂ : A}
|
||||
{p₁₀₀ : a₀₀₀ = a₂₀₀} {p₀₁₀ : a₀₀₀ = a₀₂₀} {p₀₀₁ : a₀₀₀ = a₀₀₂}
|
||||
{p₁₂₀ : a₀₂₀ = a₂₂₀} {p₂₁₀ : a₂₀₀ = a₂₂₀} {p₂₀₁ : a₂₀₀ = a₂₀₂}
|
||||
{p₁₀₂ : a₀₀₂ = a₂₀₂} {p₀₁₂ : a₀₀₂ = a₀₂₂} {p₀₂₁ : a₀₂₀ = a₀₂₂}
|
||||
{p₁₂₂ : a₀₂₂ = a₂₂₂} {p₂₁₂ : a₂₀₂ = a₂₂₂} {p₂₂₁ : a₂₂₀ = a₂₂₂}
|
||||
{s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
|
||||
{s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
|
||||
{s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁}
|
||||
{s₂₁₁ : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
|
||||
{s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁}
|
||||
{s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂)
|
||||
{b₀₂₀ : B a₀₂₀} {b₂₀₀ : B a₂₀₀} {b₂₂₀ : B a₂₂₀}
|
||||
{b₀₀₂ : B a₀₀₂} {b₀₂₂ : B a₀₂₂} {b₂₀₂ : B a₂₀₂} {b₂₂₂ : B a₂₂₂}
|
||||
{q₁₀₀ : pathover B b₀₀₀ p₁₀₀ b₂₀₀} {q₀₁₀ : pathover B b₀₀₀ p₀₁₀ b₀₂₀}
|
||||
{q₀₀₁ : pathover B b₀₀₀ p₀₀₁ b₀₀₂} {q₁₂₀ : pathover B b₀₂₀ p₁₂₀ b₂₂₀}
|
||||
{q₂₁₀ : pathover B b₂₀₀ p₂₁₀ b₂₂₀} {q₂₀₁ : pathover B b₂₀₀ p₂₀₁ b₂₀₂}
|
||||
{q₁₀₂ : pathover B b₀₀₂ p₁₀₂ b₂₀₂} {q₀₁₂ : pathover B b₀₀₂ p₀₁₂ b₀₂₂}
|
||||
{q₀₂₁ : pathover B b₀₂₀ p₀₂₁ b₀₂₂} {q₁₂₂ : pathover B b₀₂₂ p₁₂₂ b₂₂₂}
|
||||
{q₂₁₂ : pathover B b₂₀₂ p₂₁₂ b₂₂₂} {q₂₂₁ : pathover B b₂₂₀ p₂₂₁ b₂₂₂}
|
||||
(t₀₁₁ : squareover B s₀₁₁ q₀₁₀ q₀₁₂ q₀₀₁ q₀₂₁)
|
||||
(t₂₁₁ : squareover B s₂₁₁ q₂₁₀ q₂₁₂ q₂₀₁ q₂₂₁)
|
||||
(t₁₀₁ : squareover B s₁₀₁ q₁₀₀ q₁₀₂ q₀₀₁ q₂₀₁)
|
||||
(t₁₂₁ : squareover B s₁₂₁ q₁₂₀ q₁₂₂ q₀₂₁ q₂₂₁)
|
||||
(t₁₁₀ : squareover B s₁₁₀ q₀₁₀ q₂₁₀ q₁₀₀ q₁₂₀)
|
||||
(t₁₁₂ : squareover B s₁₁₂ q₀₁₂ q₂₁₂ q₁₀₂ q₁₂₂), Type :=
|
||||
idcubeo : cubeover B idc idso idso idso idso idso idso
|
||||
|
||||
|
||||
|
||||
-- variables {A : Type} {a₀₀₀ a₂₀₀ a₀₂₀ a₂₂₀ a₀₀₂ a₂₀₂ a₀₂₂ a₂₂₂ : A}
|
||||
-- {p₁₀₀ : a₀₀₀ = a₂₀₀} {p₀₁₀ : a₀₀₀ = a₀₂₀} {p₀₀₁ : a₀₀₀ = a₀₀₂}
|
||||
-- {p₁₂₀ : a₀₂₀ = a₂₂₀} {p₂₁₀ : a₂₀₀ = a₂₂₀} {p₂₀₁ : a₂₀₀ = a₂₀₂}
|
||||
-- {p₁₀₂ : a₀₀₂ = a₂₀₂} {p₀₁₂ : a₀₀₂ = a₀₂₂} {p₀₂₁ : a₀₂₀ = a₀₂₂}
|
||||
-- {p₁₂₂ : a₀₂₂ = a₂₂₂} {p₂₁₂ : a₂₀₂ = a₂₂₂} {p₂₂₁ : a₂₂₀ = a₂₂₂}
|
||||
-- {s₁₁₀ : square p₀₁₀ p₂₁₀ p₁₀₀ p₁₂₀}
|
||||
-- {s₁₁₂ : square p₀₁₂ p₂₁₂ p₁₀₂ p₁₂₂}
|
||||
-- {s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ p₂₀₁}
|
||||
-- {s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ p₂₂₁}
|
||||
-- {s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁}
|
||||
-- {s₂₁₁ : square p₂₁₀ p₂₁₂ p₂₀₁ p₂₂₁}
|
||||
|
||||
end eq
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
types.cubical
|
||||
=============
|
||||
|
||||
Cubical Types:
|
||||
|
||||
The files [path](../init/path.hlean) and [pathover](../init/pathover.hlean) are in the [init/](../init/init.md) folder.
|
||||
|
||||
* [square](square.hlean): square in a type
|
||||
* [cube](cube.hlean): cube in a type
|
||||
* [squareover](squareover.hlean): square over a square
|
||||
* [cubeover](cubeover.hlean): cube over a cube
|
||||
|
||||
The following files are higher coherence laws between operators defined in the basic files
|
||||
* [pathover2](pathover2.hlean)
|
||||
* [square2](square2.hlean)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import .square .cube .squareover .cubeover
|
||||
|
|
@ -1,133 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Coherence conditions for operations on pathovers
|
||||
-/
|
||||
|
||||
open function equiv
|
||||
|
||||
namespace eq
|
||||
|
||||
variables {A A' A'' : Type} {B B' : A → Type} {B'' : A' → Type} {C : Π⦃a⦄, B a → Type}
|
||||
{a a₂ a₃ a₄ : A} {p p' p'' : a = a₂} {p₂ p₂' : a₂ = a₃} {p₃ : a₃ = a₄} {p₁₃ : a = a₃}
|
||||
{a' : A'}
|
||||
{b b' : B a} {b₂ b₂' : B a₂} {b₃ : B a₃} {b₄ : B a₄}
|
||||
{c : C b} {c₂ : C b₂}
|
||||
|
||||
definition pathover_ap_id (q : b =[p] b₂) : pathover_ap B id q = change_path (ap_id p)⁻¹ q :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition pathover_ap_compose (B : A'' → Type) (g : A' → A'') (f : A → A')
|
||||
{b : B (g (f a))} {b₂ : B (g (f a₂))} (q : b =[p] b₂) : pathover_ap B (g ∘ f) q
|
||||
= change_path (ap_compose g f p)⁻¹ (pathover_ap B g (pathover_ap (B ∘ g) f q)) :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition pathover_ap_compose_rev (B : A'' → Type) (g : A' → A'') (f : A → A')
|
||||
{b : B (g (f a))} {b₂ : B (g (f a₂))} (q : b =[p] b₂) :
|
||||
pathover_ap B g (pathover_ap (B ∘ g) f q)
|
||||
= change_path (ap_compose g f p) (pathover_ap B (g ∘ f) q) :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition pathover_of_tr_eq_idp (r : b = b') : pathover_of_tr_eq r = pathover_idp_of_eq r :=
|
||||
idp
|
||||
|
||||
definition pathover_of_tr_eq_eq_concato (r : p ▸ b = b₂)
|
||||
: pathover_of_tr_eq r = pathover_tr p b ⬝o pathover_idp_of_eq r :=
|
||||
by induction r; induction p; reflexivity
|
||||
|
||||
definition apd011_eq_apo11_apd (f : Πa, B a → A') (p : a = a₂) (q : b =[p] b₂)
|
||||
: apd011 f p q = apo11_constant_right (apd f p) q :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition change_path_con (q : p = p') (q' : p' = p'') (r : b =[p] b₂) :
|
||||
change_path (q ⬝ q') r = change_path q' (change_path q r) :=
|
||||
by induction q; induction q'; reflexivity
|
||||
|
||||
definition change_path_invo (q : p = p') (r : b =[p] b₂) :
|
||||
change_path (inverse2 q) r⁻¹ᵒ = (change_path q r)⁻¹ᵒ :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition change_path_cono (q : p = p') (q₂ : p₂ = p₂') (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃):
|
||||
change_path (q ◾ q₂) (r ⬝o r₂) = change_path q r ⬝o change_path q₂ r₂ :=
|
||||
by induction q; induction q₂; reflexivity
|
||||
|
||||
definition pathover_of_pathover_ap_invo (B' : A' → Type) (f : A → A')
|
||||
{b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[ap f p] b₂) :
|
||||
pathover_of_pathover_ap B' f (change_path (ap_inv f p)⁻¹ q⁻¹ᵒ) =
|
||||
(pathover_of_pathover_ap B' f q)⁻¹ᵒ:=
|
||||
by induction p; eapply idp_rec_on q; reflexivity
|
||||
|
||||
definition pathover_of_pathover_ap_cono (B' : A' → Type) (f : A → A')
|
||||
{b : B' (f a)} {b₂ : B' (f a₂)} {b₃ : B' (f a₃)} (q : b =[ap f p] b₂) (q₂ : b₂ =[ap f p₂] b₃) :
|
||||
pathover_of_pathover_ap B' f (change_path (ap_con f p p₂)⁻¹ (q ⬝o q₂)) =
|
||||
pathover_of_pathover_ap B' f q ⬝o pathover_of_pathover_ap B' f q₂ :=
|
||||
by induction p; induction p₂; eapply idp_rec_on q; eapply idp_rec_on q₂; reflexivity
|
||||
|
||||
definition pathover_ap_pathover_of_pathover_ap (P : A'' → Type) (g : A' → A'') (f : A → A')
|
||||
{p : a = a₂} {b : P (g (f a))} {b₂ : P (g (f a₂))} (q : b =[ap f p] b₂) :
|
||||
pathover_ap P (g ∘ f) (pathover_of_pathover_ap (P ∘ g) f q) =
|
||||
change_path (ap_compose g f p)⁻¹ (pathover_ap P g q) :=
|
||||
by induction p; eapply (idp_rec_on q); reflexivity
|
||||
|
||||
definition change_path_pathover_of_pathover_ap (B' : A' → Type) (f : A → A') {p p' : a = a₂}
|
||||
(r : p = p') {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[ap f p] b₂) :
|
||||
change_path r (pathover_of_pathover_ap B' f q) =
|
||||
pathover_of_pathover_ap B' f (change_path (ap02 f r) q) :=
|
||||
by induction r; reflexivity
|
||||
|
||||
definition pathover_ap_change_path (B' : A' → Type) (f : A → A') {p p' : a = a₂}
|
||||
(r : p = p') {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[p] b₂) :
|
||||
pathover_ap B' f (change_path r q) = change_path (ap02 f r) (pathover_ap B' f q) :=
|
||||
by induction r; reflexivity
|
||||
|
||||
definition change_path_equiv [constructor] (b : B a) (b₂ : B a₂) (q : p = p')
|
||||
: (b =[p] b₂) ≃ (b =[p'] b₂) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact change_path q},
|
||||
{ exact change_path q⁻¹},
|
||||
{ intro r, induction q, reflexivity},
|
||||
{ intro r, induction q, reflexivity},
|
||||
end
|
||||
|
||||
definition apd_ap {B : A' → Type} (g : Πb, B b) (f : A → A') (p : a = a₂)
|
||||
: apd g (ap f p) = pathover_ap B f (apd (λx, g (f x)) p) :=
|
||||
by induction p; reflexivity
|
||||
|
||||
definition apd_eq_apd_ap {B : A' → Type} (g : Πb, B b) (f : A → A') (p : a = a₂)
|
||||
: apd (λx, g (f x)) p = pathover_of_pathover_ap B f (apd g (ap f p)) :=
|
||||
by induction p; reflexivity
|
||||
|
||||
definition ap_compose_ap02_constant {A B C : Type} {a a' : A} (p : a = a') (b : B) (c : C) :
|
||||
ap_compose (λc, b) (λa, c) p ⬝ ap02 (λc, b) (ap_constant p c) = ap_constant p b :=
|
||||
by induction p; reflexivity
|
||||
|
||||
theorem apd_constant (b : B'' a') (p : a = a) :
|
||||
pathover_ap B'' (λa, a') (apd (λa, b) p) = change_path (ap_constant p a')⁻¹ idpo :=
|
||||
begin
|
||||
rewrite [apd_eq_apd_ap _ _ p],
|
||||
let y := !change_path_of_pathover (apd (apd id) (ap_constant p b))⁻¹ᵒ,
|
||||
rewrite -y, esimp,
|
||||
refine !pathover_ap_pathover_of_pathover_ap ⬝ _,
|
||||
rewrite pathover_ap_change_path,
|
||||
rewrite -change_path_con, apply ap (λx, change_path x idpo),
|
||||
unfold ap02, rewrite [ap_inv,-con_inv], apply inverse2,
|
||||
apply ap_compose_ap02_constant
|
||||
end
|
||||
|
||||
definition apd_change_path {B : A → Type} {a a₂ : A} (f : Πa, B a) {p p' : a = a₂} (s : p = p')
|
||||
: apd f p' = change_path s (apd f p) :=
|
||||
by induction s; reflexivity
|
||||
|
||||
definition cono_invo_eq_idpo {q q' : b =[p] b₂} (r : q = q')
|
||||
: change_path (con.right_inv p) (q ⬝o q'⁻¹ᵒ) = idpo :=
|
||||
by induction r; induction q; reflexivity
|
||||
|
||||
definition tr_eq_of_pathover_concato_eq {A : Type} {B : A → Type} {a a' : A} {p : a = a'}
|
||||
{b : B a} {b' b'' : B a'} (q : b =[p] b') (r : b' = b'') :
|
||||
tr_eq_of_pathover (q ⬝op r) = tr_eq_of_pathover q ⬝ r :=
|
||||
by induction r; reflexivity
|
||||
|
||||
end eq
|
||||
|
|
@ -1,636 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Jakob von Raumer
|
||||
|
||||
Squares in a type
|
||||
-/
|
||||
import types.eq
|
||||
open eq equiv is_equiv sigma
|
||||
|
||||
namespace eq
|
||||
|
||||
variables {A B : Type} {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ a₁ a₂ a₃ a₄ : A}
|
||||
/-a₀₀-/ {p₁₀ p₁₀' : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
|
||||
{p₀₁ p₀₁' : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ p₂₁' : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
|
||||
/-a₀₂-/ {p₁₂ p₁₂' : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
|
||||
{p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
|
||||
/-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
|
||||
|
||||
|
||||
inductive square {A : Type} {a₀₀ : A}
|
||||
: Π{a₂₀ a₀₂ a₂₂ : A}, a₀₀ = a₂₀ → a₀₂ = a₂₂ → a₀₀ = a₀₂ → a₂₀ = a₂₂ → Type :=
|
||||
ids : square idp idp idp idp
|
||||
/- square top bottom left right -/
|
||||
|
||||
variables {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁} {s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁}
|
||||
{s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃} {s₃₃ : square p₃₂ p₃₄ p₂₃ p₄₃}
|
||||
|
||||
definition ids [reducible] [constructor] := @square.ids
|
||||
definition idsquare [reducible] [constructor] (a : A) := @square.ids A a
|
||||
|
||||
definition hrefl [unfold 4] (p : a = a') : square idp idp p p :=
|
||||
by induction p; exact ids
|
||||
|
||||
definition vrefl [unfold 4] (p : a = a') : square p p idp idp :=
|
||||
by induction p; exact ids
|
||||
|
||||
definition hrfl [reducible] [unfold 4] {p : a = a'} : square idp idp p p :=
|
||||
!hrefl
|
||||
definition vrfl [reducible] [unfold 4] {p : a = a'} : square p p idp idp :=
|
||||
!vrefl
|
||||
|
||||
definition hdeg_square [unfold 6] {p q : a = a'} (r : p = q) : square idp idp p q :=
|
||||
by induction r;apply hrefl
|
||||
|
||||
definition vdeg_square [unfold 6] {p q : a = a'} (r : p = q) : square p q idp idp :=
|
||||
by induction r;apply vrefl
|
||||
|
||||
definition hdeg_square_idp (p : a = a') : hdeg_square (refl p) = hrfl :=
|
||||
by reflexivity
|
||||
|
||||
definition vdeg_square_idp (p : a = a') : vdeg_square (refl p) = vrfl :=
|
||||
by reflexivity
|
||||
|
||||
definition hconcat [unfold 16] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁)
|
||||
: square (p₁₀ ⬝ p₃₀) (p₁₂ ⬝ p₃₂) p₀₁ p₄₁ :=
|
||||
by induction s₃₁; exact s₁₁
|
||||
|
||||
definition vconcat [unfold 16] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃)
|
||||
: square p₁₀ p₁₄ (p₀₁ ⬝ p₀₃) (p₂₁ ⬝ p₂₃) :=
|
||||
by induction s₁₃; exact s₁₁
|
||||
|
||||
definition dconcat [unfold 14] {p₀₀ : a₀₀ = a} {p₂₂ : a = a₂₂}
|
||||
(s₂₁ : square p₀₀ p₁₂ p₀₁ p₂₂) (s₁₂ : square p₁₀ p₂₂ p₀₀ p₂₁) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction s₁₂; exact s₂₁
|
||||
|
||||
definition hinverse [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) : square p₁₀⁻¹ p₁₂⁻¹ p₂₁ p₀₁ :=
|
||||
by induction s₁₁;exact ids
|
||||
|
||||
definition vinverse [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) : square p₁₂ p₁₀ p₀₁⁻¹ p₂₁⁻¹ :=
|
||||
by induction s₁₁;exact ids
|
||||
|
||||
definition eq_vconcat [unfold 11] {p : a₀₀ = a₂₀} (r : p = p₁₀) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) :
|
||||
square p p₁₂ p₀₁ p₂₁ :=
|
||||
by induction r; exact s₁₁
|
||||
|
||||
definition vconcat_eq [unfold 12] {p : a₀₂ = a₂₂} (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₁₂ = p) :
|
||||
square p₁₀ p p₀₁ p₂₁ :=
|
||||
by induction r; exact s₁₁
|
||||
|
||||
definition eq_hconcat [unfold 11] {p : a₀₀ = a₀₂} (r : p = p₀₁) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) :
|
||||
square p₁₀ p₁₂ p p₂₁ :=
|
||||
by induction r; exact s₁₁
|
||||
|
||||
definition hconcat_eq [unfold 12] {p : a₂₀ = a₂₂} (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₂₁ = p) :
|
||||
square p₁₀ p₁₂ p₀₁ p :=
|
||||
by induction r; exact s₁₁
|
||||
|
||||
infix ` ⬝h `:69 := hconcat --type using \tr
|
||||
infix ` ⬝v `:70 := vconcat --type using \tr
|
||||
infix ` ⬝hp `:71 := hconcat_eq --type using \tr
|
||||
infix ` ⬝vp `:73 := vconcat_eq --type using \tr
|
||||
infix ` ⬝ph `:72 := eq_hconcat --type using \tr
|
||||
infix ` ⬝pv `:74 := eq_vconcat --type using \tr
|
||||
postfix `⁻¹ʰ`:(max+1) := hinverse --type using \-1h
|
||||
postfix `⁻¹ᵛ`:(max+1) := vinverse --type using \-1v
|
||||
|
||||
definition transpose [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) : square p₀₁ p₂₁ p₁₀ p₁₂ :=
|
||||
by induction s₁₁;exact ids
|
||||
|
||||
definition aps [unfold 12] (f : A → B) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square (ap f p₁₀) (ap f p₁₂) (ap f p₀₁) (ap f p₂₁) :=
|
||||
by induction s₁₁;exact ids
|
||||
|
||||
/- canceling, whiskering and moving thinks along the sides of the square -/
|
||||
definition whisker_tl (p : a = a₀₀) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square (p ⬝ p₁₀) p₁₂ (p ⬝ p₀₁) p₂₁ :=
|
||||
by induction s₁₁;induction p;constructor
|
||||
|
||||
definition whisker_br (p : a₂₂ = a) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square p₁₀ (p₁₂ ⬝ p) p₀₁ (p₂₁ ⬝ p) :=
|
||||
by induction p;exact s₁₁
|
||||
|
||||
definition whisker_rt (p : a = a₂₀) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square (p₁₀ ⬝ p⁻¹) p₁₂ p₀₁ (p ⬝ p₂₁) :=
|
||||
by induction s₁₁;induction p;constructor
|
||||
|
||||
definition whisker_tr (p : a₂₀ = a) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square (p₁₀ ⬝ p) p₁₂ p₀₁ (p⁻¹ ⬝ p₂₁) :=
|
||||
by induction s₁₁;induction p;constructor
|
||||
|
||||
definition whisker_bl (p : a = a₀₂) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square p₁₀ (p ⬝ p₁₂) (p₀₁ ⬝ p⁻¹) p₂₁ :=
|
||||
by induction s₁₁;induction p;constructor
|
||||
|
||||
definition whisker_lb (p : a₀₂ = a) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square p₁₀ (p⁻¹ ⬝ p₁₂) (p₀₁ ⬝ p) p₂₁ :=
|
||||
by induction s₁₁;induction p;constructor
|
||||
|
||||
definition cancel_tl (p : a = a₀₀) (s₁₁ : square (p ⬝ p₁₀) p₁₂ (p ⬝ p₀₁) p₂₁)
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p; rewrite +idp_con at s₁₁; exact s₁₁
|
||||
|
||||
definition cancel_br (p : a₂₂ = a) (s₁₁ : square p₁₀ (p₁₂ ⬝ p) p₀₁ (p₂₁ ⬝ p))
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p;exact s₁₁
|
||||
|
||||
definition cancel_rt (p : a = a₂₀) (s₁₁ : square (p₁₀ ⬝ p⁻¹) p₁₂ p₀₁ (p ⬝ p₂₁))
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p; rewrite idp_con at s₁₁; exact s₁₁
|
||||
|
||||
definition cancel_tr (p : a₂₀ = a) (s₁₁ : square (p₁₀ ⬝ p) p₁₂ p₀₁ (p⁻¹ ⬝ p₂₁))
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p; rewrite [▸* at s₁₁,idp_con at s₁₁]; exact s₁₁
|
||||
|
||||
definition cancel_bl (p : a = a₀₂) (s₁₁ : square p₁₀ (p ⬝ p₁₂) (p₀₁ ⬝ p⁻¹) p₂₁)
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p; rewrite idp_con at s₁₁; exact s₁₁
|
||||
|
||||
definition cancel_lb (p : a₀₂ = a) (s₁₁ : square p₁₀ (p⁻¹ ⬝ p₁₂) (p₀₁ ⬝ p) p₂₁)
|
||||
: square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p; rewrite [▸* at s₁₁,idp_con at s₁₁]; exact s₁₁
|
||||
|
||||
definition move_top_of_left {p : a₀₀ = a} {q : a = a₀₂} (s : square p₁₀ p₁₂ (p ⬝ q) p₂₁)
|
||||
: square (p⁻¹ ⬝ p₁₀) p₁₂ q p₂₁ :=
|
||||
by apply cancel_tl p; rewrite con_inv_cancel_left; exact s
|
||||
|
||||
definition move_top_of_left' {p : a = a₀₀} {q : a = a₀₂} (s : square p₁₀ p₁₂ (p⁻¹ ⬝ q) p₂₁)
|
||||
: square (p ⬝ p₁₀) p₁₂ q p₂₁ :=
|
||||
by apply cancel_tl p⁻¹; rewrite inv_con_cancel_left; exact s
|
||||
|
||||
definition move_left_of_top {p : a₀₀ = a} {q : a = a₂₀} (s : square (p ⬝ q) p₁₂ p₀₁ p₂₁)
|
||||
: square q p₁₂ (p⁻¹ ⬝ p₀₁) p₂₁ :=
|
||||
by apply cancel_tl p; rewrite con_inv_cancel_left; exact s
|
||||
|
||||
definition move_left_of_top' {p : a = a₀₀} {q : a = a₂₀} (s : square (p⁻¹ ⬝ q) p₁₂ p₀₁ p₂₁)
|
||||
: square q p₁₂ (p ⬝ p₀₁) p₂₁ :=
|
||||
by apply cancel_tl p⁻¹; rewrite inv_con_cancel_left; exact s
|
||||
|
||||
definition move_bot_of_right {p : a₂₀ = a} {q : a = a₂₂} (s : square p₁₀ p₁₂ p₀₁ (p ⬝ q))
|
||||
: square p₁₀ (p₁₂ ⬝ q⁻¹) p₀₁ p :=
|
||||
by apply cancel_br q; rewrite inv_con_cancel_right; exact s
|
||||
|
||||
definition move_bot_of_right' {p : a₂₀ = a} {q : a₂₂ = a} (s : square p₁₀ p₁₂ p₀₁ (p ⬝ q⁻¹))
|
||||
: square p₁₀ (p₁₂ ⬝ q) p₀₁ p :=
|
||||
by apply cancel_br q⁻¹; rewrite con_inv_cancel_right; exact s
|
||||
|
||||
definition move_right_of_bot {p : a₀₂ = a} {q : a = a₂₂} (s : square p₁₀ (p ⬝ q) p₀₁ p₂₁)
|
||||
: square p₁₀ p p₀₁ (p₂₁ ⬝ q⁻¹) :=
|
||||
by apply cancel_br q; rewrite inv_con_cancel_right; exact s
|
||||
|
||||
definition move_right_of_bot' {p : a₀₂ = a} {q : a₂₂ = a} (s : square p₁₀ (p ⬝ q⁻¹) p₀₁ p₂₁)
|
||||
: square p₁₀ p p₀₁ (p₂₁ ⬝ q) :=
|
||||
by apply cancel_br q⁻¹; rewrite con_inv_cancel_right; exact s
|
||||
|
||||
definition move_top_of_right {p : a₂₀ = a} {q : a = a₂₂} (s : square p₁₀ p₁₂ p₀₁ (p ⬝ q))
|
||||
: square (p₁₀ ⬝ p) p₁₂ p₀₁ q :=
|
||||
by apply cancel_rt p; rewrite con_inv_cancel_right; exact s
|
||||
|
||||
definition move_right_of_top {p : a₀₀ = a} {q : a = a₂₀} (s : square (p ⬝ q) p₁₂ p₀₁ p₂₁)
|
||||
: square p p₁₂ p₀₁ (q ⬝ p₂₁) :=
|
||||
by apply cancel_tr q; rewrite inv_con_cancel_left; exact s
|
||||
|
||||
definition move_bot_of_left {p : a₀₀ = a} {q : a = a₀₂} (s : square p₁₀ p₁₂ (p ⬝ q) p₂₁)
|
||||
: square p₁₀ (q ⬝ p₁₂) p p₂₁ :=
|
||||
by apply cancel_lb q; rewrite inv_con_cancel_left; exact s
|
||||
|
||||
definition move_left_of_bot {p : a₀₂ = a} {q : a = a₂₂} (s : square p₁₀ (p ⬝ q) p₀₁ p₂₁)
|
||||
: square p₁₀ q (p₀₁ ⬝ p) p₂₁ :=
|
||||
by apply cancel_bl p; rewrite con_inv_cancel_right; exact s
|
||||
|
||||
/- some higher ∞-groupoid operations -/
|
||||
|
||||
definition vconcat_vrfl (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: s₁₁ ⬝v vrefl p₁₂ = s₁₁ :=
|
||||
by induction s₁₁; reflexivity
|
||||
|
||||
definition hconcat_hrfl (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: s₁₁ ⬝h hrefl p₂₁ = s₁₁ :=
|
||||
by induction s₁₁; reflexivity
|
||||
|
||||
/- equivalences -/
|
||||
|
||||
definition eq_of_square [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂ :=
|
||||
by induction s₁₁; apply idp
|
||||
|
||||
definition square_of_eq (r : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p₁₂; esimp at r; induction r; induction p₂₁; induction p₁₀; exact ids
|
||||
|
||||
definition eq_top_of_square [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: p₁₀ = p₀₁ ⬝ p₁₂ ⬝ p₂₁⁻¹ :=
|
||||
by induction s₁₁; apply idp
|
||||
|
||||
definition square_of_eq_top (r : p₁₀ = p₀₁ ⬝ p₁₂ ⬝ p₂₁⁻¹) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p₂₁; induction p₁₂; esimp at r;induction r;induction p₁₀;exact ids
|
||||
|
||||
definition eq_bot_of_square [unfold 10] (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: p₁₂ = p₀₁⁻¹ ⬝ p₁₀ ⬝ p₂₁ :=
|
||||
by induction s₁₁; apply idp
|
||||
|
||||
definition square_of_eq_bot (r : p₀₁⁻¹ ⬝ p₁₀ ⬝ p₂₁ = p₁₂) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p₂₁; induction p₁₀; esimp at r; induction r; induction p₀₁; exact ids
|
||||
|
||||
definition square_equiv_eq [constructor] (t : a₀₀ = a₀₂) (b : a₂₀ = a₂₂)
|
||||
(l : a₀₀ = a₂₀) (r : a₀₂ = a₂₂) : square t b l r ≃ t ⬝ r = l ⬝ b :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact eq_of_square},
|
||||
{ exact square_of_eq},
|
||||
{ intro s, induction b, esimp [concat] at s, induction s, induction r, induction t, apply idp},
|
||||
{ intro s, induction s, apply idp},
|
||||
end
|
||||
|
||||
definition hdeg_square_equiv' [constructor] (p q : a = a') : square idp idp p q ≃ p = q :=
|
||||
by transitivity _;apply square_equiv_eq;transitivity _;apply eq_equiv_eq_symm;
|
||||
apply equiv_eq_closed_right;apply idp_con
|
||||
|
||||
definition vdeg_square_equiv' [constructor] (p q : a = a') : square p q idp idp ≃ p = q :=
|
||||
by transitivity _;apply square_equiv_eq;apply equiv_eq_closed_right; apply idp_con
|
||||
|
||||
definition eq_of_hdeg_square [reducible] {p q : a = a'} (s : square idp idp p q) : p = q :=
|
||||
to_fun !hdeg_square_equiv' s
|
||||
|
||||
definition eq_of_vdeg_square [reducible] {p q : a = a'} (s : square p q idp idp) : p = q :=
|
||||
to_fun !vdeg_square_equiv' s
|
||||
|
||||
definition top_deg_square (l : a₁ = a₂) (b : a₂ = a₃) (r : a₄ = a₃)
|
||||
: square (l ⬝ b ⬝ r⁻¹) b l r :=
|
||||
by induction r;induction b;induction l;constructor
|
||||
|
||||
definition bot_deg_square (l : a₁ = a₂) (t : a₁ = a₃) (r : a₃ = a₄)
|
||||
: square t (l⁻¹ ⬝ t ⬝ r) l r :=
|
||||
by induction r;induction t;induction l;constructor
|
||||
|
||||
/-
|
||||
the following two equivalences have as underlying inverse function the functions
|
||||
hdeg_square and vdeg_square, respectively.
|
||||
See example below the definition
|
||||
-/
|
||||
definition hdeg_square_equiv [constructor] (p q : a = a') :
|
||||
square idp idp p q ≃ p = q :=
|
||||
begin
|
||||
fapply equiv_change_fun,
|
||||
{ fapply equiv_change_inv, apply hdeg_square_equiv', exact hdeg_square,
|
||||
intro s, induction s, induction p, reflexivity},
|
||||
{ exact eq_of_hdeg_square},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition vdeg_square_equiv [constructor] (p q : a = a') :
|
||||
square p q idp idp ≃ p = q :=
|
||||
begin
|
||||
fapply equiv_change_fun,
|
||||
{ fapply equiv_change_inv, apply vdeg_square_equiv',exact vdeg_square,
|
||||
intro s, induction s, induction p, reflexivity},
|
||||
{ exact eq_of_vdeg_square},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
example (p q : a = a') : to_inv (hdeg_square_equiv p q) = hdeg_square := idp
|
||||
|
||||
/-
|
||||
characterization of pathovers in a equality type. The type B of the equality is fixed here.
|
||||
A version where B may also varies over the path p is given in the file squareover
|
||||
-/
|
||||
|
||||
definition eq_pathover [unfold 7] {f g : A → B} {p : a = a'} {q : f a = g a} {r : f a' = g a'}
|
||||
(s : square q r (ap f p) (ap g p)) : q =[p] r :=
|
||||
begin induction p, apply pathover_idp_of_eq, exact eq_of_vdeg_square s end
|
||||
|
||||
definition eq_pathover_constant_left {g : A → B} {p : a = a'} {b : B} {q : b = g a} {r : b = g a'}
|
||||
(s : square q r idp (ap g p)) : q =[p] r :=
|
||||
eq_pathover (ap_constant p b ⬝ph s)
|
||||
|
||||
definition eq_pathover_id_left {g : A → A} {p : a = a'} {q : a = g a} {r : a' = g a'}
|
||||
(s : square q r p (ap g p)) : q =[p] r :=
|
||||
eq_pathover (ap_id p ⬝ph s)
|
||||
|
||||
definition eq_pathover_constant_right {f : A → B} {p : a = a'} {b : B} {q : f a = b} {r : f a' = b}
|
||||
(s : square q r (ap f p) idp) : q =[p] r :=
|
||||
eq_pathover (s ⬝hp (ap_constant p b)⁻¹)
|
||||
|
||||
definition eq_pathover_id_right {f : A → A} {p : a = a'} {q : f a = a} {r : f a' = a'}
|
||||
(s : square q r (ap f p) p) : q =[p] r :=
|
||||
eq_pathover (s ⬝hp (ap_id p)⁻¹)
|
||||
|
||||
definition square_of_pathover [unfold 7]
|
||||
{f g : A → B} {p : a = a'} {q : f a = g a} {r : f a' = g a'}
|
||||
(s : q =[p] r) : square q r (ap f p) (ap g p) :=
|
||||
by induction p;apply vdeg_square;exact eq_of_pathover_idp s
|
||||
|
||||
definition eq_pathover_constant_left_id_right {p : a = a'} {a₀ : A} {q : a₀ = a} {r : a₀ = a'}
|
||||
(s : square q r idp p) : q =[p] r :=
|
||||
eq_pathover (ap_constant p a₀ ⬝ph s ⬝hp (ap_id p)⁻¹)
|
||||
|
||||
definition eq_pathover_id_left_constant_right {p : a = a'} {a₀ : A} {q : a = a₀} {r : a' = a₀}
|
||||
(s : square q r p idp) : q =[p] r :=
|
||||
eq_pathover (ap_id p ⬝ph s ⬝hp (ap_constant p a₀)⁻¹)
|
||||
|
||||
definition loop_pathover {p : a = a'} {q : a = a} {r : a' = a'} (s : square q r p p) : q =[p] r :=
|
||||
eq_pathover (ap_id p ⬝ph s ⬝hp (ap_id p)⁻¹)
|
||||
|
||||
/- interaction of equivalences with operations on squares -/
|
||||
|
||||
definition eq_pathover_equiv_square [constructor] {f g : A → B}
|
||||
(p : a = a') (q : f a = g a) (r : f a' = g a') : q =[p] r ≃ square q r (ap f p) (ap g p) :=
|
||||
equiv.MK square_of_pathover
|
||||
eq_pathover
|
||||
begin
|
||||
intro s, induction p, esimp [square_of_pathover,eq_pathover],
|
||||
exact ap vdeg_square (to_right_inv !pathover_idp (eq_of_vdeg_square s))
|
||||
⬝ to_left_inv !vdeg_square_equiv s
|
||||
end
|
||||
begin
|
||||
intro s, induction p, esimp [square_of_pathover,eq_pathover],
|
||||
exact ap pathover_idp_of_eq (to_right_inv !vdeg_square_equiv (eq_of_pathover_idp s))
|
||||
⬝ to_left_inv !pathover_idp s
|
||||
end
|
||||
|
||||
definition square_of_pathover_eq_concato {f g : A → B} {p : a = a'} {q q' : f a = g a}
|
||||
{r : f a' = g a'} (s' : q = q') (s : q' =[p] r)
|
||||
: square_of_pathover (s' ⬝po s) = s' ⬝pv square_of_pathover s :=
|
||||
by induction s;induction s';reflexivity
|
||||
|
||||
definition square_of_pathover_concato_eq {f g : A → B} {p : a = a'} {q : f a = g a}
|
||||
{r r' : f a' = g a'} (s' : r = r') (s : q =[p] r)
|
||||
: square_of_pathover (s ⬝op s') = square_of_pathover s ⬝vp s' :=
|
||||
by induction s;induction s';reflexivity
|
||||
|
||||
definition square_of_pathover_concato {f g : A → B} {p : a = a'} {p' : a' = a''} {q : f a = g a}
|
||||
{q' : f a' = g a'} {q'' : f a'' = g a''} (s : q =[p] q') (s' : q' =[p'] q'')
|
||||
: square_of_pathover (s ⬝o s')
|
||||
= ap_con f p p' ⬝ph (square_of_pathover s ⬝v square_of_pathover s') ⬝hp (ap_con g p p')⁻¹ :=
|
||||
by induction s';induction s;esimp [ap_con,hconcat_eq];exact !vconcat_vrfl⁻¹
|
||||
|
||||
definition eq_of_square_hrfl [unfold 4] (p : a = a') : eq_of_square hrfl = idp_con p :=
|
||||
by induction p;reflexivity
|
||||
|
||||
definition eq_of_square_vrfl [unfold 4] (p : a = a') : eq_of_square vrfl = (idp_con p)⁻¹ :=
|
||||
by induction p;reflexivity
|
||||
|
||||
definition eq_of_square_hdeg_square {p q : a = a'} (r : p = q)
|
||||
: eq_of_square (hdeg_square r) = !idp_con ⬝ r⁻¹ :=
|
||||
by induction r;induction p;reflexivity
|
||||
|
||||
definition eq_of_square_vdeg_square {p q : a = a'} (r : p = q)
|
||||
: eq_of_square (vdeg_square r) = r ⬝ !idp_con⁻¹ :=
|
||||
by induction r;induction p;reflexivity
|
||||
|
||||
definition eq_of_square_eq_vconcat {p : a₀₀ = a₂₀} (r : p = p₁₀) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: eq_of_square (r ⬝pv s₁₁) = whisker_right p₂₁ r ⬝ eq_of_square s₁₁ :=
|
||||
by induction s₁₁;cases r;reflexivity
|
||||
|
||||
definition eq_of_square_eq_hconcat {p : a₀₀ = a₀₂} (r : p = p₀₁) (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: eq_of_square (r ⬝ph s₁₁) = eq_of_square s₁₁ ⬝ (whisker_right p₁₂ r)⁻¹ :=
|
||||
by induction r;reflexivity
|
||||
|
||||
definition eq_of_square_vconcat_eq {p : a₀₂ = a₂₂} (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₁₂ = p)
|
||||
: eq_of_square (s₁₁ ⬝vp r) = eq_of_square s₁₁ ⬝ whisker_left p₀₁ r :=
|
||||
by induction r;reflexivity
|
||||
|
||||
definition eq_of_square_hconcat_eq {p : a₂₀ = a₂₂} (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₂₁ = p)
|
||||
: eq_of_square (s₁₁ ⬝hp r) = (whisker_left p₁₀ r)⁻¹ ⬝ eq_of_square s₁₁ :=
|
||||
by induction s₁₁; induction r;reflexivity
|
||||
|
||||
definition change_path_eq_pathover {A B : Type} {a a' : A} {f g : A → B}
|
||||
{p p' : a = a'} (r : p = p')
|
||||
{q : f a = g a} {q' : f a' = g a'}
|
||||
(s : square q q' (ap f p) (ap g p)) :
|
||||
change_path r (eq_pathover s) = eq_pathover ((ap02 f r)⁻¹ ⬝ph s ⬝hp (ap02 g r)) :=
|
||||
by induction r; reflexivity
|
||||
|
||||
definition eq_hconcat_hdeg_square {A : Type} {a a' : A} {p₁ p₂ p₃ : a = a'} (q₁ : p₁ = p₂)
|
||||
(q₂ : p₂ = p₃) : q₁ ⬝ph hdeg_square q₂ = hdeg_square (q₁ ⬝ q₂) :=
|
||||
by induction q₁; induction q₂; reflexivity
|
||||
|
||||
definition hdeg_square_hconcat_eq {A : Type} {a a' : A} {p₁ p₂ p₃ : a = a'} (q₁ : p₁ = p₂)
|
||||
(q₂ : p₂ = p₃) : hdeg_square q₁ ⬝hp q₂ = hdeg_square (q₁ ⬝ q₂) :=
|
||||
by induction q₁; induction q₂; reflexivity
|
||||
|
||||
definition eq_hconcat_eq_hdeg_square {A : Type} {a a' : A} {p₁ p₂ p₃ p₄ : a = a'} (q₁ : p₁ = p₂)
|
||||
(q₂ : p₂ = p₃) (q₃ : p₃ = p₄) : q₁ ⬝ph hdeg_square q₂ ⬝hp q₃ = hdeg_square (q₁ ⬝ q₂ ⬝ q₃) :=
|
||||
by induction q₃; apply eq_hconcat_hdeg_square
|
||||
|
||||
-- definition vconcat_eq [unfold 11] {p : a₀₂ = a₂₂} (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₁₂ = p) :
|
||||
-- square p₁₀ p p₀₁ p₂₁ :=
|
||||
-- by induction r; exact s₁₁
|
||||
|
||||
-- definition eq_hconcat [unfold 11] {p : a₀₀ = a₀₂} (r : p = p₀₁)
|
||||
-- (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) : square p₁₀ p₁₂ p p₂₁ :=
|
||||
-- by induction r; exact s₁₁
|
||||
|
||||
-- definition hconcat_eq [unfold 11] {p : a₂₀ = a₂₂}
|
||||
-- (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) (r : p₂₁ = p) : square p₁₀ p₁₂ p₀₁ p :=
|
||||
-- by induction r; exact s₁₁
|
||||
|
||||
|
||||
-- the following definition is very slow, maybe it's interesting to see why?
|
||||
-- definition eq_pathover_equiv_square' {f g : A → B}(p : a = a') (q : f a = g a) (r : f a' = g a')
|
||||
-- : square q r (ap f p) (ap g p) ≃ q =[p] r :=
|
||||
-- equiv.MK eq_pathover
|
||||
-- square_of_pathover
|
||||
-- (λs, begin
|
||||
-- induction p, rewrite [↑[square_of_pathover,eq_pathover],
|
||||
-- to_right_inv !vdeg_square_equiv (eq_of_pathover_idp s),
|
||||
-- to_left_inv !pathover_idp s]
|
||||
-- end)
|
||||
-- (λs, begin
|
||||
-- induction p, rewrite [↑[square_of_pathover,eq_pathover],▸*,
|
||||
-- to_right_inv !(@pathover_idp A) (eq_of_vdeg_square s),
|
||||
-- to_left_inv !vdeg_square_equiv s]
|
||||
-- end)
|
||||
|
||||
/- recursors for squares where some sides are reflexivity -/
|
||||
|
||||
definition rec_on_b [recursor] {a₀₀ : A}
|
||||
{P : Π{a₂₀ a₁₂ : A} {t : a₀₀ = a₂₀} {l : a₀₀ = a₁₂} {r : a₂₀ = a₁₂}, square t idp l r → Type}
|
||||
{a₂₀ a₁₂ : A} {t : a₀₀ = a₂₀} {l : a₀₀ = a₁₂} {r : a₂₀ = a₁₂}
|
||||
(s : square t idp l r) (H : P ids) : P s :=
|
||||
have H2 : P (square_of_eq (eq_of_square s)),
|
||||
from eq.rec_on (eq_of_square s : t ⬝ r = l) (by induction r; induction t; exact H),
|
||||
left_inv (to_fun !square_equiv_eq) s ▸ H2
|
||||
|
||||
definition rec_on_r [recursor] {a₀₀ : A}
|
||||
{P : Π{a₀₂ a₂₁ : A} {t : a₀₀ = a₂₁} {b : a₀₂ = a₂₁} {l : a₀₀ = a₀₂}, square t b l idp → Type}
|
||||
{a₀₂ a₂₁ : A} {t : a₀₀ = a₂₁} {b : a₀₂ = a₂₁} {l : a₀₀ = a₀₂}
|
||||
(s : square t b l idp) (H : P ids) : P s :=
|
||||
let p : l ⬝ b = t := (eq_of_square s)⁻¹ in
|
||||
have H2 : P (square_of_eq (eq_of_square s)⁻¹⁻¹),
|
||||
from @eq.rec_on _ _ (λx p, P (square_of_eq p⁻¹)) _ p (by induction b; induction l; exact H),
|
||||
left_inv (to_fun !square_equiv_eq) s ▸ !inv_inv ▸ H2
|
||||
|
||||
definition rec_on_l [recursor] {a₀₁ : A}
|
||||
{P : Π {a₂₀ a₂₂ : A} {t : a₀₁ = a₂₀} {b : a₀₁ = a₂₂} {r : a₂₀ = a₂₂},
|
||||
square t b idp r → Type}
|
||||
{a₂₀ a₂₂ : A} {t : a₀₁ = a₂₀} {b : a₀₁ = a₂₂} {r : a₂₀ = a₂₂}
|
||||
(s : square t b idp r) (H : P ids) : P s :=
|
||||
let p : t ⬝ r = b := eq_of_square s ⬝ !idp_con in
|
||||
have H2 : P (square_of_eq (p ⬝ !idp_con⁻¹)),
|
||||
from eq.rec_on p (by induction r; induction t; exact H),
|
||||
left_inv (to_fun !square_equiv_eq) s ▸ !con_inv_cancel_right ▸ H2
|
||||
|
||||
definition rec_on_t [recursor] {a₁₀ : A}
|
||||
{P : Π {a₀₂ a₂₂ : A} {b : a₀₂ = a₂₂} {l : a₁₀ = a₀₂} {r : a₁₀ = a₂₂}, square idp b l r → Type}
|
||||
{a₀₂ a₂₂ : A} {b : a₀₂ = a₂₂} {l : a₁₀ = a₀₂} {r : a₁₀ = a₂₂}
|
||||
(s : square idp b l r) (H : P ids) : P s :=
|
||||
let p : l ⬝ b = r := (eq_of_square s)⁻¹ ⬝ !idp_con in
|
||||
have H2 : P (square_of_eq ((p ⬝ !idp_con⁻¹)⁻¹)),
|
||||
from eq.rec_on p (by induction b; induction l; exact H),
|
||||
have H3 : P (square_of_eq ((eq_of_square s)⁻¹⁻¹)),
|
||||
from eq.rec_on !con_inv_cancel_right H2,
|
||||
have H4 : P (square_of_eq (eq_of_square s)),
|
||||
from eq.rec_on !inv_inv H3,
|
||||
proof
|
||||
left_inv (to_fun !square_equiv_eq) s ▸ H4
|
||||
qed
|
||||
|
||||
definition rec_on_tb [recursor] {a : A}
|
||||
{P : Π{b : A} {l : a = b} {r : a = b}, square idp idp l r → Type}
|
||||
{b : A} {l : a = b} {r : a = b}
|
||||
(s : square idp idp l r) (H : P ids) : P s :=
|
||||
have H2 : P (square_of_eq (eq_of_square s)),
|
||||
from eq.rec_on (eq_of_square s : idp ⬝ r = l) (by induction r; exact H),
|
||||
left_inv (to_fun !square_equiv_eq) s ▸ H2
|
||||
|
||||
definition rec_on_lr [recursor] {a : A}
|
||||
{P : Π{a' : A} {t : a = a'} {b : a = a'}, square t b idp idp → Type}
|
||||
{a' : A} {t : a = a'} {b : a = a'}
|
||||
(s : square t b idp idp) (H : P ids) : P s :=
|
||||
let p : idp ⬝ b = t := (eq_of_square s)⁻¹ in
|
||||
have H2 : P (square_of_eq (eq_of_square s)⁻¹⁻¹),
|
||||
from @eq.rec_on _ _ (λx q, P (square_of_eq q⁻¹)) _ p (by induction b; exact H),
|
||||
to_left_inv (!square_equiv_eq) s ▸ !inv_inv ▸ H2
|
||||
|
||||
--we can also do the other recursors (tl, tr, bl, br, tbl, tbr, tlr, blr), but let's postpone this until they are needed
|
||||
|
||||
definition whisker_square [unfold 14 15 16 17] (r₁₀ : p₁₀ = p₁₀') (r₁₂ : p₁₂ = p₁₂')
|
||||
(r₀₁ : p₀₁ = p₀₁') (r₂₁ : p₂₁ = p₂₁') (s : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: square p₁₀' p₁₂' p₀₁' p₂₁' :=
|
||||
by induction r₁₀; induction r₁₂; induction r₀₁; induction r₂₁; exact s
|
||||
|
||||
/- squares commute with some operations on 2-paths -/
|
||||
|
||||
definition square_inv2 {p₁ p₂ p₃ p₄ : a = a'}
|
||||
{t : p₁ = p₂} {b : p₃ = p₄} {l : p₁ = p₃} {r : p₂ = p₄} (s : square t b l r)
|
||||
: square (inverse2 t) (inverse2 b) (inverse2 l) (inverse2 r) :=
|
||||
by induction s;constructor
|
||||
|
||||
definition square_con2 {p₁ p₂ p₃ p₄ : a₁ = a₂} {q₁ q₂ q₃ q₄ : a₂ = a₃}
|
||||
{t₁ : p₁ = p₂} {b₁ : p₃ = p₄} {l₁ : p₁ = p₃} {r₁ : p₂ = p₄}
|
||||
{t₂ : q₁ = q₂} {b₂ : q₃ = q₄} {l₂ : q₁ = q₃} {r₂ : q₂ = q₄}
|
||||
(s₁ : square t₁ b₁ l₁ r₁) (s₂ : square t₂ b₂ l₂ r₂)
|
||||
: square (t₁ ◾ t₂) (b₁ ◾ b₂) (l₁ ◾ l₂) (r₁ ◾ r₂) :=
|
||||
by induction s₂;induction s₁;constructor
|
||||
|
||||
open is_trunc
|
||||
definition is_set.elims [H : is_set A] : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
square_of_eq !is_set.elim
|
||||
|
||||
definition is_trunc_square [instance] (n : trunc_index) [H : is_trunc n .+2 A]
|
||||
: is_trunc n (square p₁₀ p₁₂ p₀₁ p₂₁) :=
|
||||
is_trunc_equiv_closed_rev n !square_equiv_eq
|
||||
|
||||
-- definition square_of_con_inv_hsquare {p₁ p₂ p₃ p₄ : a₁ = a₂}
|
||||
-- {t : p₁ = p₂} {b : p₃ = p₄} {l : p₁ = p₃} {r : p₂ = p₄}
|
||||
-- (s : square (con_inv_eq_idp t) (con_inv_eq_idp b) (l ◾ r⁻²) idp)
|
||||
-- : square t b l r :=
|
||||
-- sorry --by induction s
|
||||
|
||||
/- Square fillers -/
|
||||
-- TODO replace by "more algebraic" fillers?
|
||||
|
||||
variables (p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
definition square_fill_t : Σ (p : a₀₀ = a₂₀), square p p₁₂ p₀₁ p₂₁ :=
|
||||
by induction p₀₁; induction p₂₁; exact ⟨_, !vrefl⟩
|
||||
|
||||
definition square_fill_b : Σ (p : a₀₂ = a₂₂), square p₁₀ p p₀₁ p₂₁ :=
|
||||
by induction p₀₁; induction p₂₁; exact ⟨_, !vrefl⟩
|
||||
|
||||
definition square_fill_l : Σ (p : a₀₀ = a₀₂), square p₁₀ p₁₂ p p₂₁ :=
|
||||
by induction p₁₀; induction p₁₂; exact ⟨_, !hrefl⟩
|
||||
|
||||
definition square_fill_r : Σ (p : a₂₀ = a₂₂) , square p₁₀ p₁₂ p₀₁ p :=
|
||||
by induction p₁₀; induction p₁₂; exact ⟨_, !hrefl⟩
|
||||
|
||||
/- Squares having an 'ap' term on one face -/
|
||||
--TODO find better names
|
||||
definition square_Flr_ap_idp {c : B} {f : A → B} (p : Π a, f a = c)
|
||||
{a b : A} (q : a = b) : square (p a) (p b) (ap f q) idp :=
|
||||
by induction q; apply vrfl
|
||||
|
||||
definition square_Flr_idp_ap {c : B} {f : A → B} (p : Π a, c = f a)
|
||||
{a b : A} (q : a = b) : square (p a) (p b) idp (ap f q) :=
|
||||
by induction q; apply vrfl
|
||||
|
||||
definition square_ap_idp_Flr {b : B} {f : A → B} (p : Π a, f a = b)
|
||||
{a b : A} (q : a = b) : square (ap f q) idp (p a) (p b) :=
|
||||
by induction q; apply hrfl
|
||||
|
||||
/- Matching eq_hconcat with hconcat etc. -/
|
||||
-- TODO maybe rename hconcat_eq and the like?
|
||||
variable (s₁₁)
|
||||
definition ph_eq_pv_h_vp {p : a₀₀ = a₀₂} (r : p = p₀₁) :
|
||||
r ⬝ph s₁₁ = !idp_con⁻¹ ⬝pv ((hdeg_square r) ⬝h s₁₁) ⬝vp !idp_con :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition hdeg_h_eq_pv_ph_vp {p : a₀₀ = a₀₂} (r : p = p₀₁) :
|
||||
hdeg_square r ⬝h s₁₁ = !idp_con ⬝pv (r ⬝ph s₁₁) ⬝vp !idp_con⁻¹ :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition hp_eq_h {p : a₂₀ = a₂₂} (r : p₂₁ = p) :
|
||||
s₁₁ ⬝hp r = s₁₁ ⬝h hdeg_square r :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition pv_eq_ph_vdeg_v_vh {p : a₀₀ = a₂₀} (r : p = p₁₀) :
|
||||
r ⬝pv s₁₁ = !idp_con⁻¹ ⬝ph ((vdeg_square r) ⬝v s₁₁) ⬝hp !idp_con :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition vdeg_v_eq_ph_pv_hp {p : a₀₀ = a₂₀} (r : p = p₁₀) :
|
||||
vdeg_square r ⬝v s₁₁ = !idp_con ⬝ph (r ⬝pv s₁₁) ⬝hp !idp_con⁻¹ :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition vp_eq_v {p : a₀₂ = a₂₂} (r : p₁₂ = p) :
|
||||
s₁₁ ⬝vp r = s₁₁ ⬝v vdeg_square r :=
|
||||
by cases r; cases s₁₁; esimp
|
||||
|
||||
definition natural_square [unfold 8] {f g : A → B} (p : f ~ g) (q : a = a') :
|
||||
square (p a) (p a') (ap f q) (ap g q) :=
|
||||
square_of_pathover (apd p q)
|
||||
|
||||
definition natural_square_tr [unfold 8] {f g : A → B} (p : f ~ g) (q : a = a') :
|
||||
square (ap f q) (ap g q) (p a) (p a') :=
|
||||
transpose (natural_square p q)
|
||||
|
||||
definition natural_square011 {A A' : Type} {B : A → Type}
|
||||
{a a' : A} {p : a = a'} {b : B a} {b' : B a'} (q : b =[p] b')
|
||||
{l r : Π⦃a⦄, B a → A'} (g : Π⦃a⦄ (b : B a), l b = r b)
|
||||
: square (apd011 l p q) (apd011 r p q) (g b) (g b') :=
|
||||
begin
|
||||
induction q, exact hrfl
|
||||
end
|
||||
|
||||
definition natural_square0111' {A A' : Type} {B : A → Type} (C : Π⦃a⦄, B a → Type)
|
||||
{a a' : A} {p : a = a'} {b : B a} {b' : B a'} {q : b =[p] b'}
|
||||
{c : C b} {c' : C b'} (s : c =[apd011 C p q] c')
|
||||
{l r : Π⦃a⦄ {b : B a}, C b → A'}
|
||||
(g : Π⦃a⦄ {b : B a} (c : C b), l c = r c)
|
||||
: square (apd0111 l p q s) (apd0111 r p q s) (g c) (g c') :=
|
||||
begin
|
||||
induction q, esimp at s, induction s using idp_rec_on, exact hrfl
|
||||
end
|
||||
|
||||
-- this can be generalized a bit, by making the domain and codomain of k different, and also have
|
||||
-- a function at the RHS of s (similar to m)
|
||||
definition natural_square0111 {A A' : Type} {B : A → Type} (C : Π⦃a⦄, B a → Type)
|
||||
{a a' : A} {p : a = a'} {b : B a} {b' : B a'} {q : b =[p] b'}
|
||||
{c : C b} {c' : C b'} (r : c =[apd011 C p q] c')
|
||||
{k : A → A} {l : Π⦃a⦄, B a → B (k a)} (m : Π⦃a⦄ {b : B a}, C b → C (l b))
|
||||
{f : Π⦃a⦄ {b : B a}, C b → A'}
|
||||
(s : Π⦃a⦄ {b : B a} (c : C b), f (m c) = f c)
|
||||
: square (apd0111 (λa b c, f (m c)) p q r) (apd0111 f p q r) (s c) (s c') :=
|
||||
begin
|
||||
induction q, esimp at r, induction r using idp_rec_on, exact hrfl
|
||||
end
|
||||
|
||||
end eq
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Coherence conditions for operations on squares
|
||||
-/
|
||||
|
||||
import .square
|
||||
|
||||
open equiv
|
||||
|
||||
namespace eq
|
||||
|
||||
variables {A B C : Type} {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ a₁ a₂ a₃ a₄ : A}
|
||||
{f : A → B} {b : B} {c : C}
|
||||
/-a₀₀-/ {p₁₀ p₁₀' : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
|
||||
{p₀₁ p₀₁' : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ p₂₁' : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
|
||||
/-a₀₂-/ {p₁₂ p₁₂' : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
|
||||
{p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
|
||||
/-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
|
||||
|
||||
theorem whisker_bl_whisker_tl_eq (p : a = a')
|
||||
: whisker_bl p (whisker_tl p ids) = con.right_inv p ⬝ph vrfl :=
|
||||
by induction p; reflexivity
|
||||
|
||||
theorem ap_is_constant_natural_square {g : B → C} {f : A → B} (H : Πa, g (f a) = c) (p : a = a') :
|
||||
(ap_is_constant H p)⁻¹ ⬝ph natural_square H p ⬝hp ap_constant p c =
|
||||
whisker_bl (H a') (whisker_tl (H a) ids) :=
|
||||
begin induction p, esimp, rewrite inv_inv, rewrite whisker_bl_whisker_tl_eq end
|
||||
|
||||
definition inv_ph_eq_of_eq_ph {p : a₀₀ = a₀₂} {r : p₀₁ = p} {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁}
|
||||
{s₁₁' : square p₁₀ p₁₂ p p₂₁} (t : s₁₁ = r ⬝ph s₁₁') : r⁻¹ ⬝ph s₁₁ = s₁₁' :=
|
||||
by induction r; exact t
|
||||
|
||||
-- the following is used for torus.elim_surf
|
||||
theorem whisker_square_aps_eq
|
||||
{q₁₀ : f a₀₀ = f a₂₀} {q₀₁ : f a₀₀ = f a₀₂} {q₂₁ : f a₂₀ = f a₂₂} {q₁₂ : f a₀₂ = f a₂₂}
|
||||
{r₁₀ : ap f p₁₀ = q₁₀} {r₀₁ : ap f p₀₁ = q₀₁} {r₂₁ : ap f p₂₁ = q₂₁} {r₁₂ : ap f p₁₂ = q₁₂}
|
||||
{s₁₁ : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂} {t₁₁ : square q₁₀ q₁₂ q₀₁ q₂₁}
|
||||
(u : square (ap02 f s₁₁) (eq_of_square t₁₁)
|
||||
(ap_con f p₁₀ p₂₁ ⬝ (r₁₀ ◾ r₂₁)) (ap_con f p₀₁ p₁₂ ⬝ (r₀₁ ◾ r₁₂)))
|
||||
: whisker_square r₁₀ r₁₂ r₀₁ r₂₁ (aps f (square_of_eq s₁₁)) = t₁₁ :=
|
||||
begin
|
||||
induction r₁₀, induction r₀₁, induction r₁₂, induction r₂₁,
|
||||
induction p₁₂, induction p₁₀, induction p₂₁, esimp at *, induction s₁₁, esimp at *,
|
||||
esimp [square_of_eq],
|
||||
apply eq_of_fn_eq_fn !square_equiv_eq, esimp,
|
||||
exact (eq_bot_of_square u)⁻¹
|
||||
end
|
||||
|
||||
end eq
|
||||
|
|
@ -1,307 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Squareovers
|
||||
-/
|
||||
|
||||
import .square
|
||||
|
||||
open eq equiv is_equiv sigma
|
||||
|
||||
namespace eq
|
||||
|
||||
-- we give the argument B explicitly, because Lean would find (λa, B a) by itself, which
|
||||
-- makes the type uglier (of course the two terms are definitionally equal)
|
||||
inductive squareover {A : Type} (B : A → Type) {a₀₀ : A} {b₀₀ : B a₀₀} :
|
||||
Π{a₂₀ a₀₂ a₂₂ : A}
|
||||
{p₁₀ : a₀₀ = a₂₀} {p₁₂ : a₀₂ = a₂₂} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂}
|
||||
(s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
{b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
|
||||
(q₁₀ : pathover B b₀₀ p₁₀ b₂₀) (q₁₂ : pathover B b₀₂ p₁₂ b₂₂)
|
||||
(q₀₁ : pathover B b₀₀ p₀₁ b₀₂) (q₂₁ : pathover B b₂₀ p₂₁ b₂₂),
|
||||
Type :=
|
||||
idsquareo : squareover B ids idpo idpo idpo idpo
|
||||
|
||||
|
||||
variables {A A' : Type} {B : A → Type}
|
||||
{a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ : A}
|
||||
/-a₀₀-/ {p₁₀ : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
|
||||
{p₀₁ : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
|
||||
/-a₀₂-/ {p₁₂ : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
|
||||
{p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
|
||||
/-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
|
||||
{s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁} {s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁}
|
||||
{s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃} {s₃₃ : square p₃₂ p₃₄ p₂₃ p₄₃}
|
||||
|
||||
{b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₄₀ : B a₄₀}
|
||||
{b₀₂ : B a₀₂} {b₂₂ : B a₂₂} {b₄₂ : B a₄₂}
|
||||
{b₀₄ : B a₀₄} {b₂₄ : B a₂₄} {b₄₄ : B a₄₄}
|
||||
/-b₀₀-/ {q₁₀ : b₀₀ =[p₁₀] b₂₀} /-b₂₀-/ {q₃₀ : b₂₀ =[p₃₀] b₄₀} /-b₄₀-/
|
||||
{q₀₁ : b₀₀ =[p₀₁] b₀₂} /-t₁₁-/ {q₂₁ : b₂₀ =[p₂₁] b₂₂} /-t₃₁-/ {q₄₁ : b₄₀ =[p₄₁] b₄₂}
|
||||
/-b₀₂-/ {q₁₂ : b₀₂ =[p₁₂] b₂₂} /-b₂₂-/ {q₃₂ : b₂₂ =[p₃₂] b₄₂} /-b₄₂-/
|
||||
{q₀₃ : b₀₂ =[p₀₃] b₀₄} /-t₁₃-/ {q₂₃ : b₂₂ =[p₂₃] b₂₄} /-t₃₃-/ {q₄₃ : b₄₂ =[p₄₃] b₄₄}
|
||||
/-b₀₄-/ {q₁₄ : b₀₄ =[p₁₄] b₂₄} /-b₂₄-/ {q₃₄ : b₂₄ =[p₃₄] b₄₄} /-b₄₄-/
|
||||
|
||||
definition squareo := @squareover A B a₀₀
|
||||
definition idsquareo [reducible] [constructor] (b₀₀ : B a₀₀) := @squareover.idsquareo A B a₀₀ b₀₀
|
||||
definition idso [reducible] [constructor] := @squareover.idsquareo A B a₀₀ b₀₀
|
||||
|
||||
definition apds (f : Πa, B a) (s : square p₁₀ p₁₂ p₀₁ p₂₁)
|
||||
: squareover B s (apd f p₁₀) (apd f p₁₂) (apd f p₀₁) (apd f p₂₁) :=
|
||||
square.rec_on s idso
|
||||
|
||||
definition vrflo : squareover B vrfl q₁₀ q₁₀ idpo idpo :=
|
||||
by induction q₁₀; exact idso
|
||||
|
||||
definition hrflo : squareover B hrfl idpo idpo q₁₀ q₁₀ :=
|
||||
by induction q₁₀; exact idso
|
||||
|
||||
definition vdeg_squareover {p₁₀'} {s : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
|
||||
(r : change_path s q₁₀ = q₁₀')
|
||||
: squareover B (vdeg_square s) q₁₀ q₁₀' idpo idpo :=
|
||||
by induction s; esimp at *; induction r; exact vrflo
|
||||
|
||||
definition hdeg_squareover {p₀₁'} {s : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
|
||||
(r : change_path s q₀₁ = q₀₁')
|
||||
: squareover B (hdeg_square s) idpo idpo q₀₁ q₀₁' :=
|
||||
by induction s; esimp at *; induction r; exact hrflo
|
||||
|
||||
definition hconcato
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₃₁ : squareover B s₃₁ q₃₀ q₃₂ q₂₁ q₄₁)
|
||||
: squareover B (hconcat s₁₁ s₃₁) (q₁₀ ⬝o q₃₀) (q₁₂ ⬝o q₃₂) q₀₁ q₄₁ :=
|
||||
by induction t₃₁; exact t₁₁
|
||||
|
||||
definition vconcato
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₁₃ : squareover B s₁₃ q₁₂ q₁₄ q₀₃ q₂₃)
|
||||
: squareover B (vconcat s₁₁ s₁₃) q₁₀ q₁₄ (q₀₁ ⬝o q₀₃) (q₂₁ ⬝o q₂₃) :=
|
||||
by induction t₁₃; exact t₁₁
|
||||
|
||||
definition hinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B (hinverse s₁₁) q₁₀⁻¹ᵒ q₁₂⁻¹ᵒ q₂₁ q₀₁ :=
|
||||
by induction t₁₁; constructor
|
||||
|
||||
definition vinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B (vinverse s₁₁) q₁₂ q₁₀ q₀₁⁻¹ᵒ q₂₁⁻¹ᵒ :=
|
||||
by induction t₁₁; constructor
|
||||
|
||||
definition eq_vconcato {q : b₀₀ =[p₁₀] b₂₀}
|
||||
(r : q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q q₁₂ q₀₁ q₂₁ :=
|
||||
by induction r; exact t₁₁
|
||||
|
||||
definition vconcato_eq {q : b₀₂ =[p₁₂] b₂₂}
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₁₂ = q) : squareover B s₁₁ q₁₀ q q₀₁ q₂₁ :=
|
||||
by induction r; exact t₁₁
|
||||
|
||||
definition eq_hconcato {q : b₀₀ =[p₀₁] b₀₂}
|
||||
(r : q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q₁₀ q₁₂ q q₂₁ :=
|
||||
by induction r; exact t₁₁
|
||||
|
||||
definition hconcato_eq {q : b₂₀ =[p₂₁] b₂₂}
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₂₁ = q) : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q :=
|
||||
by induction r; exact t₁₁
|
||||
|
||||
definition pathover_vconcato {p : a₀₀ = a₂₀} {sp : p = p₁₀} {q : b₀₀ =[p] b₂₀}
|
||||
(r : change_path sp q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B (sp ⬝pv s₁₁) q q₁₂ q₀₁ q₂₁ :=
|
||||
by induction sp; induction r; exact t₁₁
|
||||
|
||||
definition vconcato_pathover {p : a₀₂ = a₂₂} {sp : p₁₂ = p} {q : b₀₂ =[p] b₂₂}
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₁₂ = q)
|
||||
: squareover B (s₁₁ ⬝vp sp) q₁₀ q q₀₁ q₂₁ :=
|
||||
by induction sp; induction r; exact t₁₁
|
||||
|
||||
definition pathover_hconcato {p : a₀₀ = a₀₂} {sp : p = p₀₁} {q : b₀₀ =[p] b₀₂}
|
||||
(r : change_path sp q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
|
||||
squareover B (sp ⬝ph s₁₁) q₁₀ q₁₂ q q₂₁ :=
|
||||
by induction sp; induction r; exact t₁₁
|
||||
|
||||
definition hconcato_pathover {p : a₂₀ = a₂₂} {sp : p₂₁ = p} {q : b₂₀ =[p] b₂₂}
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₂₁ = q) :
|
||||
squareover B (s₁₁ ⬝hp sp) q₁₀ q₁₂ q₀₁ q :=
|
||||
by induction sp; induction r; exact t₁₁
|
||||
|
||||
infix ` ⬝ho `:69 := hconcato --type using \tr
|
||||
infix ` ⬝vo `:70 := vconcato --type using \tr
|
||||
infix ` ⬝hop `:72 := hconcato_eq --type using \tr
|
||||
infix ` ⬝vop `:74 := vconcato_eq --type using \tr
|
||||
infix ` ⬝pho `:71 := eq_hconcato --type using \tr
|
||||
infix ` ⬝pvo `:73 := eq_vconcato --type using \tr
|
||||
|
||||
-- relating squareovers to squares
|
||||
definition square_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
|
||||
square (!con_tr ⬝ ap (λa, p₂₁ ▸ a) (tr_eq_of_pathover q₁₀))
|
||||
(tr_eq_of_pathover q₁₂)
|
||||
(ap (λq, q ▸ b₀₀) (eq_of_square s₁₁) ⬝ !con_tr ⬝ ap (λa, p₁₂ ▸ a) (tr_eq_of_pathover q₀₁))
|
||||
(tr_eq_of_pathover q₂₁) :=
|
||||
by induction t₁₁; esimp; constructor
|
||||
/-
|
||||
definition squareover_of_square
|
||||
(q : square (!con_tr ⬝ ap (λa, p₂₁ ▸ a) (tr_eq_of_pathover q₁₀))
|
||||
(tr_eq_of_pathover q₁₂)
|
||||
(ap (λq, q ▸ b₀₀) (eq_of_square s₁₁) ⬝ !con_tr ⬝ ap (λa, p₁₂ ▸ a) (tr_eq_of_pathover q₀₁))
|
||||
(tr_eq_of_pathover q₂₁))
|
||||
: squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁ :=
|
||||
sorry
|
||||
-/
|
||||
|
||||
definition square_of_squareover_ids {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
|
||||
{t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂}
|
||||
(so : squareover B ids (pathover_idp_of_eq t)
|
||||
(pathover_idp_of_eq b)
|
||||
(pathover_idp_of_eq l)
|
||||
(pathover_idp_of_eq r)) : square t b l r :=
|
||||
begin
|
||||
note H := square_of_squareover so, -- use apply ... in
|
||||
rewrite [▸* at H,+idp_con at H,+ap_id at H,↑pathover_idp_of_eq at H],
|
||||
rewrite [+to_right_inv !(pathover_equiv_tr_eq (refl a)) at H],
|
||||
exact H
|
||||
end
|
||||
|
||||
definition squareover_ids_of_square {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
|
||||
{t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂} (q : square t b l r)
|
||||
: squareover B ids (pathover_idp_of_eq t)
|
||||
(pathover_idp_of_eq b)
|
||||
(pathover_idp_of_eq l)
|
||||
(pathover_idp_of_eq r) :=
|
||||
square.rec_on q idso
|
||||
|
||||
-- relating pathovers to squareovers
|
||||
definition pathover_of_squareover' (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: q₁₀ ⬝o q₂₁ =[eq_of_square s₁₁] q₀₁ ⬝o q₁₂ :=
|
||||
by induction t₁₁; constructor
|
||||
|
||||
definition pathover_of_squareover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
|
||||
(t₁₁ : squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: q₁₀ ⬝o q₂₁ =[s] q₀₁ ⬝o q₁₂ :=
|
||||
begin
|
||||
revert s t₁₁, refine equiv_rect' !square_equiv_eq⁻¹ᵉ (λa b, squareover B b _ _ _ _ → _) _,
|
||||
intro s, exact pathover_of_squareover'
|
||||
end
|
||||
|
||||
definition squareover_of_pathover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
|
||||
(r : q₁₀ ⬝o q₂₁ =[s] q₀₁ ⬝o q₁₂) : squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁ :=
|
||||
by induction q₁₂; esimp [concato] at r;induction r;induction q₂₁;induction q₁₀;constructor
|
||||
|
||||
definition pathover_top_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: q₁₀ =[eq_top_of_square s₁₁] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
|
||||
by induction t₁₁; constructor
|
||||
|
||||
definition squareover_of_pathover_top {s : p₁₀ = p₀₁ ⬝ p₁₂ ⬝ p₂₁⁻¹}
|
||||
(r : q₁₀ =[s] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
|
||||
: squareover B (square_of_eq_top s) q₁₀ q₁₂ q₀₁ q₂₁ :=
|
||||
by induction q₂₁; induction q₁₂; esimp at r;induction r;induction q₁₀;constructor
|
||||
|
||||
definition pathover_of_hdeg_squareover {p₀₁' : a₀₀ = a₀₂} {r : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
|
||||
(t : squareover B (hdeg_square r) idpo idpo q₀₁ q₀₁') : q₀₁ =[r] q₀₁' :=
|
||||
by induction r; induction q₀₁'; exact (pathover_of_squareover' t)⁻¹ᵒ
|
||||
|
||||
definition pathover_of_vdeg_squareover {p₁₀' : a₀₀ = a₂₀} {r : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
|
||||
(t : squareover B (vdeg_square r) q₁₀ q₁₀' idpo idpo) : q₁₀ =[r] q₁₀' :=
|
||||
by induction r; induction q₁₀'; exact pathover_of_squareover' t
|
||||
|
||||
definition squareover_of_eq_top (r : change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
|
||||
: squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁ :=
|
||||
begin
|
||||
induction s₁₁, revert q₁₂ q₁₀ r,
|
||||
eapply idp_rec_on q₂₁, clear q₂₁,
|
||||
intro q₁₂,
|
||||
eapply idp_rec_on q₁₂, clear q₁₂,
|
||||
esimp, intros,
|
||||
induction r, eapply idp_rec_on q₁₀,
|
||||
constructor
|
||||
end
|
||||
|
||||
definition eq_top_of_squareover (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
|
||||
by induction r; reflexivity
|
||||
|
||||
definition change_square {s₁₁'} (p : s₁₁ = s₁₁') (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B s₁₁' q₁₀ q₁₂ q₀₁ q₂₁ :=
|
||||
p ▸ r
|
||||
|
||||
/-
|
||||
definition squareover_equiv_pathover (q₁₀ : b₀₀ =[p₁₀] b₂₀) (q₁₂ : b₀₂ =[p₁₂] b₂₂)
|
||||
(q₀₁ : b₀₀ =[p₀₁] b₀₂) (q₂₁ : b₂₀ =[p₂₁] b₂₂)
|
||||
: squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁ ≃ q₁₀ ⬝o q₂₁ =[eq_of_square s₁₁] q₀₁ ⬝o q₁₂ :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact pathover_of_squareover},
|
||||
{ intro r, rewrite [-to_left_inv !square_equiv_eq s₁₁], apply squareover_of_pathover, exact r},
|
||||
{ intro r, }, --need characterization of squareover lying over ids.
|
||||
{ intro s, induction s, apply idp},
|
||||
end
|
||||
-/
|
||||
|
||||
definition eq_of_vdeg_squareover {q₁₀' : b₀₀ =[p₁₀] b₂₀}
|
||||
(p : squareover B vrfl q₁₀ q₁₀' idpo idpo) : q₁₀ = q₁₀' :=
|
||||
begin
|
||||
note H := square_of_squareover p, -- use apply ... in
|
||||
induction p₁₀, -- if needed we can remove this induction and use con_tr_idp in types/eq2
|
||||
rewrite [▸* at H,idp_con at H,+ap_id at H],
|
||||
let H' := eq_of_vdeg_square H,
|
||||
exact eq_of_fn_eq_fn !pathover_equiv_tr_eq H'
|
||||
end
|
||||
|
||||
-- definition vdeg_tr_squareover {q₁₂ : p₀₁ ▸ b₀₀ =[p₁₂] p₂₁ ▸ b₂₀} (r : q₁₀ =[_] q₁₂)
|
||||
-- : squareover B s₁₁ q₁₀ q₁₂ !pathover_tr !pathover_tr :=
|
||||
-- by induction p;exact vrflo
|
||||
|
||||
/- A version of eq_pathover where the type of the equality also varies -/
|
||||
definition eq_pathover_dep {f g : Πa, B a} {p : a = a'} {q : f a = g a}
|
||||
{r : f a' = g a'} (s : squareover B hrfl (pathover_idp_of_eq q) (pathover_idp_of_eq r)
|
||||
(apd f p) (apd g p)) : q =[p] r :=
|
||||
begin
|
||||
induction p, apply pathover_idp_of_eq, apply eq_of_vdeg_square, exact square_of_squareover_ids s
|
||||
end
|
||||
|
||||
/- charcaterization of pathovers in pathovers -/
|
||||
-- in this version the fibration (B) of the pathover does not depend on the variable (a)
|
||||
definition pathover_pathover {a' a₂' : A'} {p : a' = a₂'} {f g : A' → A}
|
||||
{b : Πa, B (f a)} {b₂ : Πa, B (g a)} {q : Π(a' : A'), f a' = g a'}
|
||||
(r : pathover B (b a') (q a') (b₂ a'))
|
||||
(r₂ : pathover B (b a₂') (q a₂') (b₂ a₂'))
|
||||
(s : squareover B (natural_square q p) r r₂
|
||||
(pathover_ap B f (apd b p)) (pathover_ap B g (apd b₂ p)))
|
||||
: pathover (λa, pathover B (b a) (q a) (b₂ a)) r p r₂ :=
|
||||
begin
|
||||
induction p, esimp at s, apply pathover_idp_of_eq, apply eq_of_vdeg_squareover, exact s
|
||||
end
|
||||
|
||||
definition squareover_change_path_left {p₀₁' : a₀₀ = a₀₂} (r : p₀₁' = p₀₁)
|
||||
{q₀₁ : b₀₀ =[p₀₁'] b₀₂} (t : squareover B (r ⬝ph s₁₁) q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B s₁₁ q₁₀ q₁₂ (change_path r q₀₁) q₂₁ :=
|
||||
by induction r; exact t
|
||||
|
||||
definition squareover_change_path_right {p₂₁' : a₂₀ = a₂₂} (r : p₂₁' = p₂₁)
|
||||
{q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r⁻¹) q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r q₂₁) :=
|
||||
by induction r; exact t
|
||||
|
||||
definition squareover_change_path_right' {p₂₁' : a₂₀ = a₂₂} (r : p₂₁ = p₂₁')
|
||||
{q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r) q₁₀ q₁₂ q₀₁ q₂₁)
|
||||
: squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r⁻¹ q₂₁) :=
|
||||
by induction r; exact t
|
||||
|
||||
/- You can construct a square in a sigma-type by giving a squareover -/
|
||||
definition square_dpair_eq_dpair {a₀₀ a₂₀ a₀₂ a₂₂ : A}
|
||||
{p₁₀ : a₀₀ = a₂₀} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂} {p₁₂ : a₀₂ = a₂₂}
|
||||
(s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
|
||||
{q₁₀ : b₀₀ =[p₁₀] b₂₀} {q₀₁ : b₀₀ =[p₀₁] b₀₂} {q₂₁ : b₂₀ =[p₂₁] b₂₂} {q₁₂ : b₀₂ =[p₁₂] b₂₂}
|
||||
(t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
|
||||
square (dpair_eq_dpair p₁₀ q₁₀) (dpair_eq_dpair p₁₂ q₁₂)
|
||||
(dpair_eq_dpair p₀₁ q₀₁) (dpair_eq_dpair p₂₁ q₂₁) :=
|
||||
by induction t₁₁; constructor
|
||||
|
||||
definition sigma_square {v₀₀ v₂₀ v₀₂ v₂₂ : Σa, B a}
|
||||
{p₁₀ : v₀₀ = v₂₀} {p₀₁ : v₀₀ = v₀₂} {p₂₁ : v₂₀ = v₂₂} {p₁₂ : v₀₂ = v₂₂}
|
||||
(s₁₁ : square p₁₀..1 p₁₂..1 p₀₁..1 p₂₁..1)
|
||||
(t₁₁ : squareover B s₁₁ p₁₀..2 p₁₂..2 p₀₁..2 p₂₁..2) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
|
||||
begin
|
||||
induction v₀₀, induction v₂₀, induction v₀₂, induction v₂₂,
|
||||
rewrite [▸* at *, -sigma_eq_eta p₁₀, -sigma_eq_eta p₁₂, -sigma_eq_eta p₀₁, -sigma_eq_eta p₂₁],
|
||||
exact square_dpair_eq_dpair s₁₁ t₁₁
|
||||
end
|
||||
|
||||
end eq
|
||||
144
hott/eq2.hlean
144
hott/eq2.hlean
|
|
@ -1,144 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Theorems about 2-dimensional paths
|
||||
-/
|
||||
|
||||
import .cubical.square
|
||||
open function
|
||||
|
||||
namespace eq
|
||||
variables {A B C : Type} {f : A → B} {a a' a₁ a₂ a₃ a₄ : A} {b b' : B}
|
||||
|
||||
theorem ap_is_constant_eq (p : Πx, f x = b) (q : a = a') :
|
||||
ap_is_constant p q =
|
||||
eq_con_inv_of_con_eq ((eq_of_square (square_of_pathover (apd p q)))⁻¹ ⬝
|
||||
whisker_left (p a) (ap_constant q b)) :=
|
||||
begin
|
||||
induction q, esimp, generalize (p a), intro p, cases p, apply idpath idp
|
||||
end
|
||||
|
||||
definition ap_inv2 {p q : a = a'} (r : p = q)
|
||||
: square (ap (ap f) (inverse2 r))
|
||||
(inverse2 (ap (ap f) r))
|
||||
(ap_inv f p)
|
||||
(ap_inv f q) :=
|
||||
by induction r;exact hrfl
|
||||
|
||||
definition ap_con2 {p₁ q₁ : a₁ = a₂} {p₂ q₂ : a₂ = a₃} (r₁ : p₁ = q₁) (r₂ : p₂ = q₂)
|
||||
: square (ap (ap f) (r₁ ◾ r₂))
|
||||
(ap (ap f) r₁ ◾ ap (ap f) r₂)
|
||||
(ap_con f p₁ p₂)
|
||||
(ap_con f q₁ q₂) :=
|
||||
by induction r₂;induction r₁;exact hrfl
|
||||
|
||||
theorem ap_con_right_inv_sq {A B : Type} {a1 a2 : A} (f : A → B) (p : a1 = a2) :
|
||||
square (ap (ap f) (con.right_inv p))
|
||||
(con.right_inv (ap f p))
|
||||
(ap_con f p p⁻¹ ⬝ whisker_left _ (ap_inv f p))
|
||||
idp :=
|
||||
by cases p;apply hrefl
|
||||
|
||||
theorem ap_con_left_inv_sq {A B : Type} {a1 a2 : A} (f : A → B) (p : a1 = a2) :
|
||||
square (ap (ap f) (con.left_inv p))
|
||||
(con.left_inv (ap f p))
|
||||
(ap_con f p⁻¹ p ⬝ whisker_right _ (ap_inv f p))
|
||||
idp :=
|
||||
by cases p;apply vrefl
|
||||
|
||||
definition ap02_compose {A B C : Type} (g : B → C) (f : A → B) {a a' : A}
|
||||
{p₁ p₂ : a = a'} (q : p₁ = p₂) :
|
||||
square (ap_compose g f p₁) (ap_compose g f p₂) (ap02 (g ∘ f) q) (ap02 g (ap02 f q)) :=
|
||||
by induction q; exact vrfl
|
||||
|
||||
definition ap02_id {A : Type} {a a' : A}
|
||||
{p₁ p₂ : a = a'} (q : p₁ = p₂) :
|
||||
square (ap_id p₁) (ap_id p₂) (ap02 id q) q :=
|
||||
by induction q; exact vrfl
|
||||
|
||||
theorem ap_ap_is_constant {A B C : Type} (g : B → C) {f : A → B} {b : B}
|
||||
(p : Πx, f x = b) {x y : A} (q : x = y) :
|
||||
square (ap (ap g) (ap_is_constant p q))
|
||||
(ap_is_constant (λa, ap g (p a)) q)
|
||||
(ap_compose g f q)⁻¹
|
||||
(!ap_con ⬝ whisker_left _ !ap_inv) :=
|
||||
begin
|
||||
induction q, esimp, generalize (p x), intro p, cases p, apply ids
|
||||
-- induction q, rewrite [↑ap_compose,ap_inv], apply hinverse, apply ap_con_right_inv_sq,
|
||||
end
|
||||
|
||||
theorem ap_ap_compose {A B C D : Type} (h : C → D) (g : B → C) (f : A → B)
|
||||
{x y : A} (p : x = y) :
|
||||
square (ap_compose (h ∘ g) f p)
|
||||
(ap (ap h) (ap_compose g f p))
|
||||
(ap_compose h (g ∘ f) p)
|
||||
(ap_compose h g (ap f p)) :=
|
||||
by induction p;exact ids
|
||||
|
||||
theorem ap_compose_inv {A B C : Type} (g : B → C) (f : A → B)
|
||||
{x y : A} (p : x = y) :
|
||||
square (ap_compose g f p⁻¹)
|
||||
(inverse2 (ap_compose g f p) ⬝ (ap_inv g (ap f p))⁻¹)
|
||||
(ap_inv (g ∘ f) p)
|
||||
(ap (ap g) (ap_inv f p)) :=
|
||||
by induction p;exact ids
|
||||
|
||||
theorem ap_compose_con (g : B → C) (f : A → B) (p : a₁ = a₂) (q : a₂ = a₃) :
|
||||
square (ap_compose g f (p ⬝ q))
|
||||
(ap_compose g f p ◾ ap_compose g f q ⬝ (ap_con g (ap f p) (ap f q))⁻¹)
|
||||
(ap_con (g ∘ f) p q)
|
||||
(ap (ap g) (ap_con f p q)) :=
|
||||
by induction q;induction p;exact ids
|
||||
|
||||
theorem ap_compose_natural {A B C : Type} (g : B → C) (f : A → B)
|
||||
{x y : A} {p q : x = y} (r : p = q) :
|
||||
square (ap (ap (g ∘ f)) r)
|
||||
(ap (ap g ∘ ap f) r)
|
||||
(ap_compose g f p)
|
||||
(ap_compose g f q) :=
|
||||
natural_square_tr (ap_compose g f) r
|
||||
|
||||
theorem whisker_right_eq_of_con_inv_eq_idp {p q : a₁ = a₂} (r : p ⬝ q⁻¹ = idp) :
|
||||
whisker_right q⁻¹ (eq_of_con_inv_eq_idp r) ⬝ con.right_inv q = r :=
|
||||
by induction q; esimp at r; cases r; reflexivity
|
||||
|
||||
theorem ap_eq_of_con_inv_eq_idp (f : A → B) {p q : a₁ = a₂} (r : p ⬝ q⁻¹ = idp)
|
||||
: ap02 f (eq_of_con_inv_eq_idp r) =
|
||||
eq_of_con_inv_eq_idp (whisker_left _ !ap_inv⁻¹ ⬝ !ap_con⁻¹ ⬝ ap02 f r)
|
||||
:=
|
||||
by induction q;esimp at *;cases r;reflexivity
|
||||
|
||||
theorem eq_of_con_inv_eq_idp_con2 {p p' q q' : a₁ = a₂} (r : p = p') (s : q = q')
|
||||
(t : p' ⬝ q'⁻¹ = idp)
|
||||
: eq_of_con_inv_eq_idp (r ◾ inverse2 s ⬝ t) = r ⬝ eq_of_con_inv_eq_idp t ⬝ s⁻¹ :=
|
||||
by induction s;induction r;induction q;reflexivity
|
||||
|
||||
definition naturality_apd_eq {A : Type} {B : A → Type} {a a₂ : A} {f g : Πa, B a}
|
||||
(H : f ~ g) (p : a = a₂)
|
||||
: apd f p = concato_eq (eq_concato (H a) (apd g p)) (H a₂)⁻¹ :=
|
||||
begin
|
||||
induction p, esimp,
|
||||
generalizes [H a, g a], intro ga Ha, induction Ha,
|
||||
reflexivity
|
||||
end
|
||||
|
||||
theorem con_tr_idp {P : A → Type} {x y : A} (q : x = y) (u : P x) :
|
||||
con_tr idp q u = ap (λp, p ▸ u) (idp_con q) :=
|
||||
by induction q;reflexivity
|
||||
|
||||
definition eq_transport_Fl_idp_left {A B : Type} {a : A} {b : B} (f : A → B) (q : f a = b)
|
||||
: eq_transport_Fl idp q = !idp_con⁻¹ :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition whisker_left_idp_con_eq_assoc
|
||||
{A : Type} {a₁ a₂ a₃ : A} (p : a₁ = a₂) (q : a₂ = a₃)
|
||||
: whisker_left p (idp_con q)⁻¹ = con.assoc p idp q :=
|
||||
by induction q; reflexivity
|
||||
|
||||
definition whisker_left_inverse2 {A : Type} {a : A} {p : a = a} (q : p = idp)
|
||||
: whisker_left p q⁻² ⬝ q = con.right_inv p :=
|
||||
by cases q; reflexivity
|
||||
|
||||
end eq
|
||||
|
|
@ -1,312 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Author: Floris van Doorn
|
||||
|
||||
Ported from Coq HoTT
|
||||
Theorems about embeddings and surjections
|
||||
-/
|
||||
|
||||
import hit.trunc types.equiv cubical.square
|
||||
|
||||
open equiv sigma sigma.ops eq trunc is_trunc pi is_equiv fiber prod
|
||||
|
||||
variables {A B C : Type} (f : A → B) {b : B}
|
||||
|
||||
/- the image of a map is the (-1)-truncated fiber -/
|
||||
definition image' [constructor] (f : A → B) (b : B) : Type := ∥ fiber f b ∥
|
||||
definition is_prop_image' [instance] (f : A → B) (b : B) : is_prop (image' f b) := !is_trunc_trunc
|
||||
definition image [constructor] (f : A → B) (b : B) : Prop := Prop.mk (image' f b) _
|
||||
|
||||
definition image.mk [constructor] {f : A → B} {b : B} (a : A) (p : f a = b)
|
||||
: image f b :=
|
||||
tr (fiber.mk a p)
|
||||
|
||||
protected definition image.rec [unfold 8] [recursor 8] {f : A → B} {b : B} {P : image' f b → Type}
|
||||
[H : Πv, is_prop (P v)] (H : Π(a : A) (p : f a = b), P (image.mk a p)) (v : image' f b) : P v :=
|
||||
begin unfold [image'] at *, induction v with v, induction v with a p, exact H a p end
|
||||
|
||||
definition is_embedding [class] (f : A → B) := Π(a a' : A), is_equiv (ap f : a = a' → f a = f a')
|
||||
|
||||
definition is_surjective [class] (f : A → B) := Π(b : B), image f b
|
||||
|
||||
definition is_split_surjective [class] (f : A → B) := Π(b : B), fiber f b
|
||||
|
||||
structure is_retraction [class] (f : A → B) :=
|
||||
(sect : B → A)
|
||||
(right_inverse : Π(b : B), f (sect b) = b)
|
||||
|
||||
structure is_section [class] (f : A → B) :=
|
||||
(retr : B → A)
|
||||
(left_inverse : Π(a : A), retr (f a) = a)
|
||||
|
||||
definition is_weakly_constant [class] (f : A → B) := Π(a a' : A), f a = f a'
|
||||
|
||||
structure is_constant [class] (f : A → B) :=
|
||||
(pt : B)
|
||||
(eq : Π(a : A), f a = pt)
|
||||
|
||||
structure is_conditionally_constant [class] (f : A → B) :=
|
||||
(g : ∥A∥ → B)
|
||||
(eq : Π(a : A), f a = g (tr a))
|
||||
|
||||
namespace function
|
||||
|
||||
abbreviation sect [unfold 4] := @is_retraction.sect
|
||||
abbreviation right_inverse [unfold 4] := @is_retraction.right_inverse
|
||||
abbreviation retr [unfold 4] := @is_section.retr
|
||||
abbreviation left_inverse [unfold 4] := @is_section.left_inverse
|
||||
|
||||
definition is_equiv_ap_of_embedding [instance] [H : is_embedding f] (a a' : A)
|
||||
: is_equiv (ap f : a = a' → f a = f a') :=
|
||||
H a a'
|
||||
|
||||
definition ap_inv_idp {a : A} {H : is_equiv (ap f : a = a → f a = f a)}
|
||||
: (ap f)⁻¹ᶠ idp = idp :> a = a :=
|
||||
!left_inv
|
||||
|
||||
variable {f}
|
||||
definition is_injective_of_is_embedding [reducible] [H : is_embedding f] {a a' : A}
|
||||
: f a = f a' → a = a' :=
|
||||
(ap f)⁻¹
|
||||
|
||||
definition is_embedding_of_is_injective [HA : is_set A] [HB : is_set B]
|
||||
(H : Π(a a' : A), f a = f a' → a = a') : is_embedding f :=
|
||||
begin
|
||||
intro a a',
|
||||
fapply adjointify,
|
||||
{exact (H a a')},
|
||||
{intro p, apply is_set.elim},
|
||||
{intro p, apply is_set.elim}
|
||||
end
|
||||
|
||||
variable (f)
|
||||
|
||||
definition is_prop_is_embedding [instance] : is_prop (is_embedding f) :=
|
||||
by unfold is_embedding; exact _
|
||||
|
||||
definition is_embedding_equiv_is_injective [HA : is_set A] [HB : is_set B]
|
||||
: is_embedding f ≃ (Π(a a' : A), f a = f a' → a = a') :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ apply @is_injective_of_is_embedding},
|
||||
{ apply is_embedding_of_is_injective},
|
||||
{ intro H, apply is_prop.elim},
|
||||
{ intro H, apply is_prop.elim, }
|
||||
end
|
||||
|
||||
definition is_prop_fiber_of_is_embedding [H : is_embedding f] (b : B) :
|
||||
is_prop (fiber f b) :=
|
||||
begin
|
||||
apply is_prop.mk, intro v w,
|
||||
induction v with a p, induction w with a' q, induction q,
|
||||
fapply fiber_eq,
|
||||
{ esimp, apply is_injective_of_is_embedding p},
|
||||
{ esimp [is_injective_of_is_embedding], symmetry, apply right_inv}
|
||||
end
|
||||
|
||||
definition is_prop_fun_of_is_embedding [H : is_embedding f] : is_trunc_fun -1 f :=
|
||||
is_prop_fiber_of_is_embedding f
|
||||
|
||||
definition is_embedding_of_is_prop_fun [constructor] [H : is_trunc_fun -1 f] : is_embedding f :=
|
||||
begin
|
||||
intro a a', fapply adjointify,
|
||||
{ intro p, exact ap point (@is_prop.elim (fiber f (f a')) _ (fiber.mk a p) (fiber.mk a' idp))},
|
||||
{ intro p, rewrite [-ap_compose], esimp, apply ap_con_eq (@point_eq _ _ f (f a'))},
|
||||
{ intro p, induction p, apply ap (ap point), apply is_prop_elim_self}
|
||||
end
|
||||
|
||||
variable {f}
|
||||
definition is_surjective_rec_on {P : Type} (H : is_surjective f) (b : B) [Pt : is_prop P]
|
||||
(IH : fiber f b → P) : P :=
|
||||
trunc.rec_on (H b) IH
|
||||
variable (f)
|
||||
|
||||
definition is_surjective_of_is_split_surjective [instance] [H : is_split_surjective f]
|
||||
: is_surjective f :=
|
||||
λb, tr (H b)
|
||||
|
||||
definition is_prop_is_surjective [instance] : is_prop (is_surjective f) :=
|
||||
begin unfold is_surjective, exact _ end
|
||||
|
||||
definition is_surjective_cancel_right {A B C : Type} (g : B → C) (f : A → B)
|
||||
[H : is_surjective (g ∘ f)] : is_surjective g :=
|
||||
begin
|
||||
intro c,
|
||||
induction H c with a p,
|
||||
exact tr (fiber.mk (f a) p)
|
||||
end
|
||||
|
||||
definition is_weakly_constant_ap [instance] [H : is_weakly_constant f] (a a' : A) :
|
||||
is_weakly_constant (ap f : a = a' → f a = f a') :=
|
||||
take p q : a = a',
|
||||
have Π{b c : A} {r : b = c}, (H a b)⁻¹ ⬝ H a c = ap f r, from
|
||||
(λb c r, eq.rec_on r !con.left_inv),
|
||||
this⁻¹ ⬝ this
|
||||
|
||||
definition is_constant_ap [unfold 4] [instance] [H : is_constant f] (a a' : A)
|
||||
: is_constant (ap f : a = a' → f a = f a') :=
|
||||
begin
|
||||
induction H with b q,
|
||||
fapply is_constant.mk,
|
||||
{ exact q a ⬝ (q a')⁻¹},
|
||||
{ intro p, induction p, exact !con.right_inv⁻¹}
|
||||
end
|
||||
|
||||
definition is_contr_is_retraction [instance] [H : is_equiv f] : is_contr (is_retraction f) :=
|
||||
begin
|
||||
have H2 : (Σ(g : B → A), Πb, f (g b) = b) ≃ is_retraction f,
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{intro x, induction x with g p, constructor, exact p},
|
||||
{intro h, induction h, apply sigma.mk, assumption},
|
||||
{intro h, induction h, reflexivity},
|
||||
{intro x, induction x, reflexivity},
|
||||
end,
|
||||
apply is_trunc_equiv_closed, exact H2,
|
||||
apply is_equiv.is_contr_right_inverse
|
||||
end
|
||||
|
||||
definition is_contr_is_section [instance] [H : is_equiv f] : is_contr (is_section f) :=
|
||||
begin
|
||||
have H2 : (Σ(g : B → A), Πa, g (f a) = a) ≃ is_section f,
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{intro x, induction x with g p, constructor, exact p},
|
||||
{intro h, induction h, apply sigma.mk, assumption},
|
||||
{intro h, induction h, reflexivity},
|
||||
{intro x, induction x, reflexivity},
|
||||
end,
|
||||
apply is_trunc_equiv_closed, exact H2,
|
||||
fapply is_trunc_equiv_closed,
|
||||
{apply sigma_equiv_sigma_right, intro g, apply eq_equiv_homotopy},
|
||||
fapply is_trunc_equiv_closed,
|
||||
{apply fiber.sigma_char},
|
||||
fapply is_contr_fiber_of_is_equiv,
|
||||
exact to_is_equiv (arrow_equiv_arrow_left_rev A (equiv.mk f H)),
|
||||
end
|
||||
|
||||
definition is_embedding_of_is_equiv [instance] [H : is_equiv f] : is_embedding f :=
|
||||
λa a', _
|
||||
|
||||
definition is_equiv_of_is_surjective_of_is_embedding
|
||||
[H : is_embedding f] [H' : is_surjective f] : is_equiv f :=
|
||||
@is_equiv_of_is_contr_fun _ _ _
|
||||
(λb, is_surjective_rec_on H' b
|
||||
(λa, is_contr.mk a
|
||||
(λa',
|
||||
fiber_eq ((ap f)⁻¹ ((point_eq a) ⬝ (point_eq a')⁻¹))
|
||||
(by rewrite (right_inv (ap f)); rewrite inv_con_cancel_right))))
|
||||
|
||||
definition is_split_surjective_of_is_retraction [H : is_retraction f] : is_split_surjective f :=
|
||||
λb, fiber.mk (sect f b) (right_inverse f b)
|
||||
|
||||
definition is_constant_compose_point [constructor] [instance] (b : B)
|
||||
: is_constant (f ∘ point : fiber f b → B) :=
|
||||
is_constant.mk b (λv, by induction v with a p;exact p)
|
||||
|
||||
definition is_embedding_of_is_prop_fiber [H : Π(b : B), is_prop (fiber f b)] : is_embedding f :=
|
||||
is_embedding_of_is_prop_fun _
|
||||
|
||||
definition is_retraction_of_is_equiv [instance] [H : is_equiv f] : is_retraction f :=
|
||||
is_retraction.mk f⁻¹ (right_inv f)
|
||||
|
||||
definition is_section_of_is_equiv [instance] [H : is_equiv f] : is_section f :=
|
||||
is_section.mk f⁻¹ (left_inv f)
|
||||
|
||||
definition is_equiv_of_is_section_of_is_retraction [H1 : is_retraction f] [H2 : is_section f]
|
||||
: is_equiv f :=
|
||||
let g := sect f in let h := retr f in
|
||||
adjointify f
|
||||
g
|
||||
(right_inverse f)
|
||||
(λa, calc
|
||||
g (f a) = h (f (g (f a))) : left_inverse
|
||||
... = h (f a) : right_inverse f
|
||||
... = a : left_inverse)
|
||||
|
||||
section
|
||||
local attribute is_equiv_of_is_section_of_is_retraction [instance] [priority 10000]
|
||||
local attribute trunctype.struct [instance] [priority 1] -- remove after #842 is closed
|
||||
variable (f)
|
||||
definition is_prop_is_retraction_prod_is_section : is_prop (is_retraction f × is_section f) :=
|
||||
begin
|
||||
apply is_prop_of_imp_is_contr, intro H, induction H with H1 H2,
|
||||
exact _,
|
||||
end
|
||||
end
|
||||
|
||||
definition is_retraction_trunc_functor [instance] (r : A → B) [H : is_retraction r]
|
||||
(n : trunc_index) : is_retraction (trunc_functor n r) :=
|
||||
is_retraction.mk
|
||||
(trunc_functor n (sect r))
|
||||
(λb,
|
||||
((trunc_functor_compose n (sect r) r) b)⁻¹
|
||||
⬝ trunc_homotopy n (right_inverse r) b
|
||||
⬝ trunc_functor_id n B b)
|
||||
|
||||
-- Lemma 3.11.7
|
||||
definition is_contr_retract (r : A → B) [H : is_retraction r] : is_contr A → is_contr B :=
|
||||
begin
|
||||
intro CA,
|
||||
apply is_contr.mk (r (center A)),
|
||||
intro b,
|
||||
exact ap r (center_eq (is_retraction.sect r b)) ⬝ (is_retraction.right_inverse r b)
|
||||
end
|
||||
|
||||
local attribute is_prop_is_retraction_prod_is_section [instance]
|
||||
definition is_retraction_prod_is_section_equiv_is_equiv [constructor]
|
||||
: (is_retraction f × is_section f) ≃ is_equiv f :=
|
||||
begin
|
||||
apply equiv_of_is_prop,
|
||||
intro H, induction H, apply is_equiv_of_is_section_of_is_retraction,
|
||||
intro H, split, repeat exact _
|
||||
end
|
||||
|
||||
definition is_retraction_equiv_is_split_surjective :
|
||||
is_retraction f ≃ is_split_surjective f :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro H, induction H with g p, intro b, constructor, exact p b},
|
||||
{ intro H, constructor, intro b, exact point_eq (H b)},
|
||||
{ intro H, esimp, apply eq_of_homotopy, intro b, esimp, induction H b, reflexivity},
|
||||
{ intro H, induction H with g p, reflexivity},
|
||||
end
|
||||
|
||||
definition is_embedding_compose (g : B → C) (f : A → B)
|
||||
(H₁ : is_embedding g) (H₂ : is_embedding f) : is_embedding (g ∘ f) :=
|
||||
begin
|
||||
intros, apply @(is_equiv.homotopy_closed (ap g ∘ ap f)),
|
||||
{ apply is_equiv_compose},
|
||||
symmetry, exact ap_compose g f
|
||||
end
|
||||
|
||||
definition is_surjective_compose (g : B → C) (f : A → B)
|
||||
(H₁ : is_surjective g) (H₂ : is_surjective f) : is_surjective (g ∘ f) :=
|
||||
begin
|
||||
intro c, induction H₁ c with b p, induction H₂ b with a q,
|
||||
exact image.mk a (ap g q ⬝ p)
|
||||
end
|
||||
|
||||
definition is_split_surjective_compose (g : B → C) (f : A → B)
|
||||
(H₁ : is_split_surjective g) (H₂ : is_split_surjective f) : is_split_surjective (g ∘ f) :=
|
||||
begin
|
||||
intro c, induction H₁ c with b p, induction H₂ b with a q,
|
||||
exact fiber.mk a (ap g q ⬝ p)
|
||||
end
|
||||
|
||||
definition is_injective_compose (g : B → C) (f : A → B)
|
||||
(H₁ : Π⦃b b'⦄, g b = g b' → b = b') (H₂ : Π⦃a a'⦄, f a = f a' → a = a')
|
||||
⦃a a' : A⦄ (p : g (f a) = g (f a')) : a = a' :=
|
||||
H₂ (H₁ p)
|
||||
|
||||
/-
|
||||
The definitions
|
||||
is_surjective_of_is_equiv
|
||||
is_equiv_equiv_is_embedding_times_is_surjective
|
||||
are in types.trunc
|
||||
|
||||
See types.arrow_2 for retractions
|
||||
-/
|
||||
|
||||
end function
|
||||
|
|
@ -1,156 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Declaration of the coequalizer
|
||||
-/
|
||||
|
||||
import types.equiv .quotient
|
||||
|
||||
open quotient eq equiv is_trunc sigma sigma.ops
|
||||
|
||||
namespace coeq
|
||||
section
|
||||
|
||||
universe u
|
||||
parameters {A B : Type.{u}} (f g : A → B)
|
||||
|
||||
inductive coeq_rel : B → B → Type :=
|
||||
| Rmk : Π(x : A), coeq_rel (f x) (g x)
|
||||
open coeq_rel
|
||||
local abbreviation R := coeq_rel
|
||||
|
||||
definition coeq : Type := quotient coeq_rel -- TODO: define this in root namespace
|
||||
|
||||
definition coeq_i (x : B) : coeq :=
|
||||
class_of R x
|
||||
|
||||
/- cp is the name Coq uses. I don't know what it abbreviates, but at least it's short :-) -/
|
||||
definition cp (x : A) : coeq_i (f x) = coeq_i (g x) :=
|
||||
eq_of_rel coeq_rel (Rmk f g x)
|
||||
|
||||
protected definition rec {P : coeq → Type} (P_i : Π(x : B), P (coeq_i x))
|
||||
(Pcp : Π(x : A), P_i (f x) =[cp x] P_i (g x)) (y : coeq) : P y :=
|
||||
begin
|
||||
induction y,
|
||||
{ apply P_i},
|
||||
{ cases H, apply Pcp}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : coeq → Type} (y : coeq)
|
||||
(P_i : Π(x : B), P (coeq_i x)) (Pcp : Π(x : A), P_i (f x) =[cp x] P_i (g x)) : P y :=
|
||||
rec P_i Pcp y
|
||||
|
||||
theorem rec_cp {P : coeq → Type} (P_i : Π(x : B), P (coeq_i x))
|
||||
(Pcp : Π(x : A), P_i (f x) =[cp x] P_i (g x))
|
||||
(x : A) : apd (rec P_i Pcp) (cp x) = Pcp x :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected definition elim {P : Type} (P_i : B → P)
|
||||
(Pcp : Π(x : A), P_i (f x) = P_i (g x)) (y : coeq) : P :=
|
||||
rec P_i (λx, pathover_of_eq _ (Pcp x)) y
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (y : coeq) (P_i : B → P)
|
||||
(Pcp : Π(x : A), P_i (f x) = P_i (g x)) : P :=
|
||||
elim P_i Pcp y
|
||||
|
||||
theorem elim_cp {P : Type} (P_i : B → P) (Pcp : Π(x : A), P_i (f x) = P_i (g x))
|
||||
(x : A) : ap (elim P_i Pcp) (cp x) = Pcp x :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (cp x)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_cp],
|
||||
end
|
||||
|
||||
protected definition elim_type (P_i : B → Type)
|
||||
(Pcp : Π(x : A), P_i (f x) ≃ P_i (g x)) (y : coeq) : Type :=
|
||||
elim P_i (λx, ua (Pcp x)) y
|
||||
|
||||
protected definition elim_type_on [reducible] (y : coeq) (P_i : B → Type)
|
||||
(Pcp : Π(x : A), P_i (f x) ≃ P_i (g x)) : Type :=
|
||||
elim_type P_i Pcp y
|
||||
|
||||
theorem elim_type_cp (P_i : B → Type) (Pcp : Π(x : A), P_i (f x) ≃ P_i (g x))
|
||||
(x : A) : transport (elim_type P_i Pcp) (cp x) = Pcp x :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim_type,elim_cp];apply cast_ua_fn
|
||||
|
||||
protected definition rec_prop {P : coeq → Type} [H : Πx, is_prop (P x)]
|
||||
(P_i : Π(x : B), P (coeq_i x)) (y : coeq) : P y :=
|
||||
rec P_i (λa, !is_prop.elimo) y
|
||||
|
||||
protected definition elim_prop {P : Type} [H : is_prop P] (P_i : B → P) (y : coeq) : P :=
|
||||
elim P_i (λa, !is_prop.elim) y
|
||||
|
||||
end
|
||||
|
||||
end coeq
|
||||
|
||||
attribute coeq.coeq_i [constructor]
|
||||
attribute coeq.rec coeq.elim [unfold 8] [recursor 8]
|
||||
attribute coeq.elim_type [unfold 7]
|
||||
attribute coeq.rec_on coeq.elim_on [unfold 6]
|
||||
attribute coeq.elim_type_on [unfold 5]
|
||||
|
||||
/- Flattening -/
|
||||
namespace coeq
|
||||
section
|
||||
open function
|
||||
|
||||
universe u
|
||||
parameters {A B : Type.{u}} (f g : A → B) (P_i : B → Type)
|
||||
(Pcp : Πx : A, P_i (f x) ≃ P_i (g x))
|
||||
|
||||
local abbreviation P := coeq.elim_type f g P_i Pcp
|
||||
|
||||
local abbreviation F : sigma (P_i ∘ f) → sigma P_i :=
|
||||
λz, ⟨f z.1, z.2⟩
|
||||
|
||||
local abbreviation G : sigma (P_i ∘ f) → sigma P_i :=
|
||||
λz, ⟨g z.1, Pcp z.1 z.2⟩
|
||||
|
||||
local abbreviation Pr : Π⦃b b' : B⦄,
|
||||
coeq_rel f g b b' → P_i b ≃ P_i b' :=
|
||||
@coeq_rel.rec A B f g _ Pcp
|
||||
|
||||
local abbreviation P' := quotient.elim_type P_i Pr
|
||||
|
||||
protected definition flattening : sigma P ≃ coeq F G :=
|
||||
begin
|
||||
have H : Πz, P z ≃ P' z,
|
||||
begin
|
||||
intro z, apply equiv_of_eq,
|
||||
have H1 : coeq.elim_type f g P_i Pcp = quotient.elim_type P_i Pr,
|
||||
begin
|
||||
change
|
||||
quotient.rec P_i
|
||||
(λb b' r, coeq_rel.cases_on r (λx, pathover_of_eq _ (ua (Pcp x))))
|
||||
= quotient.rec P_i
|
||||
(λb b' r, pathover_of_eq _ (ua (coeq_rel.cases_on r Pcp))),
|
||||
have H2 : Π⦃b b' : B⦄ (r : coeq_rel f g b b'),
|
||||
coeq_rel.cases_on r (λx, pathover_of_eq _ (ua (Pcp x)))
|
||||
= pathover_of_eq _ (ua (coeq_rel.cases_on r Pcp))
|
||||
:> P_i b =[eq_of_rel (coeq_rel f g) r] P_i b',
|
||||
begin intros b b' r, cases r, reflexivity end,
|
||||
rewrite (eq_of_homotopy3 H2)
|
||||
end,
|
||||
apply ap10 H1
|
||||
end,
|
||||
apply equiv.trans (sigma_equiv_sigma_right H),
|
||||
apply equiv.trans !quotient.flattening.flattening_lemma,
|
||||
fapply quotient.equiv,
|
||||
{ reflexivity },
|
||||
{ intros bp bp',
|
||||
fapply equiv.MK,
|
||||
{ intro r, induction r with b b' r p,
|
||||
induction r with x, exact coeq_rel.Rmk F G ⟨x, p⟩ },
|
||||
{ esimp, intro r, induction r with xp,
|
||||
induction xp with x p,
|
||||
exact quotient.flattening.flattening_rel.mk Pr
|
||||
(coeq_rel.Rmk f g x) p },
|
||||
{ esimp, intro r, induction r with xp,
|
||||
induction xp with x p, reflexivity },
|
||||
{ intro r, induction r with b b' r p,
|
||||
induction r with x, reflexivity } }
|
||||
end
|
||||
end
|
||||
end coeq
|
||||
|
|
@ -1,203 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Definition of general colimits and sequential colimits.
|
||||
-/
|
||||
|
||||
/- definition of a general colimit -/
|
||||
open eq nat quotient sigma equiv is_trunc
|
||||
|
||||
namespace colimit
|
||||
section
|
||||
parameters {I J : Type} (A : I → Type) (dom cod : J → I)
|
||||
(f : Π(j : J), A (dom j) → A (cod j))
|
||||
variables {i : I} (a : A i) (j : J) (b : A (dom j))
|
||||
|
||||
local abbreviation B := Σ(i : I), A i
|
||||
inductive colim_rel : B → B → Type :=
|
||||
| Rmk : Π{j : J} (a : A (dom j)), colim_rel ⟨cod j, f j a⟩ ⟨dom j, a⟩
|
||||
open colim_rel
|
||||
local abbreviation R := colim_rel
|
||||
|
||||
-- TODO: define this in root namespace
|
||||
definition colimit : Type :=
|
||||
quotient colim_rel
|
||||
|
||||
definition incl : colimit :=
|
||||
class_of R ⟨i, a⟩
|
||||
abbreviation ι := @incl
|
||||
|
||||
definition cglue : ι (f j b) = ι b :=
|
||||
eq_of_rel colim_rel (Rmk f b)
|
||||
|
||||
protected definition rec {P : colimit → Type}
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x)
|
||||
(y : colimit) : P y :=
|
||||
begin
|
||||
fapply (quotient.rec_on y),
|
||||
{ intro a, cases a, apply Pincl},
|
||||
{ intro a a' H, cases H, apply Pglue}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : colimit → Type} (y : colimit)
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x) : P y :=
|
||||
rec Pincl Pglue y
|
||||
|
||||
theorem rec_cglue {P : colimit → Type}
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P (ι x))
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) =[cglue j x] Pincl x)
|
||||
{j : J} (x : A (dom j)) : apd (rec Pincl Pglue) (cglue j x) = Pglue j x :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected definition elim {P : Type} (Pincl : Π⦃i : I⦄ (x : A i), P)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x) (y : colimit) : P :=
|
||||
rec Pincl (λj a, pathover_of_eq _ (Pglue j a)) y
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (y : colimit)
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x) : P :=
|
||||
elim Pincl Pglue y
|
||||
|
||||
theorem elim_cglue {P : Type}
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) = Pincl x)
|
||||
{j : J} (x : A (dom j)) : ap (elim Pincl Pglue) (cglue j x) = Pglue j x :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (cglue j x)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_cglue],
|
||||
end
|
||||
|
||||
protected definition elim_type (Pincl : Π⦃i : I⦄ (x : A i), Type)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x) (y : colimit) : Type :=
|
||||
elim Pincl (λj a, ua (Pglue j a)) y
|
||||
|
||||
protected definition elim_type_on [reducible] (y : colimit)
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), Type)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x) : Type :=
|
||||
elim_type Pincl Pglue y
|
||||
|
||||
theorem elim_type_cglue (Pincl : Π⦃i : I⦄ (x : A i), Type)
|
||||
(Pglue : Π(j : J) (x : A (dom j)), Pincl (f j x) ≃ Pincl x)
|
||||
{j : J} (x : A (dom j)) : transport (elim_type Pincl Pglue) (cglue j x) = Pglue j x :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim_type,elim_cglue];apply cast_ua_fn
|
||||
|
||||
protected definition rec_prop {P : colimit → Type} [H : Πx, is_prop (P x)]
|
||||
(Pincl : Π⦃i : I⦄ (x : A i), P (ι x)) (y : colimit) : P y :=
|
||||
rec Pincl (λa b, !is_prop.elimo) y
|
||||
|
||||
protected definition elim_prop {P : Type} [H : is_prop P] (Pincl : Π⦃i : I⦄ (x : A i), P)
|
||||
(y : colimit) : P :=
|
||||
elim Pincl (λa b, !is_prop.elim) y
|
||||
|
||||
end
|
||||
end colimit
|
||||
|
||||
/- definition of a sequential colimit -/
|
||||
namespace seq_colim
|
||||
section
|
||||
/-
|
||||
we define it directly in terms of quotients. An alternative definition could be
|
||||
definition seq_colim := colimit.colimit A id succ f
|
||||
-/
|
||||
parameters {A : ℕ → Type} (f : Π⦃n⦄, A n → A (succ n))
|
||||
variables {n : ℕ} (a : A n)
|
||||
|
||||
local abbreviation B := Σ(n : ℕ), A n
|
||||
inductive seq_rel : B → B → Type :=
|
||||
| Rmk : Π{n : ℕ} (a : A n), seq_rel ⟨succ n, f a⟩ ⟨n, a⟩
|
||||
open seq_rel
|
||||
local abbreviation R := seq_rel
|
||||
|
||||
-- TODO: define this in root namespace
|
||||
definition seq_colim : Type :=
|
||||
quotient seq_rel
|
||||
|
||||
definition inclusion : seq_colim :=
|
||||
class_of R ⟨n, a⟩
|
||||
|
||||
abbreviation sι := @inclusion
|
||||
|
||||
definition glue : sι (f a) = sι a :=
|
||||
eq_of_rel seq_rel (Rmk f a)
|
||||
|
||||
protected definition rec {P : seq_colim → Type}
|
||||
(Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
|
||||
(Pglue : Π(n : ℕ) (a : A n), Pincl (f a) =[glue a] Pincl a) (aa : seq_colim) : P aa :=
|
||||
begin
|
||||
fapply (quotient.rec_on aa),
|
||||
{ intro a, cases a, apply Pincl},
|
||||
{ intro a a' H, cases H, apply Pglue}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : seq_colim → Type} (aa : seq_colim)
|
||||
(Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) =[glue a] Pincl a)
|
||||
: P aa :=
|
||||
rec Pincl Pglue aa
|
||||
|
||||
theorem rec_glue {P : seq_colim → Type} (Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a))
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) =[glue a] Pincl a) {n : ℕ} (a : A n)
|
||||
: apd (rec Pincl Pglue) (glue a) = Pglue a :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected definition elim {P : Type} (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) : seq_colim → P :=
|
||||
rec Pincl (λn a, pathover_of_eq _ (Pglue a))
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (aa : seq_colim)
|
||||
(Pincl : Π⦃n : ℕ⦄ (a : A n), P)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) : P :=
|
||||
elim Pincl Pglue aa
|
||||
|
||||
theorem elim_glue {P : Type} (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) = Pincl a) {n : ℕ} (a : A n)
|
||||
: ap (elim Pincl Pglue) (glue a) = Pglue a :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (glue a)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_glue],
|
||||
end
|
||||
|
||||
protected definition elim_type (Pincl : Π⦃n : ℕ⦄ (a : A n), Type)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) : seq_colim → Type :=
|
||||
elim Pincl (λn a, ua (Pglue a))
|
||||
|
||||
protected definition elim_type_on [reducible] (aa : seq_colim)
|
||||
(Pincl : Π⦃n : ℕ⦄ (a : A n), Type)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) : Type :=
|
||||
elim_type Pincl Pglue aa
|
||||
|
||||
theorem elim_type_glue (Pincl : Π⦃n : ℕ⦄ (a : A n), Type)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) {n : ℕ} (a : A n)
|
||||
: transport (elim_type Pincl Pglue) (glue a) = Pglue a :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim_type,elim_glue]; apply cast_ua_fn
|
||||
|
||||
theorem elim_type_glue_inv (Pincl : Π⦃n : ℕ⦄ (a : A n), Type)
|
||||
(Pglue : Π⦃n : ℕ⦄ (a : A n), Pincl (f a) ≃ Pincl a) {n : ℕ} (a : A n)
|
||||
: transport (seq_colim.elim_type f Pincl Pglue) (glue a)⁻¹ = to_inv (Pglue a) :=
|
||||
by rewrite [tr_eq_cast_ap_fn, ↑seq_colim.elim_type, ap_inv, elim_glue]; apply cast_ua_inv_fn
|
||||
|
||||
protected definition rec_prop {P : seq_colim → Type} [H : Πx, is_prop (P x)]
|
||||
(Pincl : Π⦃n : ℕ⦄ (a : A n), P (sι a)) (aa : seq_colim) : P aa :=
|
||||
rec Pincl (λa b, !is_prop.elimo) aa
|
||||
|
||||
protected definition elim_prop {P : Type} [H : is_prop P] (Pincl : Π⦃n : ℕ⦄ (a : A n), P)
|
||||
: seq_colim → P :=
|
||||
elim Pincl (λa b, !is_prop.elim)
|
||||
|
||||
|
||||
end
|
||||
end seq_colim
|
||||
|
||||
attribute colimit.incl seq_colim.inclusion [constructor]
|
||||
attribute colimit.rec colimit.elim [unfold 10] [recursor 10]
|
||||
attribute colimit.elim_type [unfold 9]
|
||||
attribute colimit.rec_on colimit.elim_on [unfold 8]
|
||||
attribute colimit.elim_type_on [unfold 7]
|
||||
attribute seq_colim.rec seq_colim.elim [unfold 6] [recursor 6]
|
||||
attribute seq_colim.elim_type [unfold 5]
|
||||
attribute seq_colim.rec_on seq_colim.elim_on [unfold 4]
|
||||
attribute seq_colim.elim_type_on [unfold 3]
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
/-
|
||||
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 .two_quotient .colimit .coeq .refl_quotient
|
||||
|
|
@ -1,247 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015-16 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
The groupoid quotient. This is a 1-type which path spaces is the same as the morphisms
|
||||
a given groupoid. We define it as the 1-truncation of a two quotient.
|
||||
-/
|
||||
|
||||
import algebra.category.groupoid .two_quotient homotopy.connectedness
|
||||
algebra.group_theory
|
||||
|
||||
open trunc_two_quotient eq bool unit relation category e_closure iso is_trunc trunc equiv is_equiv
|
||||
group
|
||||
|
||||
namespace groupoid_quotient
|
||||
section
|
||||
parameter (G : Groupoid)
|
||||
|
||||
inductive groupoid_quotient_R : G → G → Type :=
|
||||
| Rmk : Π{a b : G} (f : a ⟶ b), groupoid_quotient_R a b
|
||||
|
||||
open groupoid_quotient_R
|
||||
local abbreviation R := groupoid_quotient_R
|
||||
|
||||
inductive groupoid_quotient_Q : Π⦃x y : G⦄,
|
||||
e_closure groupoid_quotient_R x y → e_closure groupoid_quotient_R x y → Type :=
|
||||
| Qconcat : Π{a b c : G} (g : b ⟶ c) (f : a ⟶ b),
|
||||
groupoid_quotient_Q [Rmk (g ∘ f)] ([Rmk f] ⬝r [Rmk g])
|
||||
|
||||
open groupoid_quotient_Q
|
||||
local abbreviation Q := groupoid_quotient_Q
|
||||
|
||||
definition groupoid_quotient := trunc_two_quotient 1 R Q
|
||||
|
||||
local attribute groupoid_quotient [reducible]
|
||||
definition is_trunc_groupoid_quotient [instance] : is_trunc 1 groupoid_quotient := _
|
||||
|
||||
parameter {G}
|
||||
variables {a b c : G}
|
||||
definition elt (a : G) : groupoid_quotient := incl0 a
|
||||
definition pth (f : a ⟶ b) : elt a = elt b := incl1 (Rmk f)
|
||||
definition resp_comp (g : b ⟶ c) (f : a ⟶ b) : pth (g ∘ f) = pth f ⬝ pth g := incl2 (Qconcat g f)
|
||||
definition resp_id (a : G) : pth (ID a) = idp :=
|
||||
begin
|
||||
apply cancel_right (pth (id)), refine _ ⬝ !idp_con⁻¹,
|
||||
refine !resp_comp⁻¹ ⬝ _,
|
||||
exact ap pth !id_id,
|
||||
end
|
||||
|
||||
definition resp_inv (f : a ⟶ b) : pth (f⁻¹) = (pth f)⁻¹ :=
|
||||
begin
|
||||
apply eq_inv_of_con_eq_idp',
|
||||
refine !resp_comp⁻¹ ⬝ _,
|
||||
refine ap pth !right_inverse ⬝ _,
|
||||
apply resp_id
|
||||
end
|
||||
|
||||
protected definition rec {P : groupoid_quotient → Type} [Πx, is_trunc 1 (P x)]
|
||||
(Pe : Πg, P (elt g)) (Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a =[pth f] Pe b)
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b),
|
||||
change_path (resp_comp g f) (Pp (g ∘ f)) = Pp f ⬝o Pp g)
|
||||
(x : groupoid_quotient) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ apply Pe},
|
||||
{ induction s with a b f, apply Pp},
|
||||
{ induction q with a b c g f,
|
||||
apply Pcomp}
|
||||
end
|
||||
|
||||
protected definition rec_on {P : groupoid_quotient → Type} [Πx, is_trunc 1 (P x)]
|
||||
(x : groupoid_quotient)
|
||||
(Pe : Πg, P (elt g)) (Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a =[pth f] Pe b)
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b),
|
||||
change_path (resp_comp g f) (Pp (g ∘ f)) = Pp f ⬝o Pp g) : P x :=
|
||||
rec Pe Pp Pcomp x
|
||||
|
||||
protected definition set_rec {P : groupoid_quotient → Type} [Πx, is_set (P x)]
|
||||
(Pe : Πg, P (elt g)) (Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a =[pth f] Pe b)
|
||||
(x : groupoid_quotient) : P x :=
|
||||
rec Pe Pp !center x
|
||||
|
||||
protected definition prop_rec {P : groupoid_quotient → Type} [Πx, is_prop (P x)]
|
||||
(Pe : Πg, P (elt g)) (x : groupoid_quotient) : P x :=
|
||||
rec Pe !center !center x
|
||||
|
||||
definition rec_pth {P : groupoid_quotient → Type} [Πx, is_trunc 1 (P x)]
|
||||
{Pe : Πg, P (elt g)} {Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a =[pth f] Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b),
|
||||
change_path (resp_comp g f) (Pp (g ∘ f)) = Pp f ⬝o Pp g)
|
||||
{a b : G} (f : a ⟶ b) : apd (rec Pe Pp Pcomp) (pth f) = Pp f :=
|
||||
proof !rec_incl1 qed
|
||||
|
||||
protected definition elim {P : Type} [is_trunc 1 P] (Pe : G → P)
|
||||
(Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a = Pe b)
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b), Pp (g ∘ f) = Pp f ⬝ Pp g)
|
||||
(x : groupoid_quotient) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact Pe a},
|
||||
{ induction s with a b f, exact Pp f},
|
||||
{ induction q with a b c g f,
|
||||
exact Pcomp g f}
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} [is_trunc 1 P] (x : groupoid_quotient)
|
||||
(Pe : G → P) (Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a = Pe b)
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b), Pp (g ∘ f) = Pp f ⬝ Pp g) : P :=
|
||||
elim Pe Pp Pcomp x
|
||||
|
||||
protected definition set_elim [reducible] {P : Type} [is_set P] (Pe : G → P)
|
||||
(Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a = Pe b)
|
||||
(x : groupoid_quotient) : P :=
|
||||
elim Pe Pp !center x
|
||||
|
||||
protected definition prop_elim [reducible] {P : Type} [is_prop P] (Pe : G → P)
|
||||
(x : groupoid_quotient) : P :=
|
||||
elim Pe !center !center x
|
||||
|
||||
definition elim_pth {P : Type} [is_trunc 1 P] {Pe : G → P} {Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a = Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b), Pp (g ∘ f) = Pp f ⬝ Pp g) {a b : G} (f : a ⟶ b) :
|
||||
ap (elim Pe Pp Pcomp) (pth f) = Pp f :=
|
||||
!elim_incl1
|
||||
|
||||
-- The following rule is also true because P is a 1-type, and can be proven by `!is_set.elims`
|
||||
-- The following is the canonical proofs which holds for any truncated two-quotient.
|
||||
theorem elim_resp_comp {P : Type} [is_trunc 1 P] {Pe : G → P}
|
||||
{Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a = Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b), Pp (g ∘ f) = Pp f ⬝ Pp g)
|
||||
{a b c : G} (g : b ⟶ c) (f : a ⟶ b)
|
||||
: square (ap02 (elim Pe Pp Pcomp) (resp_comp g f))
|
||||
(Pcomp g f)
|
||||
(elim_pth Pcomp (g ∘ f))
|
||||
(!ap_con ⬝ (elim_pth Pcomp f ◾ elim_pth Pcomp g)) :=
|
||||
proof !elim_incl2 qed
|
||||
|
||||
protected definition elim_set.{u} (Pe : G → Set.{u}) (Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a ≃ Pe b)
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b) (x : Pe a), Pp (g ∘ f) x = Pp g (Pp f x))
|
||||
(x : groupoid_quotient) : Set.{u} :=
|
||||
elim Pe (λa b f, tua (Pp f)) (λa b c g f, ap tua (equiv_eq (Pcomp g f)) ⬝ !tua_trans) x
|
||||
|
||||
theorem elim_set_pth {Pe : G → Set} {Pp : Π⦃a b⦄ (f : a ⟶ b), Pe a ≃ Pe b}
|
||||
(Pcomp : Π⦃a b c⦄ (g : b ⟶ c) (f : a ⟶ b) (x : Pe a), Pp (g ∘ f) x = Pp g (Pp f x))
|
||||
{a b : G} (f : a ⟶ b) :
|
||||
transport (elim_set Pe Pp Pcomp) (pth f) = Pp f :=
|
||||
by rewrite [tr_eq_cast_ap_fn, ↑elim_set, ▸*, ap_compose' trunctype.carrier, elim_pth];
|
||||
apply tcast_tua_fn
|
||||
|
||||
end
|
||||
end groupoid_quotient
|
||||
|
||||
attribute groupoid_quotient.elt [constructor]
|
||||
attribute groupoid_quotient.rec groupoid_quotient.elim [unfold 7] [recursor 7]
|
||||
attribute groupoid_quotient.rec_on groupoid_quotient.elim_on [unfold 4]
|
||||
attribute groupoid_quotient.set_rec groupoid_quotient.set_elim [unfold 6]
|
||||
attribute groupoid_quotient.prop_rec groupoid_quotient.prop_elim
|
||||
groupoid_quotient.elim_set [unfold 5]
|
||||
|
||||
|
||||
open sigma pi is_conn function
|
||||
namespace groupoid_quotient
|
||||
section
|
||||
universe variables u v
|
||||
variables {G : Groupoid.{u v}} (a : G) {b c : G}
|
||||
|
||||
include a
|
||||
|
||||
protected definition code [unfold 3] (x : groupoid_quotient G) : Set.{v} :=
|
||||
begin
|
||||
refine groupoid_quotient.elim_set _ _ _ x,
|
||||
{ intro b, exact homset a b},
|
||||
{ intro b c g, exact equiv_postcompose g},
|
||||
{ intro b c d h g f, esimp at *, apply assoc'}
|
||||
end
|
||||
|
||||
omit a
|
||||
|
||||
local abbreviation code [unfold 3] := @groupoid_quotient.code G a
|
||||
|
||||
variable {a}
|
||||
protected definition encode [unfold 4] (x : groupoid_quotient G) (p : elt a = x) : code a x :=
|
||||
transport (code a) p (ID a)
|
||||
|
||||
protected definition decode [unfold 3] (x : groupoid_quotient G) (z : code a x) : elt a = x :=
|
||||
begin
|
||||
induction x using groupoid_quotient.set_rec with b b c g,
|
||||
{ esimp, exact pth z},
|
||||
{ apply arrow_pathover_left, esimp, intro f, apply eq_pathover_constant_left_id_right,
|
||||
apply square_of_eq, refine !resp_comp⁻¹ ⬝ _ ⬝ !idp_con⁻¹, rewrite elim_set_pth}
|
||||
end
|
||||
|
||||
local abbreviation encode [unfold_full] := @groupoid_quotient.encode G a
|
||||
local abbreviation decode [unfold_full] := @groupoid_quotient.decode G a
|
||||
|
||||
protected definition decode_encode (x : groupoid_quotient G) (p : elt a = x) :
|
||||
decode x (encode x p) = p :=
|
||||
begin induction p, esimp, apply resp_id end
|
||||
|
||||
protected definition encode_decode (x : groupoid_quotient G) (z : code a x) :
|
||||
encode x (decode x z) = z :=
|
||||
begin
|
||||
induction x using groupoid_quotient.prop_rec with b,
|
||||
esimp, refine ap10 !elim_set_pth.{u v v} (ID a) ⬝ _, esimp,
|
||||
apply id_right
|
||||
end
|
||||
|
||||
definition decode_comp (z : code a (elt b)) (z' : code b (elt c)) :
|
||||
decode (elt c) (z' ∘ z) = decode (elt b) z ⬝ decode (elt c) z' :=
|
||||
!resp_comp
|
||||
|
||||
variables (a b)
|
||||
definition elt_eq_elt_equiv [constructor] : (elt a = elt b) ≃ (a ⟶ b) :=
|
||||
equiv.MK (encode (elt b)) (decode (elt b))
|
||||
(groupoid_quotient.encode_decode (elt b)) (groupoid_quotient.decode_encode (elt b))
|
||||
|
||||
variables {a b}
|
||||
definition encode_con (p : elt a = elt b)
|
||||
(q : elt b = elt c) : encode (elt c) (p ⬝ q) = encode (elt c) q ∘ encode (elt b) p :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn (elt_eq_elt_equiv a c)⁻¹ᵉ,
|
||||
refine !right_inv ⬝ _ ⬝ !decode_comp⁻¹,
|
||||
apply concat2, do 2 exact (to_left_inv !elt_eq_elt_equiv _)⁻¹
|
||||
end
|
||||
|
||||
variable (G)
|
||||
definition is_conn_groupoid_quotient [H : is_conn 0 G] : is_conn 0 (groupoid_quotient G) :=
|
||||
begin
|
||||
have g : trunc 0 G, from !center,
|
||||
induction g with g,
|
||||
have p : Πh, ∥ g = h ∥,
|
||||
begin
|
||||
intro h, refine !tr_eq_tr_equiv _, apply is_prop.elim
|
||||
end,
|
||||
fapply is_contr.mk,
|
||||
{ apply trunc_functor 0 elt (tr g)},
|
||||
{ intro x, induction x with x,
|
||||
induction x using groupoid_quotient.prop_rec with b, esimp,
|
||||
induction p b with q, exact ap (tr ∘ elt) q}
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
end groupoid_quotient
|
||||
|
||||
export [unfold] groupoid_quotient
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
hit
|
||||
===
|
||||
|
||||
Declaration and theorems of higher inductive types in Lean. We take
|
||||
two higher inductive types (hits) as primitive notions in Lean. We
|
||||
define all other hits in terms of these two hits. The hits which are
|
||||
primitive are n-truncation and quotients. These are defined in
|
||||
[init.hit](../init/hit.hlean) and they have definitional computation
|
||||
rules on the point constructors.
|
||||
|
||||
Here we find hits related to the basic structure theory of HoTT. The
|
||||
hits related to homotopy theory are defined in
|
||||
[homotopy](../homotopy/homotopy.md).
|
||||
|
||||
Files in this folder:
|
||||
|
||||
* [quotient](quotient.hlean): quotients, primitive
|
||||
* [trunc](trunc.hlean): truncation, primitive
|
||||
* [colimit](colimit.hlean): Colimits of arbitrary diagrams and sequential colimits, defined using quotients
|
||||
* [pushout](pushout.hlean): Pushouts, defined using quotients
|
||||
* [coeq](coeq.hlean): Co-equalizers, defined using quotients
|
||||
* [set_quotient](set_quotient.hlean): Set-quotients, defined using quotients and set-truncation
|
||||
* [prop_trunc](prop_trunc.hlean): The construction of the propositional truncation from quotients.
|
||||
|
||||
The following hits have also 2-constructors. They are defined only using quotients.
|
||||
* [two_quotient](two_quotient.hlean): Quotients where you can also specify 2-paths. These are used for all hits which have 2-constructors, and they are almost fully general for such hits, as long as they are nonrecursive
|
||||
* [refl_quotient](refl_quotient.hlean): Quotients where you can also specify 2-paths
|
||||
* [groupoid_quotient](groupoid_quotient.hlean): The realization or quotient of a groupoid.
|
||||
|
|
@ -1,427 +0,0 @@
|
|||
import function types.trunc hit.colimit homotopy.connectedness --types.nat.hott hit.trunc cubical.square
|
||||
|
||||
open eq is_trunc unit quotient seq_colim pi nat equiv sum algebra is_conn function
|
||||
|
||||
/-
|
||||
In this file we define the propositional truncation, which, given (X : Type)
|
||||
has constructors
|
||||
* tr : X → trunc X
|
||||
* is_prop_trunc : is_prop (trunc X)
|
||||
and with a recursor which recurses to any family of mere propositions.
|
||||
|
||||
The construction uses a "one step truncation" of X, with two constructors:
|
||||
* tr : X → one_step_tr X
|
||||
* tr_eq : Π(a b : X), tr a = tr b
|
||||
This is like a truncation, but taking out the recursive part.
|
||||
Martin Escardo calls this construction the generalized circle, since the one step truncation of the
|
||||
unit type is the circle.
|
||||
|
||||
Then we can repeat this n times:
|
||||
A 0 = X,
|
||||
A (n + 1) = one_step_tr (A n)
|
||||
We have a map
|
||||
f {n : ℕ} : A n → A (n + 1) := tr
|
||||
Then trunc is defined as the sequential colimit of (A, f).
|
||||
|
||||
Both the one step truncation and the sequential colimit can be defined as a quotient, which is a
|
||||
primitive HIT in Lean. Here, with a quotient, we mean the following HIT:
|
||||
Given {X : Type} (R : X → X → Type) we have the constructors
|
||||
* class_of : X → quotient R
|
||||
* eq_of_rel : Π{a a' : X}, R a a' → a = a'
|
||||
|
||||
See the comment below for a sketch of the proof that (trunc A) is actually a mere proposition.
|
||||
-/
|
||||
|
||||
/- definition of "one step truncation" in terms of quotients -/
|
||||
|
||||
namespace one_step_tr
|
||||
section
|
||||
parameters {A : Type}
|
||||
variables (a a' : A)
|
||||
|
||||
protected definition R (a a' : A) : Type₀ := unit
|
||||
parameter (A)
|
||||
definition one_step_tr : Type := quotient R
|
||||
parameter {A}
|
||||
definition tr : one_step_tr :=
|
||||
class_of R a
|
||||
|
||||
definition tr_eq : tr a = tr a' :=
|
||||
eq_of_rel _ star
|
||||
|
||||
protected definition rec {P : one_step_tr → Type} (Pt : Π(a : A), P (tr a))
|
||||
(Pe : Π(a a' : A), Pt a =[tr_eq a a'] Pt a') (x : one_step_tr) : P x :=
|
||||
begin
|
||||
fapply (quotient.rec_on x),
|
||||
{ intro a, apply Pt},
|
||||
{ intro a a' H, cases H, apply Pe}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : one_step_tr → Type} (x : one_step_tr)
|
||||
(Pt : Π(a : A), P (tr a)) (Pe : Π(a a' : A), Pt a =[tr_eq a a'] Pt a') : P x :=
|
||||
rec Pt Pe x
|
||||
|
||||
protected definition elim {P : Type} (Pt : A → P)
|
||||
(Pe : Π(a a' : A), Pt a = Pt a') (x : one_step_tr) : P :=
|
||||
rec Pt (λa a', pathover_of_eq _ (Pe a a')) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : one_step_tr) (Pt : A → P)
|
||||
(Pe : Π(a a' : A), Pt a = Pt a') : P :=
|
||||
elim Pt Pe x
|
||||
|
||||
theorem rec_tr_eq {P : one_step_tr → Type} (Pt : Π(a : A), P (tr a))
|
||||
(Pe : Π(a a' : A), Pt a =[tr_eq a a'] Pt a') (a a' : A)
|
||||
: apd (rec Pt Pe) (tr_eq a a') = Pe a a' :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
theorem elim_tr_eq {P : Type} (Pt : A → P)
|
||||
(Pe : Π(a a' : A), Pt a = Pt a') (a a' : A)
|
||||
: ap (elim Pt Pe) (tr_eq a a') = Pe a a' :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (tr_eq a a')),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_tr_eq],
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
definition n_step_tr [reducible] (A : Type) (n : ℕ) : Type :=
|
||||
nat.rec_on n A (λn' A', one_step_tr A')
|
||||
|
||||
end one_step_tr
|
||||
|
||||
attribute one_step_tr.rec one_step_tr.elim [recursor 5] [unfold 5]
|
||||
attribute one_step_tr.rec_on one_step_tr.elim_on [unfold 2]
|
||||
attribute one_step_tr.tr [constructor]
|
||||
|
||||
namespace one_step_tr
|
||||
/- Theorems about the one-step truncation -/
|
||||
open homotopy trunc prod
|
||||
theorem tr_eq_ne_idp {A : Type} (a : A) : tr_eq a a ≠ idp :=
|
||||
begin
|
||||
intro p,
|
||||
have H2 : Π{X : Type₁} {x : X} {q : x = x}, q = idp,
|
||||
from λX x q, calc
|
||||
q = ap (one_step_tr.elim (λa, x) (λa b, q)) (tr_eq a a) : elim_tr_eq
|
||||
... = ap (one_step_tr.elim (λa, x) (λa b, q)) (refl (one_step_tr.tr a)) : by rewrite p
|
||||
... = idp : idp,
|
||||
exact bool.eq_bnot_ne_idp H2
|
||||
end
|
||||
|
||||
theorem tr_eq_ne_ap_tr {A : Type} {a b : A} (p : a = b) : tr_eq a b ≠ ap tr p :=
|
||||
by induction p; apply tr_eq_ne_idp
|
||||
|
||||
theorem not_inhabited_set_trunc_one_step_tr (A : Type)
|
||||
: ¬(trunc 1 (one_step_tr A) × is_set (trunc 1 (one_step_tr A))) :=
|
||||
begin
|
||||
intro H, induction H with x H,
|
||||
refine trunc.elim_on x _, clear x, intro x,
|
||||
induction x,
|
||||
{ have q : trunc -1 ((tr_eq a a) = idp),
|
||||
begin
|
||||
refine to_fun !tr_eq_tr_equiv _,
|
||||
refine @is_prop.elim _ _ _ _, apply is_trunc_equiv_closed, apply tr_eq_tr_equiv
|
||||
end,
|
||||
refine trunc.elim_on q _, clear q, intro p, exact !tr_eq_ne_idp p},
|
||||
{ apply is_prop.elim}
|
||||
end
|
||||
|
||||
theorem not_is_conn_one_step_tr (A : Type) : ¬is_conn 1 (one_step_tr A) :=
|
||||
λH, not_inhabited_set_trunc_one_step_tr A (!center, _)
|
||||
|
||||
theorem is_prop_trunc_one_step_tr (A : Type) : is_prop (trunc 0 (one_step_tr A)) :=
|
||||
begin
|
||||
apply is_prop.mk,
|
||||
intro x y,
|
||||
refine trunc.rec_on x _, refine trunc.rec_on y _, clear x y, intro y x,
|
||||
induction x,
|
||||
{ induction y,
|
||||
{ exact ap trunc.tr !tr_eq},
|
||||
{ apply is_prop.elimo}},
|
||||
{ apply is_prop.elimo}
|
||||
end
|
||||
|
||||
local attribute is_prop_trunc_one_step_tr [instance]
|
||||
|
||||
theorem trunc_0_one_step_tr_equiv (A : Type) : trunc 0 (one_step_tr A) ≃ ∥ A ∥ :=
|
||||
begin
|
||||
apply equiv_of_is_prop,
|
||||
{ intro x, refine trunc.rec _ x, clear x, intro x, induction x,
|
||||
{ exact trunc.tr a},
|
||||
{ apply is_prop.elim}},
|
||||
{ intro x, refine trunc.rec _ x, clear x, intro a, exact trunc.tr (tr a)},
|
||||
end
|
||||
|
||||
definition one_step_tr_functor [unfold 4] {A B : Type} (f : A → B) (x : one_step_tr A)
|
||||
: one_step_tr B :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact tr (f a)},
|
||||
{ apply tr_eq}
|
||||
end
|
||||
|
||||
definition one_step_tr_universal_property [constructor] (A B : Type)
|
||||
: (one_step_tr A → B) ≃ Σ(f : A → B), Π(x y : A), f x = f y :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, fconstructor, intro a, exact f (tr a), intros, exact ap f !tr_eq},
|
||||
{ intro v a, induction v with f p, induction a, exact f a, apply p},
|
||||
{ intro v, induction v with f p, esimp, apply ap (sigma.mk _), apply eq_of_homotopy2,
|
||||
intro a a', apply elim_tr_eq},
|
||||
{ intro f, esimp, apply eq_of_homotopy, intro a, induction a,
|
||||
reflexivity,
|
||||
apply eq_pathover, apply hdeg_square, rewrite [▸*,elim_tr_eq]},
|
||||
end
|
||||
|
||||
|
||||
end one_step_tr
|
||||
open one_step_tr
|
||||
|
||||
namespace prop_trunc
|
||||
namespace hide
|
||||
section
|
||||
parameter {X : Type}
|
||||
|
||||
/- basic constructors -/
|
||||
definition A [reducible] (n : ℕ) : Type := nat.rec_on n X (λn' X', one_step_tr X')
|
||||
definition f [reducible] ⦃n : ℕ⦄ (a : A n) : A (succ n) := tr a
|
||||
definition f_eq [reducible] {n : ℕ} (a a' : A n) : f a = f a' := tr_eq a a'
|
||||
definition truncX [reducible] : Type := @seq_colim A f
|
||||
definition i [reducible] {n : ℕ} (a : A n) : truncX := inclusion f a
|
||||
definition g [reducible] {n : ℕ} (a : A n) : i (f a) = i a := glue f a
|
||||
|
||||
/- defining the normal recursor is easy -/
|
||||
definition rec {P : truncX → Type} [Pt : Πx, is_prop (P x)]
|
||||
(H : Π(a : X), P (@i 0 a)) (x : truncX) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ induction n with n IH,
|
||||
{ exact H a},
|
||||
{ induction a,
|
||||
{ exact !g⁻¹ ▸ IH a},
|
||||
{ apply is_prop.elimo}}},
|
||||
{ apply is_prop.elimo}
|
||||
end
|
||||
|
||||
/-
|
||||
The main effort is to prove that truncX is a mere proposition.
|
||||
We prove
|
||||
Π(a b : truncX), a = b
|
||||
first by induction on a, using the induction principle we just proven and then by induction on b
|
||||
|
||||
On the point level we need to construct
|
||||
(1) a : A n, b : A m ⊢ p a b : i a = i b
|
||||
On the path level (for the induction on b) we need to show that
|
||||
(2) a : A n, b : A m ⊢ p a (f b) ⬝ g b = p a b
|
||||
The path level for a is automatic, since (Πb, a = b) is a mere proposition
|
||||
Thanks to Egbert Rijke for pointing this out
|
||||
|
||||
For (1) we distinguish the cases n ≤ m and n ≥ m,
|
||||
and we prove that the two constructions coincide for n = m
|
||||
|
||||
For (2) we distinguish the cases n ≤ m and n > m
|
||||
|
||||
During the proof we heavily use induction on inequalities.
|
||||
(n ≤ m), or (le n m), is defined as an inductive family:
|
||||
inductive le (n : ℕ) : ℕ → Type₀ :=
|
||||
| refl : le n n
|
||||
| step : Π {m}, le n m → le n (succ m)
|
||||
-/
|
||||
|
||||
|
||||
/- point operations -/
|
||||
|
||||
definition fr [reducible] [unfold 2] (n : ℕ) (a : X) : A n :=
|
||||
begin
|
||||
induction n with n x,
|
||||
{ exact a},
|
||||
{ exact f x},
|
||||
end
|
||||
|
||||
/- path operations -/
|
||||
|
||||
definition i_fr [unfold 2] (n : ℕ) (a : X) : i (fr n a) = @i 0 a :=
|
||||
begin
|
||||
induction n with n p,
|
||||
{ reflexivity},
|
||||
{ exact g (fr n a) ⬝ p},
|
||||
end
|
||||
|
||||
definition eq_same {n : ℕ} (a a' : A n) : i a = i a' :=
|
||||
calc
|
||||
i a = i (f a) : g
|
||||
... = i (f a') : ap i (f_eq a a')
|
||||
... = i a' : g
|
||||
|
||||
definition eq_constructors {n : ℕ} (a : X) (b : A n) : @i 0 a = i b :=
|
||||
calc
|
||||
i a = i (fr n a) : i_fr
|
||||
... = i b : eq_same
|
||||
|
||||
/- 2-dimensional path operations -/
|
||||
|
||||
theorem ap_i_ap_f {n : ℕ} {a a' : A n} (p : a = a') : !g⁻¹ ⬝ ap i (ap !f p) ⬝ !g = ap i p :=
|
||||
by induction p; apply con.left_inv
|
||||
|
||||
theorem ap_i_eq_ap_i_same {n : ℕ} {a a' : A n} (p q : a = a') : ap i p = ap i q :=
|
||||
@(is_weakly_constant_ap i) eq_same a a' p q
|
||||
|
||||
theorem ap_f_eq_f {n : ℕ} (a a' : A n)
|
||||
: !g⁻¹ ⬝ ap i (f_eq (f a) (f a')) ⬝ !g = ap i (f_eq a a') :=
|
||||
ap _ !ap_i_eq_ap_i_same ⬝ !ap_i_ap_f
|
||||
|
||||
theorem eq_same_f {n : ℕ} (a a' : A n)
|
||||
: (g a)⁻¹ ⬝ eq_same (f a) (f a') ⬝ g a' = eq_same a a' :=
|
||||
begin
|
||||
esimp [eq_same],
|
||||
apply (ap (λx, _ ⬝ x ⬝ _)),
|
||||
apply (ap_f_eq_f a a'),
|
||||
end
|
||||
|
||||
theorem eq_constructors_comp {n : ℕ} (a : X) (b : A n)
|
||||
: eq_constructors a (f b) ⬝ g b = eq_constructors a b :=
|
||||
begin
|
||||
rewrite [↑eq_constructors,▸*,↓fr n a,↓i_fr n a,con_inv,+con.assoc],
|
||||
apply ap (λx, _ ⬝ x),
|
||||
rewrite -con.assoc, exact !eq_same_f
|
||||
end
|
||||
|
||||
theorem is_prop_truncX : is_prop truncX :=
|
||||
begin
|
||||
apply is_prop_of_imp_is_contr,
|
||||
intro a,
|
||||
refine @rec _ _ _ a,
|
||||
clear a, intro a,
|
||||
fapply is_contr.mk,
|
||||
exact @i 0 a,
|
||||
intro b,
|
||||
induction b with n b n b,
|
||||
{ apply eq_constructors},
|
||||
{ apply (equiv.to_inv !eq_pathover_equiv_r), apply eq_constructors_comp}
|
||||
end
|
||||
|
||||
end
|
||||
end hide
|
||||
end prop_trunc
|
||||
|
||||
namespace prop_trunc
|
||||
open hide
|
||||
definition ptrunc.{u} (A : Type.{u}) : Type.{u} := @truncX A
|
||||
definition ptr {A : Type} : A → ptrunc A := @i A 0
|
||||
definition is_prop_trunc (A : Type) : is_prop (ptrunc A) := is_prop_truncX
|
||||
protected definition ptrunc.rec {A : Type} {P : ptrunc A → Type}
|
||||
[Pt : Π(x : ptrunc A), is_prop (P x)]
|
||||
(H : Π(a : A), P (ptr a)) : Π(x : ptrunc A), P x := @rec A P Pt H
|
||||
|
||||
example {A : Type} {P : ptrunc A → Type} [Pt : Πaa, is_prop (P aa)]
|
||||
(H : Πa, P (ptr a)) (a : A) : (ptrunc.rec H) (ptr a) = H a := by reflexivity
|
||||
|
||||
open sigma prod
|
||||
|
||||
-- the constructed truncation is equivalent to the "standard" propositional truncation
|
||||
-- (called _root_.trunc -1 below)
|
||||
open trunc
|
||||
attribute is_prop_trunc [instance]
|
||||
definition ptrunc_equiv_trunc (A : Type) : ptrunc A ≃ trunc -1 A :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro x, induction x using ptrunc.rec with a, exact tr a},
|
||||
{ intro x, refine trunc.rec _ x, intro a, exact ptr a},
|
||||
{ intro x, induction x with a, reflexivity},
|
||||
{ intro x, induction x using ptrunc.rec with a, reflexivity}
|
||||
end
|
||||
|
||||
-- some other recursors we get from this construction:
|
||||
definition trunc.elim2 {A P : Type} (h : Π{n}, n_step_tr A n → P)
|
||||
(coh : Π(n : ℕ) (a : n_step_tr A n), h (f a) = h a) (x : ptrunc A) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact h a},
|
||||
{ apply coh}
|
||||
end
|
||||
|
||||
definition trunc.rec2 {A : Type} {P : truncX → Type} (h : Π{n} (a : n_step_tr A n), P (i a))
|
||||
(coh : Π(n : ℕ) (a : n_step_tr A n), h (f a) =[g a] h a)
|
||||
(x : ptrunc A) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact h a},
|
||||
{ apply coh}
|
||||
end
|
||||
|
||||
definition elim2_equiv [constructor] (A P : Type) : (ptrunc A → P) ≃
|
||||
Σ(h : Π{n}, n_step_tr A n → P),
|
||||
Π(n : ℕ) (a : n_step_tr A n), @h (succ n) (one_step_tr.tr a) = h a :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro h, fconstructor,
|
||||
{ intro n a, refine h (i a)},
|
||||
{ intro n a, exact ap h (g a)}},
|
||||
{ intro x a, induction x with h p, induction a,
|
||||
exact h a,
|
||||
apply p},
|
||||
{ intro x, induction x with h p, fapply sigma_eq,
|
||||
{ reflexivity},
|
||||
{ esimp, apply pathover_idp_of_eq, apply eq_of_homotopy2, intro n a, xrewrite elim_glue}},
|
||||
{ intro h, apply eq_of_homotopy, intro a, esimp, induction a,
|
||||
esimp,
|
||||
apply eq_pathover, apply hdeg_square, esimp, rewrite elim_glue}
|
||||
end
|
||||
|
||||
open sigma.ops
|
||||
definition conditionally_constant_equiv {A P : Type} (k : A → P) :
|
||||
(Σ(g : ptrunc A → P), Πa, g (ptr a) = k a) ≃
|
||||
Σ(h : Π{n}, n_step_tr A n → P),
|
||||
(Π(n : ℕ) (a : n_step_tr A n), h (f a) = h a) × (Πa, @h 0 a = k a) :=
|
||||
calc
|
||||
(Σ(g : ptrunc A → P), Πa, g (ptr a) = k a)
|
||||
≃ Σ(v : Σ(h : Π{n}, n_step_tr A n → P), Π(n : ℕ) (a : n_step_tr A n), h (f a) = h a),
|
||||
Πa, (v.1) 0 a = k a
|
||||
: sigma_equiv_sigma !elim2_equiv (λg, equiv.rfl)
|
||||
... ≃ Σ(h : Π{n}, n_step_tr A n → P) (p : Π(n : ℕ) (a : n_step_tr A n), h (f a) = h a),
|
||||
Πa, @h 0 a = k a
|
||||
: sigma_assoc_equiv
|
||||
... ≃ Σ(h : Π{n}, n_step_tr A n → P),
|
||||
(Π(n : ℕ) (a : n_step_tr A n), h (f a) = h a) × (Πa, @h 0 a = k a)
|
||||
: sigma_equiv_sigma_right (λa, !equiv_prod)
|
||||
|
||||
definition cocone_of_is_collapsible {A : Type} (f : A → A) (p : Πa a', f a = f a')
|
||||
(n : ℕ) (x : n_step_tr A n) : A :=
|
||||
begin
|
||||
apply f,
|
||||
induction n with n h,
|
||||
{ exact x},
|
||||
{ apply to_inv !one_step_tr_universal_property ⟨f, p⟩, exact one_step_tr_functor h x}
|
||||
end
|
||||
|
||||
definition has_split_support_of_is_collapsible {A : Type} (f : A → A) (p : Πa a', f a = f a')
|
||||
: ptrunc A → A :=
|
||||
begin
|
||||
fapply to_inv !elim2_equiv,
|
||||
fconstructor,
|
||||
{ exact cocone_of_is_collapsible f p},
|
||||
{ intro n a, apply p}
|
||||
|
||||
end
|
||||
|
||||
end prop_trunc
|
||||
|
||||
open prop_trunc trunc
|
||||
-- Corollaries for the actual truncation.
|
||||
namespace is_trunc
|
||||
local attribute is_prop_trunc_one_step_tr [instance]
|
||||
definition is_prop.elim_set {A : Type} {P : Type} [is_set P] (f : A → P)
|
||||
(p : Πa a', f a = f a') (x : trunc -1 A) : P :=
|
||||
begin
|
||||
have y : trunc 0 (one_step_tr A),
|
||||
by induction x; exact trunc.tr (one_step_tr.tr a),
|
||||
induction y with y,
|
||||
induction y,
|
||||
{ exact f a},
|
||||
{ exact p a a'}
|
||||
end
|
||||
|
||||
definition is_prop.elim_set_tr {A : Type} {P : Type} {H : is_set P} (f : A → P)
|
||||
(p : Πa a', f a = f a') (a : A) : is_prop.elim_set f p (tr a) = f a :=
|
||||
by reflexivity
|
||||
|
||||
end is_trunc
|
||||
|
|
@ -1,378 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015-16 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Ulrik Buchholtz, Jakob von Raumer
|
||||
|
||||
Declaration and properties of the pushout
|
||||
-/
|
||||
|
||||
import .quotient types.sigma types.arrow_2
|
||||
|
||||
open quotient eq sum equiv is_trunc pointed
|
||||
|
||||
namespace pushout
|
||||
section
|
||||
|
||||
parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
|
||||
|
||||
local abbreviation A := BL + TR
|
||||
inductive pushout_rel : A → A → Type :=
|
||||
| Rmk : Π(x : TL), pushout_rel (inl (f x)) (inr (g x))
|
||||
open pushout_rel
|
||||
local abbreviation R := pushout_rel
|
||||
|
||||
definition pushout : Type := quotient R -- TODO: define this in root namespace
|
||||
|
||||
parameters {f g}
|
||||
definition inl (x : BL) : pushout :=
|
||||
class_of R (inl x)
|
||||
|
||||
definition inr (x : TR) : pushout :=
|
||||
class_of R (inr x)
|
||||
|
||||
definition glue (x : TL) : inl (f x) = inr (g x) :=
|
||||
eq_of_rel pushout_rel (Rmk f g x)
|
||||
|
||||
protected definition rec {P : pushout → Type} (Pinl : Π(x : BL), P (inl x))
|
||||
(Pinr : Π(x : TR), P (inr x)) (Pglue : Π(x : TL), Pinl (f x) =[glue x] Pinr (g x))
|
||||
(y : pushout) : P y :=
|
||||
begin
|
||||
induction y,
|
||||
{ cases a,
|
||||
apply Pinl,
|
||||
apply Pinr},
|
||||
{ cases H, apply Pglue}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : pushout → Type} (y : pushout)
|
||||
(Pinl : Π(x : BL), P (inl x)) (Pinr : Π(x : TR), P (inr x))
|
||||
(Pglue : Π(x : TL), Pinl (f x) =[glue x] Pinr (g x)) : P y :=
|
||||
rec Pinl Pinr Pglue y
|
||||
|
||||
theorem rec_glue {P : pushout → Type} (Pinl : Π(x : BL), P (inl x))
|
||||
(Pinr : Π(x : TR), P (inr x)) (Pglue : Π(x : TL), Pinl (f x) =[glue x] Pinr (g x))
|
||||
(x : TL) : apd (rec Pinl Pinr Pglue) (glue x) = Pglue x :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected definition elim {P : Type} (Pinl : BL → P) (Pinr : TR → P)
|
||||
(Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) (y : pushout) : P :=
|
||||
rec Pinl Pinr (λx, pathover_of_eq _ (Pglue x)) y
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (y : pushout) (Pinl : BL → P)
|
||||
(Pinr : TR → P) (Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) : P :=
|
||||
elim Pinl Pinr Pglue y
|
||||
|
||||
theorem elim_glue {P : Type} (Pinl : BL → P) (Pinr : TR → P)
|
||||
(Pglue : Π(x : TL), Pinl (f x) = Pinr (g x)) (x : TL)
|
||||
: ap (elim Pinl Pinr Pglue) (glue x) = Pglue x :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (glue x)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑pushout.elim,rec_glue],
|
||||
end
|
||||
|
||||
protected definition elim_type (Pinl : BL → Type) (Pinr : TR → Type)
|
||||
(Pglue : Π(x : TL), Pinl (f x) ≃ Pinr (g x)) : pushout → Type :=
|
||||
quotient.elim_type (sum.rec Pinl Pinr)
|
||||
begin intro v v' r, induction r, apply Pglue end
|
||||
|
||||
protected definition elim_type_on [reducible] (y : pushout) (Pinl : BL → Type)
|
||||
(Pinr : TR → Type) (Pglue : Π(x : TL), Pinl (f x) ≃ Pinr (g x)) : Type :=
|
||||
elim_type Pinl Pinr Pglue y
|
||||
|
||||
theorem elim_type_glue (Pinl : BL → Type) (Pinr : TR → Type)
|
||||
(Pglue : Π(x : TL), Pinl (f x) ≃ Pinr (g x)) (x : TL)
|
||||
: transport (elim_type Pinl Pinr Pglue) (glue x) = Pglue x :=
|
||||
!elim_type_eq_of_rel_fn
|
||||
|
||||
theorem elim_type_glue_inv (Pinl : BL → Type) (Pinr : TR → Type)
|
||||
(Pglue : Π(x : TL), Pinl (f x) ≃ Pinr (g x)) (x : TL)
|
||||
: transport (elim_type Pinl Pinr Pglue) (glue x)⁻¹ = to_inv (Pglue x) :=
|
||||
!elim_type_eq_of_rel_inv
|
||||
|
||||
protected definition rec_prop {P : pushout → Type} [H : Πx, is_prop (P x)]
|
||||
(Pinl : Π(x : BL), P (inl x)) (Pinr : Π(x : TR), P (inr x)) (y : pushout) :=
|
||||
rec Pinl Pinr (λx, !is_prop.elimo) y
|
||||
|
||||
protected definition elim_prop {P : Type} [H : is_prop P] (Pinl : BL → P) (Pinr : TR → P)
|
||||
(y : pushout) : P :=
|
||||
elim Pinl Pinr (λa, !is_prop.elim) y
|
||||
|
||||
end
|
||||
end pushout
|
||||
|
||||
attribute pushout.inl pushout.inr [constructor]
|
||||
attribute pushout.rec pushout.elim [unfold 10] [recursor 10]
|
||||
attribute pushout.elim_type [unfold 9]
|
||||
attribute pushout.rec_on pushout.elim_on [unfold 7]
|
||||
attribute pushout.elim_type_on [unfold 6]
|
||||
|
||||
open sigma
|
||||
|
||||
namespace pushout
|
||||
|
||||
variables {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
|
||||
|
||||
/- The non-dependent universal property -/
|
||||
definition pushout_arrow_equiv (C : Type)
|
||||
: (pushout f g → C) ≃ (Σ(i : BL → C) (j : TR → C), Πc, i (f c) = j (g c)) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ⟨λx, f (inl x), λx, f (inr x), λx, ap f (glue x)⟩},
|
||||
{ intro v x, induction v with i w, induction w with j p, induction x,
|
||||
exact (i a), exact (j a), exact (p x)},
|
||||
{ intro v, induction v with i w, induction w with j p, esimp,
|
||||
apply ap (λp, ⟨i, j, p⟩), apply eq_of_homotopy, intro x, apply elim_glue},
|
||||
{ intro f, apply eq_of_homotopy, intro x, induction x: esimp,
|
||||
apply eq_pathover, apply hdeg_square, esimp, apply elim_glue},
|
||||
end
|
||||
|
||||
/- glue squares -/
|
||||
protected definition glue_square {x x' : TL} (p : x = x')
|
||||
: square (glue x) (glue x') (ap inl (ap f p)) (ap inr (ap g p)) :=
|
||||
by cases p; apply vrefl
|
||||
|
||||
end pushout
|
||||
|
||||
open function sigma.ops
|
||||
|
||||
namespace pushout
|
||||
|
||||
/- The flattening lemma -/
|
||||
section
|
||||
|
||||
universe variable u
|
||||
parameters {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
|
||||
(Pinl : BL → Type.{u}) (Pinr : TR → Type.{u})
|
||||
(Pglue : Π(x : TL), Pinl (f x) ≃ Pinr (g x))
|
||||
include Pglue
|
||||
|
||||
local abbreviation A := BL + TR
|
||||
local abbreviation R : A → A → Type := pushout_rel f g
|
||||
local abbreviation P [unfold 5] := pushout.elim_type Pinl Pinr Pglue
|
||||
|
||||
local abbreviation F : sigma (Pinl ∘ f) → sigma Pinl :=
|
||||
λz, ⟨ f z.1 , z.2 ⟩
|
||||
|
||||
local abbreviation G : sigma (Pinl ∘ f) → sigma Pinr :=
|
||||
λz, ⟨ g z.1 , Pglue z.1 z.2 ⟩
|
||||
|
||||
protected definition flattening : sigma P ≃ pushout F G :=
|
||||
begin
|
||||
apply equiv.trans !quotient.flattening.flattening_lemma,
|
||||
fapply equiv.MK,
|
||||
{ intro q, induction q with z z z' fr,
|
||||
{ induction z with a p, induction a with x x,
|
||||
{ exact inl ⟨x, p⟩ },
|
||||
{ exact inr ⟨x, p⟩ } },
|
||||
{ induction fr with a a' r p, induction r with x,
|
||||
exact glue ⟨x, p⟩ } },
|
||||
{ intro q, induction q with xp xp xp,
|
||||
{ exact class_of _ ⟨sum.inl xp.1, xp.2⟩ },
|
||||
{ exact class_of _ ⟨sum.inr xp.1, xp.2⟩ },
|
||||
{ apply eq_of_rel, constructor } },
|
||||
{ intro q, induction q with xp xp xp: induction xp with x p,
|
||||
{ apply ap inl, reflexivity },
|
||||
{ apply ap inr, reflexivity },
|
||||
{ unfold F, unfold G, apply eq_pathover,
|
||||
rewrite [ap_id,ap_compose' (quotient.elim _ _)],
|
||||
krewrite elim_glue, krewrite elim_eq_of_rel, apply hrefl } },
|
||||
{ intro q, induction q with z z z' fr,
|
||||
{ induction z with a p, induction a with x x,
|
||||
{ reflexivity },
|
||||
{ reflexivity } },
|
||||
{ induction fr with a a' r p, induction r with x,
|
||||
esimp, apply eq_pathover,
|
||||
rewrite [ap_id,ap_compose' (pushout.elim _ _ _)],
|
||||
krewrite elim_eq_of_rel, krewrite elim_glue, apply hrefl } }
|
||||
end
|
||||
end
|
||||
|
||||
-- Commutativity of pushouts
|
||||
section
|
||||
variables {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
|
||||
|
||||
protected definition transpose [unfold 6] : pushout f g → pushout g f :=
|
||||
begin
|
||||
intro x, induction x, apply inr a, apply inl a, apply !glue⁻¹
|
||||
end
|
||||
|
||||
--TODO prove without krewrite?
|
||||
protected definition transpose_involutive (x : pushout f g) :
|
||||
pushout.transpose g f (pushout.transpose f g x) = x :=
|
||||
begin
|
||||
induction x, apply idp, apply idp,
|
||||
apply eq_pathover, refine _ ⬝hp !ap_id⁻¹,
|
||||
refine !(ap_compose (pushout.transpose _ _)) ⬝ph _, esimp[pushout.transpose],
|
||||
krewrite [elim_glue, ap_inv, elim_glue, inv_inv], apply hrfl
|
||||
end
|
||||
|
||||
protected definition symm : pushout f g ≃ pushout g f :=
|
||||
begin
|
||||
fapply equiv.MK, do 2 exact !pushout.transpose,
|
||||
do 2 (intro x; apply pushout.transpose_involutive),
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
-- Functoriality of pushouts
|
||||
section
|
||||
section lemmas
|
||||
variables {X : Type} {x₀ x₁ x₂ x₃ : X}
|
||||
(p : x₀ = x₁) (q : x₁ = x₂) (r : x₂ = x₃)
|
||||
private definition is_equiv_functor_lemma₁
|
||||
: (r ⬝ ((p ⬝ q ⬝ r)⁻¹ ⬝ p)) = q⁻¹ :=
|
||||
by cases p; cases r; cases q; reflexivity
|
||||
|
||||
private definition is_equiv_functor_lemma₂
|
||||
: (p ⬝ q ⬝ r)⁻¹ ⬝ (p ⬝ q) = r⁻¹ :=
|
||||
by cases p; cases r; cases q; reflexivity
|
||||
end lemmas
|
||||
|
||||
variables {TL BL TR : Type} {f : TL → BL} {g : TL → TR}
|
||||
{TL' BL' TR' : Type} {f' : TL' → BL'} {g' : TL' → TR'}
|
||||
(tl : TL → TL') (bl : BL → BL') (tr : TR → TR')
|
||||
(fh : bl ∘ f ~ f' ∘ tl) (gh : tr ∘ g ~ g' ∘ tl)
|
||||
include fh gh
|
||||
|
||||
protected definition functor [reducible] : pushout f g → pushout f' g' :=
|
||||
begin
|
||||
intro x, induction x with a b z,
|
||||
{ exact inl (bl a) },
|
||||
{ exact inr (tr b) },
|
||||
{ exact (ap inl (fh z)) ⬝ glue (tl z) ⬝ (ap inr (gh z)⁻¹) }
|
||||
end
|
||||
|
||||
protected definition ap_functor_inl [unfold 18] {x x' : BL} (p : x = x')
|
||||
: ap (pushout.functor tl bl tr fh gh) (ap inl p) = ap inl (ap bl p) :=
|
||||
by cases p; reflexivity
|
||||
|
||||
protected definition ap_functor_inr [unfold 18] {x x' : TR} (p : x = x')
|
||||
: ap (pushout.functor tl bl tr fh gh) (ap inr p) = ap inr (ap tr p) :=
|
||||
by cases p; reflexivity
|
||||
|
||||
variables [ietl : is_equiv tl] [iebl : is_equiv bl] [ietr : is_equiv tr]
|
||||
include ietl iebl ietr
|
||||
|
||||
open equiv is_equiv arrow
|
||||
protected definition is_equiv_functor [instance]
|
||||
: is_equiv (pushout.functor tl bl tr fh gh) :=
|
||||
adjointify
|
||||
(pushout.functor tl bl tr fh gh)
|
||||
(pushout.functor tl⁻¹ bl⁻¹ tr⁻¹
|
||||
(inv_commute_of_commute tl bl f f' fh)
|
||||
(inv_commute_of_commute tl tr g g' gh))
|
||||
abstract begin
|
||||
intro x', induction x' with a' b' z',
|
||||
{ apply ap inl, apply right_inv },
|
||||
{ apply ap inr, apply right_inv },
|
||||
{ apply eq_pathover,
|
||||
rewrite [ap_id,ap_compose' (pushout.functor tl bl tr fh gh)],
|
||||
krewrite elim_glue,
|
||||
rewrite [ap_inv,ap_con,ap_inv],
|
||||
krewrite [pushout.ap_functor_inr], rewrite ap_con,
|
||||
krewrite [pushout.ap_functor_inl,elim_glue],
|
||||
apply transpose,
|
||||
apply move_top_of_right, apply move_top_of_left',
|
||||
krewrite [-(ap_inv inl),-ap_con,-(ap_inv inr),-ap_con],
|
||||
apply move_top_of_right, apply move_top_of_left',
|
||||
krewrite [-ap_con,-(ap_inv inl),-ap_con],
|
||||
rewrite ap_bot_inv_commute_of_commute,
|
||||
apply eq_hconcat (ap02 inl
|
||||
(is_equiv_functor_lemma₁
|
||||
(right_inv bl (f' z'))
|
||||
(ap f' (right_inv tl z')⁻¹)
|
||||
(fh (tl⁻¹ z'))⁻¹)),
|
||||
rewrite [ap_inv f',inv_inv],
|
||||
rewrite ap_bot_inv_commute_of_commute,
|
||||
refine hconcat_eq _ (ap02 inr
|
||||
(is_equiv_functor_lemma₁
|
||||
(right_inv tr (g' z'))
|
||||
(ap g' (right_inv tl z')⁻¹)
|
||||
(gh (tl⁻¹ z'))⁻¹))⁻¹,
|
||||
rewrite [ap_inv g',inv_inv],
|
||||
apply pushout.glue_square }
|
||||
end end
|
||||
abstract begin
|
||||
intro x, induction x with a b z,
|
||||
{ apply ap inl, apply left_inv },
|
||||
{ apply ap inr, apply left_inv },
|
||||
{ apply eq_pathover,
|
||||
rewrite [ap_id,ap_compose'
|
||||
(pushout.functor tl⁻¹ bl⁻¹ tr⁻¹ _ _)
|
||||
(pushout.functor tl bl tr _ _)],
|
||||
krewrite elim_glue,
|
||||
rewrite [ap_inv,ap_con,ap_inv],
|
||||
krewrite [pushout.ap_functor_inr], rewrite ap_con,
|
||||
krewrite [pushout.ap_functor_inl,elim_glue],
|
||||
apply transpose,
|
||||
apply move_top_of_right, apply move_top_of_left',
|
||||
krewrite [-(ap_inv inl),-ap_con,-(ap_inv inr),-ap_con],
|
||||
apply move_top_of_right, apply move_top_of_left',
|
||||
krewrite [-ap_con,-(ap_inv inl),-ap_con],
|
||||
rewrite inv_commute_of_commute_top,
|
||||
apply eq_hconcat (ap02 inl
|
||||
(is_equiv_functor_lemma₂
|
||||
(ap bl⁻¹ (fh z))⁻¹
|
||||
(left_inv bl (f z))
|
||||
(ap f (left_inv tl z)⁻¹))),
|
||||
rewrite [ap_inv f,inv_inv],
|
||||
rewrite inv_commute_of_commute_top,
|
||||
refine hconcat_eq _ (ap02 inr
|
||||
(is_equiv_functor_lemma₂
|
||||
(ap tr⁻¹ (gh z))⁻¹
|
||||
(left_inv tr (g z))
|
||||
(ap g (left_inv tl z)⁻¹)))⁻¹,
|
||||
rewrite [ap_inv g,inv_inv],
|
||||
apply pushout.glue_square }
|
||||
end end
|
||||
|
||||
end
|
||||
|
||||
/- version giving the equivalence -/
|
||||
section
|
||||
variables {TL BL TR : Type} (f : TL → BL) (g : TL → TR)
|
||||
{TL' BL' TR' : Type} (f' : TL' → BL') (g' : TL' → TR')
|
||||
(tl : TL ≃ TL') (bl : BL ≃ BL') (tr : TR ≃ TR')
|
||||
(fh : bl ∘ f ~ f' ∘ tl) (gh : tr ∘ g ~ g' ∘ tl)
|
||||
include fh gh
|
||||
|
||||
protected definition equiv : pushout f g ≃ pushout f' g' :=
|
||||
equiv.mk (pushout.functor tl bl tr fh gh) _
|
||||
end
|
||||
|
||||
definition pointed_pushout [instance] [constructor] {TL BL TR : Type} [HTL : pointed TL]
|
||||
[HBL : pointed BL] [HTR : pointed TR] (f : TL → BL) (g : TL → TR) : pointed (pushout f g) :=
|
||||
pointed.mk (inl (point _))
|
||||
end pushout open pushout
|
||||
|
||||
definition ppushout [constructor] {TL BL TR : Type*} (f : TL →* BL) (g : TL →* TR) : Type* :=
|
||||
pointed.mk' (pushout f g)
|
||||
|
||||
namespace pushout
|
||||
section
|
||||
parameters {TL BL TR : Type*} (f : TL →* BL) (g : TL →* TR)
|
||||
|
||||
parameters {f g}
|
||||
definition pinl [constructor] : BL →* ppushout f g :=
|
||||
pmap.mk inl idp
|
||||
|
||||
definition pinr [constructor] : TR →* ppushout f g :=
|
||||
pmap.mk inr ((ap inr (respect_pt g))⁻¹ ⬝ !glue⁻¹ ⬝ (ap inl (respect_pt f)))
|
||||
|
||||
definition pglue (x : TL) : pinl (f x) = pinr (g x) := -- TODO do we need this?
|
||||
!glue
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
variables {TL BL TR : Type*} (f : TL →* BL) (g : TL →* TR)
|
||||
|
||||
protected definition psymm [constructor] : ppushout f g ≃* ppushout g f :=
|
||||
begin
|
||||
fapply pequiv_of_equiv,
|
||||
{ apply pushout.symm },
|
||||
{ exact ap inr (respect_pt f)⁻¹ ⬝ !glue⁻¹ ⬝ ap inl (respect_pt g) }
|
||||
end
|
||||
|
||||
end
|
||||
end pushout
|
||||
|
|
@ -1,320 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Ulrik Buchholtz
|
||||
|
||||
Quotients. This is a quotient without truncation for an arbitrary type-valued binary relation.
|
||||
See also .set_quotient
|
||||
-/
|
||||
|
||||
/-
|
||||
The hit quotient is primitive, declared in init.hit.
|
||||
The constructors are, given {A : Type} (R : A → A → Type),
|
||||
* class_of : A → quotient R (A implicit, R explicit)
|
||||
* eq_of_rel : Π{a a' : A}, R a a' → class_of a = class_of a' (R explicit)
|
||||
-/
|
||||
|
||||
import arity cubical.squareover types.arrow cubical.pathover2 types.pointed
|
||||
|
||||
open eq equiv sigma sigma.ops pi is_trunc pointed
|
||||
|
||||
namespace quotient
|
||||
|
||||
variables {A : Type} {R : A → A → Type}
|
||||
|
||||
protected definition elim {P : Type} (Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a')
|
||||
(x : quotient R) : P :=
|
||||
quotient.rec Pc (λa a' H, pathover_of_eq _ (Pp H)) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : quotient R)
|
||||
(Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') : P :=
|
||||
quotient.elim Pc Pp x
|
||||
|
||||
theorem elim_eq_of_rel {P : Type} (Pc : A → P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
|
||||
: ap (quotient.elim Pc Pp) (eq_of_rel R H) = Pp H :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (eq_of_rel R H)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑quotient.elim,rec_eq_of_rel],
|
||||
end
|
||||
|
||||
protected definition rec_prop {A : Type} {R : A → A → Type} {P : quotient R → Type}
|
||||
[H : Πx, is_prop (P x)] (Pc : Π(a : A), P (class_of R a)) (x : quotient R) : P x :=
|
||||
quotient.rec Pc (λa a' H, !is_prop.elimo) x
|
||||
|
||||
protected definition elim_prop {P : Type} [H : is_prop P] (Pc : A → P) (x : quotient R) : P :=
|
||||
quotient.elim Pc (λa a' H, !is_prop.elim) x
|
||||
|
||||
protected definition elim_type (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') : quotient R → Type :=
|
||||
quotient.elim Pc (λa a' H, ua (Pp H))
|
||||
|
||||
protected definition elim_type_on [reducible] (x : quotient R) (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') : Type :=
|
||||
quotient.elim_type Pc Pp x
|
||||
|
||||
theorem elim_type_eq_of_rel_fn (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a')
|
||||
: transport (quotient.elim_type Pc Pp) (eq_of_rel R H) = to_fun (Pp H) :=
|
||||
by rewrite [tr_eq_cast_ap_fn, ↑quotient.elim_type, elim_eq_of_rel]; apply cast_ua_fn
|
||||
|
||||
-- rename to elim_type_eq_of_rel_fn_inv
|
||||
theorem elim_type_eq_of_rel_inv (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a')
|
||||
: transport (quotient.elim_type Pc Pp) (eq_of_rel R H)⁻¹ = to_inv (Pp H) :=
|
||||
by rewrite [tr_eq_cast_ap_fn, ↑quotient.elim_type, ap_inv, elim_eq_of_rel]; apply cast_ua_inv_fn
|
||||
|
||||
-- remove '
|
||||
theorem elim_type_eq_of_rel_inv' (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (x : Pc a')
|
||||
: transport (quotient.elim_type Pc Pp) (eq_of_rel R H)⁻¹ x = to_inv (Pp H) x :=
|
||||
ap10 (elim_type_eq_of_rel_inv Pc Pp H) x
|
||||
|
||||
theorem elim_type_eq_of_rel.{u} (Pc : A → Type.{u})
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (p : Pc a)
|
||||
: transport (quotient.elim_type Pc Pp) (eq_of_rel R H) p = to_fun (Pp H) p :=
|
||||
ap10 (elim_type_eq_of_rel_fn Pc Pp H) p
|
||||
|
||||
definition elim_type_eq_of_rel' (Pc : A → Type)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a') {a a' : A} (H : R a a') (p : Pc a)
|
||||
: pathover (quotient.elim_type Pc Pp) p (eq_of_rel R H) (to_fun (Pp H) p) :=
|
||||
pathover_of_tr_eq (elim_type_eq_of_rel Pc Pp H p)
|
||||
|
||||
definition elim_type_uncurried (H : Σ(Pc : A → Type), Π⦃a a' : A⦄ (H : R a a'), Pc a ≃ Pc a')
|
||||
: quotient R → Type :=
|
||||
quotient.elim_type H.1 H.2
|
||||
end quotient
|
||||
|
||||
attribute quotient.rec [recursor]
|
||||
attribute quotient.elim [unfold 6] [recursor 6]
|
||||
attribute quotient.elim_type [unfold 5]
|
||||
attribute quotient.elim_on [unfold 4]
|
||||
attribute quotient.elim_type_on [unfold 3]
|
||||
|
||||
namespace quotient
|
||||
|
||||
section
|
||||
variables {A : Type} (R : A → A → Type)
|
||||
|
||||
/- The dependent universal property -/
|
||||
definition quotient_pi_equiv (C : quotient R → Type) : (Πx, C x) ≃
|
||||
(Σ(f : Π(a : A), C (class_of R a)), Π⦃a a' : A⦄ (H : R a a'), f a =[eq_of_rel R H] f a') :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ⟨λa, f (class_of R a), λa a' H, apd f (eq_of_rel R H)⟩},
|
||||
{ intro v x, induction v with i p, induction x,
|
||||
exact (i a),
|
||||
exact (p H)},
|
||||
{ intro v, induction v with i p, esimp,
|
||||
apply ap (sigma.mk i), apply eq_of_homotopy3, intro a a' H, apply rec_eq_of_rel},
|
||||
{ intro f, apply eq_of_homotopy, intro x, induction x: esimp,
|
||||
apply eq_pathover_dep, esimp, rewrite rec_eq_of_rel, exact hrflo},
|
||||
end
|
||||
end
|
||||
|
||||
definition pquotient [constructor] {A : Type*} (R : A → A → Type) : Type* :=
|
||||
pType.mk (quotient R) (class_of R pt)
|
||||
|
||||
/- the flattening lemma -/
|
||||
|
||||
namespace flattening
|
||||
section
|
||||
|
||||
parameters {A : Type} (R : A → A → Type) (C : A → Type) (f : Π⦃a a'⦄, R a a' → C a ≃ C a')
|
||||
include f
|
||||
variables {a a' : A} {r : R a a'}
|
||||
|
||||
local abbreviation P [unfold 5] := quotient.elim_type C f
|
||||
|
||||
definition flattening_type : Type := Σa, C a
|
||||
local abbreviation X := flattening_type
|
||||
inductive flattening_rel : X → X → Type :=
|
||||
| mk : Π⦃a a' : A⦄ (r : R a a') (c : C a), flattening_rel ⟨a, c⟩ ⟨a', f r c⟩
|
||||
|
||||
definition Ppt [constructor] (c : C a) : sigma P :=
|
||||
⟨class_of R a, c⟩
|
||||
|
||||
definition Peq (r : R a a') (c : C a) : Ppt c = Ppt (f r c) :=
|
||||
begin
|
||||
fapply sigma_eq: esimp,
|
||||
{ apply eq_of_rel R r},
|
||||
{ refine elim_type_eq_of_rel' C f r c}
|
||||
end
|
||||
|
||||
definition rec {Q : sigma P → Type} (Qpt : Π{a : A} (x : C a), Q (Ppt x))
|
||||
(Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c =[Peq r c] Qpt (f r c))
|
||||
(v : sigma P) : Q v :=
|
||||
begin
|
||||
induction v with q p,
|
||||
induction q,
|
||||
{ exact Qpt p},
|
||||
{ apply pi_pathover_left', esimp, intro c,
|
||||
refine _ ⬝op apdt Qpt (elim_type_eq_of_rel C f H c)⁻¹ᵖ,
|
||||
refine _ ⬝op (tr_compose Q Ppt _ _)⁻¹ ,
|
||||
rewrite ap_inv,
|
||||
refine pathover_cancel_right _ !tr_pathover⁻¹ᵒ,
|
||||
refine change_path _ (Qeq H c),
|
||||
symmetry, rewrite [↑[Ppt, Peq]],
|
||||
refine whisker_left _ !ap_dpair ⬝ _,
|
||||
refine !dpair_eq_dpair_con⁻¹ ⬝ _, esimp,
|
||||
apply ap (dpair_eq_dpair _),
|
||||
esimp [elim_type_eq_of_rel',pathover_idp_of_eq],
|
||||
exact !pathover_of_tr_eq_eq_concato⁻¹},
|
||||
end
|
||||
|
||||
definition elim {Q : Type} (Qpt : Π{a : A}, C a → Q)
|
||||
(Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c = Qpt (f r c))
|
||||
(v : sigma P) : Q :=
|
||||
begin
|
||||
induction v with q p,
|
||||
induction q,
|
||||
{ exact Qpt p},
|
||||
{ apply arrow_pathover_constant_right, esimp,
|
||||
intro c, exact Qeq H c ⬝ ap Qpt (elim_type_eq_of_rel C f H c)⁻¹},
|
||||
end
|
||||
|
||||
theorem elim_Peq {Q : Type} (Qpt : Π{a : A}, C a → Q)
|
||||
(Qeq : Π⦃a a' : A⦄ (r : R a a') (c : C a), Qpt c = Qpt (f r c)) {a a' : A} (r : R a a')
|
||||
(c : C a) : ap (elim @Qpt Qeq) (Peq r c) = Qeq r c :=
|
||||
begin
|
||||
refine !ap_dpair_eq_dpair ⬝ _,
|
||||
refine !apd011_eq_apo11_apd ⬝ _,
|
||||
rewrite [rec_eq_of_rel, ▸*],
|
||||
refine !apo11_arrow_pathover_constant_right ⬝ _,
|
||||
rewrite [↑elim_type_eq_of_rel', to_right_inv !pathover_equiv_tr_eq, ap_inv],
|
||||
apply inv_con_cancel_right
|
||||
end
|
||||
|
||||
open flattening_rel
|
||||
definition flattening_lemma : sigma P ≃ quotient flattening_rel :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ refine elim _ _,
|
||||
{ intro a c, exact class_of _ ⟨a, c⟩},
|
||||
{ intro a a' r c, apply eq_of_rel, constructor}},
|
||||
{ intro q, induction q with x x x' H,
|
||||
{ exact Ppt x.2},
|
||||
{ induction H, esimp, apply Peq}},
|
||||
{ intro q, induction q with x x x' H: esimp,
|
||||
{ induction x with a c, reflexivity},
|
||||
{ induction H, esimp, apply eq_pathover, apply hdeg_square,
|
||||
refine ap_compose (elim _ _) (quotient.elim _ _) _ ⬝ _,
|
||||
rewrite [elim_eq_of_rel, ap_id, ▸*],
|
||||
apply elim_Peq}},
|
||||
{ refine rec (λa x, idp) _, intros,
|
||||
apply eq_pathover, apply hdeg_square,
|
||||
refine ap_compose (quotient.elim _ _) (elim _ _) _ ⬝ _,
|
||||
rewrite [elim_Peq, ap_id, ▸*],
|
||||
apply elim_eq_of_rel}
|
||||
end
|
||||
|
||||
end
|
||||
end flattening
|
||||
|
||||
section
|
||||
open is_equiv equiv prod prod.ops
|
||||
variables {A : Type} (R : A → A → Type)
|
||||
{B : Type} (Q : B → B → Type)
|
||||
(f : A → B) (k : Πa a' : A, R a a' → Q (f a) (f a'))
|
||||
include f k
|
||||
|
||||
protected definition functor [reducible] : quotient R → quotient Q :=
|
||||
quotient.elim (λa, class_of Q (f a)) (λa a' r, eq_of_rel Q (k a a' r))
|
||||
|
||||
variables [F : is_equiv f] [K : Πa a', is_equiv (k a a')]
|
||||
include F K
|
||||
|
||||
protected definition functor_inv [reducible] : quotient Q → quotient R :=
|
||||
quotient.elim (λb, class_of R (f⁻¹ b))
|
||||
(λb b' q, eq_of_rel R ((k (f⁻¹ b) (f⁻¹ b'))⁻¹
|
||||
((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)))
|
||||
|
||||
protected definition is_equiv [instance]
|
||||
: is_equiv (quotient.functor R Q f k):=
|
||||
begin
|
||||
fapply adjointify _ (quotient.functor_inv R Q f k),
|
||||
{ intro qb, induction qb with b b b' q,
|
||||
{ apply ap (class_of Q), apply right_inv },
|
||||
{ apply eq_pathover, rewrite [ap_id,ap_compose' (quotient.elim _ _)],
|
||||
do 2 krewrite elim_eq_of_rel, rewrite (right_inv (k (f⁻¹ b) (f⁻¹ b'))),
|
||||
have H1 : pathover (λz : B × B, Q z.1 z.2)
|
||||
((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q)
|
||||
(prod_eq (right_inv f b) (right_inv f b')) q,
|
||||
begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
|
||||
have H2 : square
|
||||
(ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.1)
|
||||
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
|
||||
(ap (λx : (Σz : B × B, Q z.1 z.2), class_of Q x.1.2)
|
||||
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1))
|
||||
(eq_of_rel Q ((right_inv f b)⁻¹ ▸ (right_inv f b')⁻¹ ▸ q))
|
||||
(eq_of_rel Q q),
|
||||
from
|
||||
natural_square_tr (λw : (Σz : B × B, Q z.1 z.2), eq_of_rel Q w.2)
|
||||
(sigma_eq (prod_eq (right_inv f b) (right_inv f b')) H1),
|
||||
krewrite (ap_compose' (class_of Q)) at H2,
|
||||
krewrite (ap_compose' (λz : B × B, z.1)) at H2,
|
||||
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
|
||||
krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
|
||||
krewrite (ap_compose' (class_of Q) (λx : (Σz : B × B, Q z.1 z.2), x.1.2)) at H2,
|
||||
krewrite (ap_compose' (λz : B × B, z.2)) at H2,
|
||||
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
|
||||
krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
|
||||
apply H2 } },
|
||||
{ intro qa, induction qa with a a a' r,
|
||||
{ apply ap (class_of R), apply left_inv },
|
||||
{ apply eq_pathover, rewrite [ap_id,(ap_compose' (quotient.elim _ _))],
|
||||
do 2 krewrite elim_eq_of_rel,
|
||||
have H1 : pathover (λz : A × A, R z.1 z.2)
|
||||
((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r)
|
||||
(prod_eq (left_inv f a) (left_inv f a')) r,
|
||||
begin apply pathover_of_eq_tr, krewrite [prod_eq_inv,prod_eq_transport] end,
|
||||
have H2 : square
|
||||
(ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.1)
|
||||
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
|
||||
(ap (λx : (Σz : A × A, R z.1 z.2), class_of R x.1.2)
|
||||
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1))
|
||||
(eq_of_rel R ((left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r))
|
||||
(eq_of_rel R r),
|
||||
begin
|
||||
exact
|
||||
natural_square_tr (λw : (Σz : A × A, R z.1 z.2), eq_of_rel R w.2)
|
||||
(sigma_eq (prod_eq (left_inv f a) (left_inv f a')) H1)
|
||||
end,
|
||||
krewrite (ap_compose' (class_of R)) at H2,
|
||||
krewrite (ap_compose' (λz : A × A, z.1)) at H2,
|
||||
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
|
||||
krewrite prod.ap_pr1 at H2, krewrite prod_eq_pr1 at H2,
|
||||
krewrite (ap_compose' (class_of R) (λx : (Σz : A × A, R z.1 z.2), x.1.2)) at H2,
|
||||
krewrite (ap_compose' (λz : A × A, z.2)) at H2,
|
||||
rewrite sigma.ap_pr1 at H2, rewrite sigma_eq_pr1 at H2,
|
||||
krewrite prod.ap_pr2 at H2, krewrite prod_eq_pr2 at H2,
|
||||
have H3 :
|
||||
(k (f⁻¹ (f a)) (f⁻¹ (f a')))⁻¹
|
||||
((right_inv f (f a))⁻¹ ▸ (right_inv f (f a'))⁻¹ ▸ k a a' r)
|
||||
= (left_inv f a)⁻¹ ▸ (left_inv f a')⁻¹ ▸ r,
|
||||
begin
|
||||
rewrite [adj f a,adj f a',ap_inv',ap_inv'],
|
||||
rewrite [-(tr_compose _ f (left_inv f a')⁻¹ (k a a' r)),
|
||||
-(tr_compose _ f (left_inv f a)⁻¹)],
|
||||
rewrite [-(fn_tr_eq_tr_fn (left_inv f a')⁻¹ (λx, k a x) r),
|
||||
-(fn_tr_eq_tr_fn (left_inv f a)⁻¹
|
||||
(λx, k x (f⁻¹ (f a')))),
|
||||
left_inv (k _ _)]
|
||||
end,
|
||||
rewrite H3, apply H2 } }
|
||||
end
|
||||
end
|
||||
|
||||
section
|
||||
variables {A : Type} (R : A → A → Type)
|
||||
{B : Type} (Q : B → B → Type)
|
||||
(f : A ≃ B) (k : Πa a' : A, R a a' ≃ Q (f a) (f a'))
|
||||
include f k
|
||||
|
||||
/- This could also be proved using ua, but then it wouldn't compute -/
|
||||
protected definition equiv : quotient R ≃ quotient Q :=
|
||||
equiv.mk (quotient.functor R Q f k) _
|
||||
end
|
||||
|
||||
|
||||
end quotient
|
||||
|
|
@ -1,84 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Quotient of a reflexive relation
|
||||
-/
|
||||
|
||||
import homotopy.circle cubical.squareover .two_quotient
|
||||
|
||||
open eq simple_two_quotient e_closure
|
||||
|
||||
namespace refl_quotient
|
||||
section
|
||||
|
||||
parameters {A : Type} (R : A → A → Type) (ρ : Πa, R a a)
|
||||
inductive refl_quotient_Q : Π⦃a : A⦄, e_closure R a a → Type :=
|
||||
| Qmk {} : Π(a : A), refl_quotient_Q [ρ a]
|
||||
open refl_quotient_Q
|
||||
local abbreviation Q := refl_quotient_Q
|
||||
|
||||
definition refl_quotient : Type := simple_two_quotient R Q
|
||||
|
||||
definition rclass_of (a : A) : refl_quotient := incl0 R Q a
|
||||
definition req_of_rel ⦃a a' : A⦄ (r : R a a') : rclass_of a = rclass_of a' :=
|
||||
incl1 R Q r
|
||||
|
||||
definition pρ (a : A) : req_of_rel (ρ a) = idp :=
|
||||
incl2 R Q (Qmk a)
|
||||
|
||||
protected definition rec {P : refl_quotient → Type} (Pc : Π(a : A), P (rclass_of a))
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[req_of_rel H] Pc a')
|
||||
(Pr : Π(a : A), change_path (pρ a) (Pp (ρ a)) = idpo) (x : refl_quotient) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
exact Pc a,
|
||||
exact Pp s,
|
||||
induction q, apply Pr
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : refl_quotient → Type} (x : refl_quotient)
|
||||
(Pc : Π(a : A), P (rclass_of a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[req_of_rel H] Pc a')
|
||||
(Pr : Π(a : A), change_path (pρ a) (Pp (ρ a)) = idpo) : P x :=
|
||||
rec Pc Pp Pr x
|
||||
|
||||
definition rec_req_of_rel {P : Type} {P : refl_quotient → Type} (Pc : Π(a : A), P (rclass_of a))
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[req_of_rel H] Pc a')
|
||||
(Pr : Π(a : A), change_path (pρ a) (Pp (ρ a)) = idpo) ⦃a a' : A⦄ (r : R a a')
|
||||
: apd (rec Pc Pp Pr) (req_of_rel r) = Pp r :=
|
||||
!rec_incl1
|
||||
|
||||
protected definition elim {P : Type} (Pc : Π(a : A), P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') (Pr : Π(a : A), Pp (ρ a) = idp)
|
||||
(x : refl_quotient) : P :=
|
||||
begin
|
||||
induction x,
|
||||
exact Pc a,
|
||||
exact Pp s,
|
||||
induction q, apply Pr
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : refl_quotient) (Pc : Π(a : A), P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') (Pr : Π(a : A), Pp (ρ a) = idp) : P :=
|
||||
elim Pc Pp Pr x
|
||||
|
||||
definition elim_req_of_rel {P : Type} {Pc : Π(a : A), P}
|
||||
{Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a'} (Pr : Π(a : A), Pp (ρ a) = idp)
|
||||
⦃a a' : A⦄ (r : R a a') : ap (elim Pc Pp Pr) (req_of_rel r) = Pp r :=
|
||||
!elim_incl1
|
||||
|
||||
theorem elim_pρ {P : Type} (Pc : Π(a : A), P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') (Pr : Π(a : A), Pp (ρ a) = idp) (a : A)
|
||||
: square (ap02 (elim Pc Pp Pr) (pρ a)) (Pr a) (elim_req_of_rel Pr (ρ a)) idp :=
|
||||
!elim_incl2
|
||||
|
||||
end
|
||||
end refl_quotient
|
||||
|
||||
attribute refl_quotient.rclass_of [constructor]
|
||||
attribute refl_quotient.rec refl_quotient.elim [unfold 8] [recursor 8]
|
||||
--attribute refl_quotient.elim_type [unfold 9]
|
||||
attribute refl_quotient.rec_on refl_quotient.elim_on [unfold 5]
|
||||
--attribute refl_quotient.elim_type_on [unfold 6]
|
||||
|
|
@ -1,145 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Declaration of set-quotients, i.e. quotient of a mere relation which is then set-truncated.
|
||||
-/
|
||||
|
||||
import function algebra.relation types.trunc types.eq hit.quotient
|
||||
|
||||
open eq is_trunc trunc quotient equiv
|
||||
|
||||
namespace set_quotient
|
||||
section
|
||||
parameters {A : Type} (R : A → A → Prop)
|
||||
-- set-quotients are just set-truncations of (type) quotients
|
||||
definition set_quotient : Type := trunc 0 (quotient R)
|
||||
|
||||
parameter {R}
|
||||
definition class_of (a : A) : set_quotient :=
|
||||
tr (class_of _ a)
|
||||
|
||||
definition eq_of_rel {a a' : A} (H : R a a') : class_of a = class_of a' :=
|
||||
ap tr (eq_of_rel _ H)
|
||||
|
||||
theorem is_set_set_quotient [instance] : is_set set_quotient :=
|
||||
begin unfold set_quotient, exact _ end
|
||||
|
||||
protected definition rec {P : set_quotient → Type} [Pt : Πaa, is_set (P aa)]
|
||||
(Pc : Π(a : A), P (class_of a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel H] Pc a')
|
||||
(x : set_quotient) : P x :=
|
||||
begin
|
||||
apply (@trunc.rec_on _ _ P x),
|
||||
{ intro x', apply Pt},
|
||||
{ intro y, induction y,
|
||||
{ apply Pc},
|
||||
{ exact pathover_of_pathover_ap P tr (Pp H)}}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : set_quotient → Type} (x : set_quotient)
|
||||
[Pt : Πaa, is_set (P aa)] (Pc : Π(a : A), P (class_of a))
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel H] Pc a') : P x :=
|
||||
rec Pc Pp x
|
||||
|
||||
theorem rec_eq_of_rel {P : set_quotient → Type} [Pt : Πaa, is_set (P aa)]
|
||||
(Pc : Π(a : A), P (class_of a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel H] Pc a')
|
||||
{a a' : A} (H : R a a') : apd (rec Pc Pp) (eq_of_rel H) = Pp H :=
|
||||
!is_set.elimo
|
||||
|
||||
protected definition elim {P : Type} [Pt : is_set P] (Pc : A → P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') (x : set_quotient) : P :=
|
||||
rec Pc (λa a' H, pathover_of_eq _ (Pp H)) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : set_quotient) [Pt : is_set P]
|
||||
(Pc : A → P) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') : P :=
|
||||
elim Pc Pp x
|
||||
|
||||
theorem elim_eq_of_rel {P : Type} [Pt : is_set P] (Pc : A → P)
|
||||
(Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a = Pc a') {a a' : A} (H : R a a')
|
||||
: ap (elim Pc Pp) (eq_of_rel H) = Pp H :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (eq_of_rel H)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_eq_of_rel],
|
||||
end
|
||||
|
||||
protected definition rec_prop {P : set_quotient → Type} [Pt : Πaa, is_prop (P aa)]
|
||||
(Pc : Π(a : A), P (class_of a)) (x : set_quotient) : P x :=
|
||||
rec Pc (λa a' H, !is_prop.elimo) x
|
||||
|
||||
protected definition elim_prop {P : Type} [Pt : is_prop P] (Pc : A → P) (x : set_quotient)
|
||||
: P :=
|
||||
elim Pc (λa a' H, !is_prop.elim) x
|
||||
|
||||
end
|
||||
end set_quotient
|
||||
|
||||
attribute set_quotient.class_of [constructor]
|
||||
attribute set_quotient.rec set_quotient.elim [unfold 7] [recursor 7]
|
||||
attribute set_quotient.rec_on set_quotient.elim_on [unfold 4]
|
||||
|
||||
open sigma relation function
|
||||
|
||||
namespace set_quotient
|
||||
variables {A B C : Type} (R : A → A → Prop) (S : B → B → Prop) (T : C → C → Prop)
|
||||
|
||||
definition is_surjective_class_of : is_surjective (class_of : A → set_quotient R) :=
|
||||
λx, set_quotient.rec_on x (λa, tr (fiber.mk a idp)) (λa a' r, !is_prop.elimo)
|
||||
|
||||
/- non-dependent universal property -/
|
||||
|
||||
definition set_quotient_arrow_equiv (B : Type) [H : is_set B] :
|
||||
(set_quotient R → B) ≃ (Σ(f : A → B), Π(a a' : A), R a a' → f a = f a') :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ⟨λa, f (class_of a), λa a' r, ap f (eq_of_rel r)⟩},
|
||||
{ intro v x, induction v with f p, exact set_quotient.elim_on x f p},
|
||||
{ intro v, induction v with f p, esimp, apply ap (sigma.mk f),
|
||||
apply eq_of_homotopy3, intro a a' r, apply elim_eq_of_rel},
|
||||
{ intro f, apply eq_of_homotopy, intro x, refine set_quotient.rec_on x _ _: esimp,
|
||||
intro a, reflexivity,
|
||||
intro a a' r, apply eq_pathover, apply hdeg_square, apply elim_eq_of_rel}
|
||||
end
|
||||
|
||||
protected definition code [unfold 4] (a : A) (x : set_quotient R) [H : is_equivalence R]
|
||||
: Prop :=
|
||||
set_quotient.elim_on x (R a)
|
||||
begin
|
||||
intros a' a'' H1,
|
||||
refine to_inv !trunctype_eq_equiv _, esimp,
|
||||
apply ua,
|
||||
apply equiv_of_is_prop,
|
||||
{ intro H2, exact is_transitive.trans R H2 H1},
|
||||
{ intro H2, apply is_transitive.trans R H2, exact is_symmetric.symm R H1}
|
||||
end
|
||||
|
||||
protected definition encode {a : A} {x : set_quotient R} (p : class_of a = x)
|
||||
[H : is_equivalence R] : set_quotient.code R a x :=
|
||||
begin
|
||||
induction p, esimp, apply is_reflexive.refl R
|
||||
end
|
||||
|
||||
definition rel_of_eq {a a' : A} (p : class_of a = class_of a' :> set_quotient R)
|
||||
[H : is_equivalence R] : R a a' :=
|
||||
set_quotient.encode R p
|
||||
|
||||
variables {R S T}
|
||||
definition quotient_unary_map [unfold 7] (f : A → B) (H : Π{a a'} (r : R a a'), S (f a) (f a')) :
|
||||
set_quotient R → set_quotient S :=
|
||||
set_quotient.elim (class_of ∘ f) (λa a' r, eq_of_rel (H r))
|
||||
|
||||
definition quotient_binary_map [unfold 11 12] (f : A → B → C)
|
||||
(H : Π{a a'} (r : R a a') {b b'} (s : S b b'), T (f a b) (f a' b'))
|
||||
[HR : is_reflexive R] [HS : is_reflexive S] :
|
||||
set_quotient R → set_quotient S → set_quotient T :=
|
||||
begin
|
||||
refine set_quotient.elim _ _,
|
||||
{ intro a, refine set_quotient.elim _ _,
|
||||
{ intro b, exact class_of (f a b)},
|
||||
{ intro b b' s, apply eq_of_rel, apply H, apply is_reflexive.refl R, exact s}},
|
||||
{ intro a a' r, apply eq_of_homotopy, refine set_quotient.rec _ _,
|
||||
{ intro b, esimp, apply eq_of_rel, apply H, exact r, apply is_reflexive.refl S},
|
||||
{ intro b b' s, apply eq_pathover, esimp, apply is_set.elims}}
|
||||
end
|
||||
|
||||
end set_quotient
|
||||
|
|
@ -1,158 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
n-truncation of types.
|
||||
|
||||
Ported from Coq HoTT
|
||||
-/
|
||||
|
||||
/- The hit n-truncation is primitive, declared in init.hit. -/
|
||||
|
||||
import types.sigma types.pointed
|
||||
|
||||
open is_trunc eq equiv is_equiv function prod sum sigma
|
||||
|
||||
namespace trunc
|
||||
|
||||
protected definition elim {n : trunc_index} {A : Type} {P : Type}
|
||||
[Pt : is_trunc n P] (H : A → P) : trunc n A → P :=
|
||||
trunc.rec H
|
||||
|
||||
protected definition elim_on {n : trunc_index} {A : Type} {P : Type} (aa : trunc n A)
|
||||
[Pt : is_trunc n P] (H : A → P) : P :=
|
||||
trunc.elim H aa
|
||||
|
||||
end trunc
|
||||
|
||||
attribute trunc.elim_on [unfold 4]
|
||||
attribute trunc.rec [recursor 6]
|
||||
attribute trunc.elim [recursor 6] [unfold 6]
|
||||
|
||||
namespace trunc
|
||||
|
||||
variables {X Y Z : Type} {P : X → Type} (n : trunc_index) (A B : Type)
|
||||
|
||||
local attribute is_trunc_eq [instance]
|
||||
|
||||
variables {A n}
|
||||
definition untrunc_of_is_trunc [reducible] [unfold 4] [H : is_trunc n A] : trunc n A → A :=
|
||||
trunc.rec id
|
||||
|
||||
variables (A n)
|
||||
definition is_equiv_tr [instance] [constructor] [H : is_trunc n A] : is_equiv (@tr n A) :=
|
||||
adjointify _
|
||||
(untrunc_of_is_trunc)
|
||||
(λaa, trunc.rec_on aa (λa, idp))
|
||||
(λa, idp)
|
||||
|
||||
definition trunc_equiv [constructor] [H : is_trunc n A] : trunc n A ≃ A :=
|
||||
(equiv.mk tr _)⁻¹ᵉ
|
||||
|
||||
definition is_trunc_of_is_equiv_tr [H : is_equiv (@tr n A)] : is_trunc n A :=
|
||||
is_trunc_is_equiv_closed n (@tr n _)⁻¹
|
||||
|
||||
/- Functoriality -/
|
||||
definition trunc_functor [unfold 5] (f : X → Y) : trunc n X → trunc n Y :=
|
||||
λxx, trunc.rec_on xx (λx, tr (f x))
|
||||
|
||||
definition trunc_functor_compose [unfold 7] (f : X → Y) (g : Y → Z)
|
||||
: trunc_functor n (g ∘ f) ~ trunc_functor n g ∘ trunc_functor n f :=
|
||||
λxx, trunc.rec_on xx (λx, idp)
|
||||
|
||||
definition trunc_functor_id : trunc_functor n (@id A) ~ id :=
|
||||
λxx, trunc.rec_on xx (λx, idp)
|
||||
|
||||
definition trunc_functor_cast {X Y : Type} (n : ℕ₋₂) (p : X = Y) :
|
||||
trunc_functor n (cast p) ~ cast (ap (trunc n) p) :=
|
||||
begin
|
||||
intro x, induction x with x, esimp,
|
||||
exact fn_tr_eq_tr_fn p (λy, tr) x ⬝ !tr_compose
|
||||
end
|
||||
|
||||
definition is_equiv_trunc_functor [constructor] (f : X → Y) [H : is_equiv f]
|
||||
: is_equiv (trunc_functor n f) :=
|
||||
adjointify _
|
||||
(trunc_functor n f⁻¹)
|
||||
(λyy, trunc.rec_on yy (λy, ap tr !right_inv))
|
||||
(λxx, trunc.rec_on xx (λx, ap tr !left_inv))
|
||||
|
||||
definition trunc_homotopy {f g : X → Y} (p : f ~ g) : trunc_functor n f ~ trunc_functor n g :=
|
||||
λxx, trunc.rec_on xx (λx, ap tr (p x))
|
||||
|
||||
section
|
||||
definition trunc_equiv_trunc [constructor] (f : X ≃ Y) : trunc n X ≃ trunc n Y :=
|
||||
equiv.mk _ (is_equiv_trunc_functor n f)
|
||||
end
|
||||
|
||||
section
|
||||
open prod.ops
|
||||
definition trunc_prod_equiv [constructor] : trunc n (X × Y) ≃ trunc n X × trunc n Y :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{exact (λpp, trunc.rec_on pp (λp, (tr p.1, tr p.2)))},
|
||||
{intro p, cases p with xx yy,
|
||||
apply (trunc.rec_on xx), intro x,
|
||||
apply (trunc.rec_on yy), intro y, exact (tr (x,y))},
|
||||
{intro p, cases p with xx yy,
|
||||
apply (trunc.rec_on xx), intro x,
|
||||
apply (trunc.rec_on yy), intro y, apply idp},
|
||||
{intro pp, apply (trunc.rec_on pp), intro p, cases p, apply idp}
|
||||
end
|
||||
end
|
||||
|
||||
/- Propositional truncation -/
|
||||
|
||||
definition ttrunc [constructor] (n : ℕ₋₂) (X : Type) : n-Type :=
|
||||
trunctype.mk (trunc n X) _
|
||||
|
||||
-- should this live in Prop?
|
||||
definition merely [reducible] [constructor] (A : Type) : Prop := ttrunc -1 A
|
||||
|
||||
notation `||`:max A `||`:0 := merely A
|
||||
notation `∥`:max A `∥`:0 := merely A
|
||||
|
||||
definition Exists [reducible] [constructor] (P : X → Type) : Prop := ∥ sigma P ∥
|
||||
definition or [reducible] [constructor] (A B : Type) : Prop := ∥ A ⊎ B ∥
|
||||
|
||||
notation `exists` binders `,` r:(scoped P, Exists P) := r
|
||||
notation `∃` binders `,` r:(scoped P, Exists P) := r
|
||||
notation A ` \/ ` B := or A B
|
||||
notation A ∨ B := or A B
|
||||
|
||||
definition merely.intro [reducible] [constructor] (a : A) : ∥ A ∥ := tr a
|
||||
definition exists.intro [reducible] [constructor] (x : X) (p : P x) : ∃x, P x := tr ⟨x, p⟩
|
||||
definition or.intro_left [reducible] [constructor] (x : X) : X ∨ Y := tr (inl x)
|
||||
definition or.intro_right [reducible] [constructor] (y : Y) : X ∨ Y := tr (inr y)
|
||||
|
||||
definition is_contr_of_merely_prop [H : is_prop A] (aa : merely A) : is_contr A :=
|
||||
is_contr_of_inhabited_prop (trunc.rec_on aa id)
|
||||
|
||||
section
|
||||
open sigma.ops
|
||||
definition trunc_sigma_equiv [constructor] : trunc n (Σ x, P x) ≃ trunc n (Σ x, trunc n (P x)) :=
|
||||
equiv.MK (λpp, trunc.rec_on pp (λp, tr ⟨p.1, tr p.2⟩))
|
||||
(λpp, trunc.rec_on pp (λp, trunc.rec_on p.2 (λb, tr ⟨p.1, b⟩)))
|
||||
(λpp, trunc.rec_on pp (λp, sigma.rec_on p (λa bb, trunc.rec_on bb (λb, by esimp))))
|
||||
(λpp, trunc.rec_on pp (λp, sigma.rec_on p (λa b, by esimp)))
|
||||
|
||||
definition trunc_sigma_equiv_of_is_trunc [H : is_trunc n X]
|
||||
: trunc n (Σ x, P x) ≃ Σ x, trunc n (P x) :=
|
||||
calc
|
||||
trunc n (Σ x, P x) ≃ trunc n (Σ x, trunc n (P x)) : trunc_sigma_equiv
|
||||
... ≃ Σ x, trunc n (P x) : !trunc_equiv
|
||||
end
|
||||
|
||||
/- the (non-dependent) universal property -/
|
||||
definition trunc_arrow_equiv [constructor] [H : is_trunc n B] :
|
||||
(trunc n A → B) ≃ (A → B) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro g a, exact g (tr a)},
|
||||
{ intro f x, exact trunc.rec_on x f},
|
||||
{ intro f, apply eq_of_homotopy, intro a, reflexivity},
|
||||
{ intro g, apply eq_of_homotopy, intro x, exact trunc.rec_on x (λa, idp)},
|
||||
end
|
||||
|
||||
end trunc
|
||||
|
|
@ -1,658 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
|
||||
Authors: Floris van Doorn
|
||||
-/
|
||||
|
||||
import homotopy.circle eq2 algebra.e_closure cubical.squareover cubical.cube cubical.square2
|
||||
|
||||
open quotient eq circle sum sigma equiv function relation e_closure
|
||||
|
||||
/-
|
||||
This files defines a general class of nonrecursive 2-HITs using just quotients.
|
||||
We can define any HIT X which has
|
||||
- a single 0-constructor
|
||||
f : A → X (for some type A)
|
||||
- a single 1-constructor
|
||||
e : Π{a a' : A}, R a a' → a = a' (for some (type-valued) relation R on A)
|
||||
and furthermore has 2-constructors which are all of the form
|
||||
p = p'
|
||||
where p, p' are of the form
|
||||
- refl (f a), for some a : A;
|
||||
- e r, for some r : R a a';
|
||||
- ap f q, where q : a = a' :> A;
|
||||
- inverses of such paths;
|
||||
- concatenations of such paths.
|
||||
|
||||
so an example 2-constructor could be (as long as it typechecks):
|
||||
ap f q' ⬝ ((e r)⁻¹ ⬝ ap f q)⁻¹ ⬝ e r' = idp
|
||||
|
||||
We first define "simple two quotients" which have as requirement that the right hand side is idp
|
||||
Then we define "two quotients" which can have an arbitrary path on the right hand side
|
||||
Then we define "truncated two quotients", which is a two quotient followed by n-truncation,
|
||||
and show that this satisfies the desired induction principle and computation rule.
|
||||
|
||||
Caveat: for none of these constructions we show that the induction priniciple computes on
|
||||
2-paths. However, with truncated two quotients, if the truncation is a 1-truncation, then this
|
||||
computation rule follows automatically, since the target is a 1-type.
|
||||
-/
|
||||
|
||||
namespace simple_two_quotient
|
||||
|
||||
section
|
||||
parameters {A : Type}
|
||||
(R : A → A → Type)
|
||||
local abbreviation T := e_closure R -- the (type-valued) equivalence closure of R
|
||||
parameter (Q : Π⦃a⦄, T a a → Type)
|
||||
variables ⦃a a' : A⦄ {s : R a a'} {r : T a a}
|
||||
|
||||
|
||||
local abbreviation B := A ⊎ Σ(a : A) (r : T a a), Q r
|
||||
|
||||
inductive pre_two_quotient_rel : B → B → Type :=
|
||||
| pre_Rmk {} : Π⦃a a'⦄ (r : R a a'), pre_two_quotient_rel (inl a) (inl a')
|
||||
--BUG: if {} not provided, the alias for pre_Rmk is wrong
|
||||
|
||||
definition pre_two_quotient := quotient pre_two_quotient_rel
|
||||
|
||||
open pre_two_quotient_rel
|
||||
local abbreviation C := quotient pre_two_quotient_rel
|
||||
protected definition j [constructor] (a : A) : C := class_of pre_two_quotient_rel (inl a)
|
||||
protected definition pre_aux [constructor] (q : Q r) : C :=
|
||||
class_of pre_two_quotient_rel (inr ⟨a, r, q⟩)
|
||||
protected definition e (s : R a a') : j a = j a' := eq_of_rel _ (pre_Rmk s)
|
||||
protected definition et (t : T a a') : j a = j a' := e_closure.elim e t
|
||||
protected definition f [unfold 7] (q : Q r) : S¹ → C :=
|
||||
circle.elim (j a) (et r)
|
||||
|
||||
protected definition pre_rec [unfold 8] {P : C → Type}
|
||||
(Pj : Πa, P (j a)) (Pa : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), P (pre_aux q))
|
||||
(Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a =[e s] Pj a') (x : C) : P x :=
|
||||
begin
|
||||
induction x with p,
|
||||
{ induction p,
|
||||
{ apply Pj},
|
||||
{ induction a with a1 a2, induction a2, apply Pa}},
|
||||
{ induction H, esimp, apply Pe},
|
||||
end
|
||||
|
||||
protected definition pre_elim [unfold 8] {P : Type} (Pj : A → P)
|
||||
(Pa : Π⦃a : A⦄ ⦃r : T a a⦄, Q r → P) (Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a = Pj a') (x : C)
|
||||
: P :=
|
||||
pre_rec Pj Pa (λa a' s, pathover_of_eq _ (Pe s)) x
|
||||
|
||||
protected theorem rec_e {P : C → Type}
|
||||
(Pj : Πa, P (j a)) (Pa : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), P (pre_aux q))
|
||||
(Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a =[e s] Pj a') ⦃a a' : A⦄ (s : R a a')
|
||||
: apd (pre_rec Pj Pa Pe) (e s) = Pe s :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected theorem elim_e {P : Type} (Pj : A → P) (Pa : Π⦃a : A⦄ ⦃r : T a a⦄, Q r → P)
|
||||
(Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a = Pj a') ⦃a a' : A⦄ (s : R a a')
|
||||
: ap (pre_elim Pj Pa Pe) (e s) = Pe s :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (e s)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑pre_elim,rec_e],
|
||||
end
|
||||
|
||||
protected definition elim_et {P : Type} (Pj : A → P) (Pa : Π⦃a : A⦄ ⦃r : T a a⦄, Q r → P)
|
||||
(Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a = Pj a') ⦃a a' : A⦄ (t : T a a')
|
||||
: ap (pre_elim Pj Pa Pe) (et t) = e_closure.elim Pe t :=
|
||||
ap_e_closure_elim_h e (elim_e Pj Pa Pe) t
|
||||
|
||||
protected definition rec_et {P : C → Type}
|
||||
(Pj : Πa, P (j a)) (Pa : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), P (pre_aux q))
|
||||
(Pe : Π⦃a a' : A⦄ (s : R a a'), Pj a =[e s] Pj a') ⦃a a' : A⦄ (t : T a a')
|
||||
: apd (pre_rec Pj Pa Pe) (et t) = e_closure.elimo e Pe t :=
|
||||
ap_e_closure_elimo_h e Pe (rec_e Pj Pa Pe) t
|
||||
|
||||
inductive simple_two_quotient_rel : C → C → Type :=
|
||||
| Rmk {} : Π{a : A} {r : T a a} (q : Q r) (x : circle),
|
||||
simple_two_quotient_rel (f q x) (pre_aux q)
|
||||
|
||||
open simple_two_quotient_rel
|
||||
definition simple_two_quotient := quotient simple_two_quotient_rel
|
||||
local abbreviation D := simple_two_quotient
|
||||
local abbreviation i := class_of simple_two_quotient_rel
|
||||
definition incl0 (a : A) : D := i (j a)
|
||||
protected definition aux (q : Q r) : D := i (pre_aux q)
|
||||
definition incl1 (s : R a a') : incl0 a = incl0 a' := ap i (e s)
|
||||
definition inclt (t : T a a') : incl0 a = incl0 a' := e_closure.elim incl1 t
|
||||
|
||||
-- "wrong" version inclt, which is ap i (p ⬝ q) instead of ap i p ⬝ ap i q
|
||||
-- it is used in the proof, because incltw is easier to work with
|
||||
protected definition incltw (t : T a a') : incl0 a = incl0 a' := ap i (et t)
|
||||
|
||||
protected definition inclt_eq_incltw (t : T a a') : inclt t = incltw t :=
|
||||
(ap_e_closure_elim i e t)⁻¹
|
||||
|
||||
definition incl2' (q : Q r) (x : S¹) : i (f q x) = aux q :=
|
||||
eq_of_rel simple_two_quotient_rel (Rmk q x)
|
||||
|
||||
protected definition incl2w (q : Q r) : incltw r = idp :=
|
||||
(ap02 i (elim_loop (j a) (et r))⁻¹) ⬝
|
||||
(ap_compose i (f q) loop)⁻¹ ⬝
|
||||
ap_is_constant (incl2' q) loop ⬝
|
||||
!con.right_inv
|
||||
|
||||
definition incl2 (q : Q r) : inclt r = idp :=
|
||||
inclt_eq_incltw r ⬝ incl2w q
|
||||
|
||||
local attribute simple_two_quotient f i D incl0 aux incl1 incl2' inclt [reducible]
|
||||
local attribute i aux incl0 [constructor]
|
||||
|
||||
parameters {R Q}
|
||||
protected definition rec {P : D → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 r) = idpo) (x : D) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ refine (pre_rec _ _ _ a),
|
||||
{ exact P0},
|
||||
{ intro a r q, exact incl2' q base ▸ P0 a},
|
||||
{ intro a a' s, exact pathover_of_pathover_ap P i (P1 s)}},
|
||||
{ exact abstract [irreducible] begin induction H, induction x,
|
||||
{ esimp, exact pathover_tr (incl2' q base) (P0 a)},
|
||||
{ apply pathover_pathover,
|
||||
esimp, fold [i, incl2' q],
|
||||
refine eq_hconcato _ _, apply _,
|
||||
{ transitivity _,
|
||||
{ apply ap (pathover_ap _ _),
|
||||
transitivity _, apply apd_compose2 (pre_rec P0 _ _) (f q) loop,
|
||||
apply ap (pathover_of_pathover_ap _ _),
|
||||
transitivity _, apply apd_change_path, exact !elim_loop⁻¹,
|
||||
transitivity _,
|
||||
apply ap (change_path _),
|
||||
transitivity _, apply rec_et,
|
||||
transitivity (pathover_of_pathover_ap P i (change_path (inclt_eq_incltw r)
|
||||
(e_closure.elimo incl1 (λ (a a' : A) (s : R a a'), P1 s) r))),
|
||||
apply e_closure_elimo_ap,
|
||||
exact idp,
|
||||
apply change_path_pathover_of_pathover_ap},
|
||||
esimp, transitivity _, apply pathover_ap_pathover_of_pathover_ap P i (f q),
|
||||
transitivity _, apply ap (change_path _), apply to_right_inv !pathover_compose,
|
||||
do 2 (transitivity _; exact !change_path_con⁻¹),
|
||||
transitivity _, apply ap (change_path _),
|
||||
exact (to_left_inv (change_path_equiv _ _ (incl2 q)) _)⁻¹, esimp,
|
||||
rewrite P2, transitivity _; exact !change_path_con⁻¹, apply ap (λx, change_path x _),
|
||||
rewrite [↑incl2, con_inv], transitivity _, exact !con.assoc⁻¹,
|
||||
rewrite [inv_con_cancel_right, ↑incl2w, ↑ap02, +con_inv, +ap_inv, +inv_inv, -+con.assoc,
|
||||
+con_inv_cancel_right], reflexivity},
|
||||
rewrite [change_path_con, apd_constant],
|
||||
apply squareover_change_path_left, apply squareover_change_path_right',
|
||||
apply squareover_change_path_left,
|
||||
refine change_square _ vrflo,
|
||||
symmetry, apply inv_ph_eq_of_eq_ph, rewrite [ap_is_constant_natural_square],
|
||||
apply whisker_bl_whisker_tl_eq} end end},
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : D → Type} (x : D) (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 r) = idpo) : P x :=
|
||||
rec P0 P1 P2 x
|
||||
|
||||
theorem rec_incl1 {P : D → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 r) = idpo) ⦃a a' : A⦄ (s : R a a')
|
||||
: apd (rec P0 P1 P2) (incl1 s) = P1 s :=
|
||||
begin
|
||||
unfold [rec, incl1], refine !apd_ap ⬝ _, esimp, rewrite rec_e,
|
||||
apply to_right_inv !pathover_compose
|
||||
end
|
||||
|
||||
theorem rec_inclt {P : D → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 r) = idpo) ⦃a a' : A⦄ (t : T a a')
|
||||
: apd (rec P0 P1 P2) (inclt t) = e_closure.elimo incl1 P1 t :=
|
||||
ap_e_closure_elimo_h incl1 P1 (rec_incl1 P0 P1 P2) t
|
||||
|
||||
protected definition elim {P : Type} (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
(x : D) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ refine (pre_elim _ _ _ a),
|
||||
{ exact P0},
|
||||
{ intro a r q, exact P0 a},
|
||||
{ exact P1}},
|
||||
{ exact abstract begin induction H, induction x,
|
||||
{ exact idpath (P0 a)},
|
||||
{ unfold f, apply eq_pathover, apply hdeg_square,
|
||||
exact abstract ap_compose (pre_elim P0 _ P1) (f q) loop ⬝
|
||||
ap _ !elim_loop ⬝
|
||||
!elim_et ⬝
|
||||
P2 q ⬝
|
||||
!ap_constant⁻¹ end} end end},
|
||||
end
|
||||
local attribute elim [unfold 8]
|
||||
|
||||
protected definition elim_on {P : Type} (x : D) (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
: P :=
|
||||
elim P0 P1 P2 x
|
||||
|
||||
definition elim_incl1 {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a a' : A⦄ (s : R a a') : ap (elim P0 P1 P2) (incl1 s) = P1 s :=
|
||||
(ap_compose (elim P0 P1 P2) i (e s))⁻¹ ⬝ !elim_e
|
||||
|
||||
definition elim_inclt {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a a' : A⦄ (t : T a a') : ap (elim P0 P1 P2) (inclt t) = e_closure.elim P1 t :=
|
||||
ap_e_closure_elim_h incl1 (elim_incl1 P2) t
|
||||
|
||||
protected definition elim_incltw {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a a' : A⦄ (t : T a a') : ap (elim P0 P1 P2) (incltw t) = e_closure.elim P1 t :=
|
||||
(ap_compose (elim P0 P1 P2) i (et t))⁻¹ ⬝ !elim_et
|
||||
|
||||
protected theorem elim_inclt_eq_elim_incltw {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a a' : A⦄ (t : T a a')
|
||||
: elim_inclt P2 t = ap (ap (elim P0 P1 P2)) (inclt_eq_incltw t) ⬝ elim_incltw P2 t :=
|
||||
begin
|
||||
unfold [elim_inclt,elim_incltw,inclt_eq_incltw,et],
|
||||
refine !ap_e_closure_elim_h_eq ⬝ _,
|
||||
rewrite [ap_inv,-con.assoc],
|
||||
xrewrite [eq_of_square (ap_ap_e_closure_elim i (elim P0 P1 P2) e t)⁻¹ʰ],
|
||||
rewrite [↓incl1,con.assoc], apply whisker_left,
|
||||
rewrite [↑[elim_et,elim_incl1],+ap_e_closure_elim_h_eq,con_inv,↑[i,function.compose]],
|
||||
rewrite [-con.assoc (_ ⬝ _),con.assoc _⁻¹,con.left_inv,▸*,-ap_inv,-ap_con],
|
||||
apply ap (ap _),
|
||||
krewrite [-eq_of_homotopy3_inv,-eq_of_homotopy3_con]
|
||||
end
|
||||
|
||||
definition elim_incl2' {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a : A⦄ ⦃r : T a a⦄ (q : Q r) : ap (elim P0 P1 P2) (incl2' q base) = idpath (P0 a) :=
|
||||
!elim_eq_of_rel
|
||||
|
||||
local attribute whisker_right [reducible]
|
||||
protected theorem elim_incl2w {P : Type} (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a : A⦄ ⦃r : T a a⦄ (q : Q r)
|
||||
: square (ap02 (elim P0 P1 P2) (incl2w q)) (P2 q) (elim_incltw P2 r) idp :=
|
||||
begin
|
||||
esimp [incl2w,ap02],
|
||||
rewrite [+ap_con (ap _),▸*],
|
||||
xrewrite [-ap_compose (ap _) (ap i)],
|
||||
rewrite [+ap_inv],
|
||||
xrewrite [eq_top_of_square
|
||||
((ap_compose_natural (elim P0 P1 P2) i (elim_loop (j a) (et r)))⁻¹ʰ⁻¹ᵛ ⬝h
|
||||
(ap_ap_compose (elim P0 P1 P2) i (f q) loop)⁻¹ʰ⁻¹ᵛ ⬝h
|
||||
ap_ap_is_constant (elim P0 P1 P2) (incl2' q) loop ⬝h
|
||||
ap_con_right_inv_sq (elim P0 P1 P2) (incl2' q base)),
|
||||
↑[elim_incltw]],
|
||||
apply whisker_tl,
|
||||
rewrite [ap_is_constant_eq],
|
||||
xrewrite [naturality_apd_eq (λx, !elim_eq_of_rel) loop],
|
||||
rewrite [↑elim_2,rec_loop,square_of_pathover_concato_eq,square_of_pathover_eq_concato,
|
||||
eq_of_square_vconcat_eq,eq_of_square_eq_vconcat],
|
||||
apply eq_vconcat,
|
||||
{ apply ap (λx, _ ⬝ eq_con_inv_of_con_eq ((_ ⬝ x ⬝ _)⁻¹ ⬝ _) ⬝ _),
|
||||
transitivity _, apply ap eq_of_square,
|
||||
apply to_right_inv !eq_pathover_equiv_square (hdeg_square (elim_1 P A R Q P0 P1 a r q P2)),
|
||||
transitivity _, apply eq_of_square_hdeg_square,
|
||||
unfold elim_1, reflexivity},
|
||||
rewrite [+con_inv,whisker_left_inv,+inv_inv,-whisker_right_inv,
|
||||
con.assoc (whisker_left _ _),con.assoc _ (whisker_right _ _),▸*,
|
||||
whisker_right_con_whisker_left _ !ap_constant],
|
||||
xrewrite [-con.assoc _ _ (whisker_right _ _)],
|
||||
rewrite [con.assoc _ _ (whisker_left _ _),idp_con_whisker_left,▸*,
|
||||
con.assoc _ !ap_constant⁻¹,con.left_inv],
|
||||
xrewrite [eq_con_inv_of_con_eq_whisker_left,▸*],
|
||||
rewrite [+con.assoc _ _ !con.right_inv,
|
||||
right_inv_eq_idp (
|
||||
(λ(x : ap (elim P0 P1 P2) (incl2' q base) = idpath
|
||||
(elim P0 P1 P2 (class_of simple_two_quotient_rel (f q base)))), x)
|
||||
(elim_incl2' P2 q)),
|
||||
↑[whisker_left]],
|
||||
xrewrite [con2_con_con2],
|
||||
rewrite [idp_con,↑elim_incl2',con.left_inv,whisker_right_inv,↑whisker_right],
|
||||
xrewrite [con.assoc _ _ (_ ◾ _)],
|
||||
rewrite [con.left_inv,▸*,-+con.assoc,con.assoc _⁻¹,↑[elim,function.compose],con.left_inv,
|
||||
▸*,↑j,con.left_inv,idp_con],
|
||||
apply square_of_eq, reflexivity
|
||||
end
|
||||
|
||||
theorem elim_incl2 {P : Type} (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a : A⦄ ⦃r : T a a⦄ (q : Q r), e_closure.elim P1 r = idp)
|
||||
⦃a : A⦄ ⦃r : T a a⦄ (q : Q r)
|
||||
: square (ap02 (elim P0 P1 P2) (incl2 q)) (P2 q) (elim_inclt P2 r) idp :=
|
||||
begin
|
||||
rewrite [↑incl2,↑ap02,ap_con,elim_inclt_eq_elim_incltw],
|
||||
apply whisker_tl,
|
||||
apply elim_incl2w
|
||||
end
|
||||
|
||||
end
|
||||
end simple_two_quotient
|
||||
|
||||
export [unfold] simple_two_quotient
|
||||
attribute simple_two_quotient.j simple_two_quotient.incl0 [constructor]
|
||||
attribute simple_two_quotient.rec simple_two_quotient.elim [unfold 8] [recursor 8]
|
||||
--attribute simple_two_quotient.elim_type [unfold 9] -- TODO
|
||||
attribute simple_two_quotient.rec_on simple_two_quotient.elim_on [unfold 5]
|
||||
--attribute simple_two_quotient.elim_type_on [unfold 6] -- TODO
|
||||
|
||||
namespace two_quotient
|
||||
open simple_two_quotient
|
||||
section
|
||||
parameters {A : Type}
|
||||
(R : A → A → Type)
|
||||
local abbreviation T := e_closure R -- the (type-valued) equivalence closure of R
|
||||
parameter (Q : Π⦃a a'⦄, T a a' → T a a' → Type)
|
||||
variables ⦃a a' a'' : A⦄ {s : R a a'} {t t' : T a a'}
|
||||
|
||||
inductive two_quotient_Q : Π⦃a : A⦄, e_closure R a a → Type :=
|
||||
| Qmk : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄, Q t t' → two_quotient_Q (t ⬝r t'⁻¹ʳ)
|
||||
open two_quotient_Q
|
||||
local abbreviation Q2 := two_quotient_Q
|
||||
|
||||
definition two_quotient := simple_two_quotient R Q2
|
||||
definition incl0 (a : A) : two_quotient := incl0 _ _ a
|
||||
definition incl1 (s : R a a') : incl0 a = incl0 a' := incl1 _ _ s
|
||||
definition inclt (t : T a a') : incl0 a = incl0 a' := e_closure.elim incl1 t
|
||||
definition incl2 (q : Q t t') : inclt t = inclt t' :=
|
||||
eq_of_con_inv_eq_idp (incl2 _ _ (Qmk R q))
|
||||
|
||||
parameters {R Q}
|
||||
protected definition rec {P : two_quotient → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
(x : two_quotient) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact P0 a},
|
||||
{ exact P1 s},
|
||||
{ exact abstract [irreducible] begin induction q with a a' t t' q,
|
||||
rewrite [elimo_trans (simple_two_quotient.incl1 R Q2) P1,
|
||||
elimo_symm (simple_two_quotient.incl1 R Q2) P1,
|
||||
-whisker_right_eq_of_con_inv_eq_idp (simple_two_quotient.incl2 R Q2 (Qmk R q)),
|
||||
change_path_con],
|
||||
xrewrite [change_path_cono],
|
||||
refine ap (λx, change_path _ (_ ⬝o x)) !change_path_invo ⬝ _, esimp,
|
||||
apply cono_invo_eq_idpo, apply P2 end end}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : two_quotient → Type} (x : two_quotient)
|
||||
(P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t') : P x :=
|
||||
rec P0 P1 P2 x
|
||||
|
||||
theorem rec_incl1 {P : two_quotient → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
⦃a a' : A⦄ (s : R a a') : apd (rec P0 P1 P2) (incl1 s) = P1 s :=
|
||||
rec_incl1 _ _ _ s
|
||||
|
||||
theorem rec_inclt {P : two_quotient → Type} (P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
⦃a a' : A⦄ (t : T a a') : apd (rec P0 P1 P2) (inclt t) = e_closure.elimo incl1 P1 t :=
|
||||
rec_inclt _ _ _ t
|
||||
|
||||
protected definition elim {P : Type} (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
(x : two_quotient) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact P0 a},
|
||||
{ exact P1 s},
|
||||
{ exact abstract [unfold 10] begin induction q with a a' t t' q,
|
||||
esimp [e_closure.elim],
|
||||
apply con_inv_eq_idp, exact P2 q end end},
|
||||
end
|
||||
local attribute elim [unfold 8]
|
||||
|
||||
protected definition elim_on {P : Type} (x : two_quotient) (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
: P :=
|
||||
elim P0 P1 P2 x
|
||||
|
||||
definition elim_incl1 {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (s : R a a') : ap (elim P0 P1 P2) (incl1 s) = P1 s :=
|
||||
!elim_incl1
|
||||
|
||||
definition elim_inclt {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (t : T a a') : ap (elim P0 P1 P2) (inclt t) = e_closure.elim P1 t :=
|
||||
ap_e_closure_elim_h incl1 (elim_incl1 P2) t
|
||||
|
||||
theorem elim_incl2 {P : Type} (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t')
|
||||
: square (ap02 (elim P0 P1 P2) (incl2 q)) (P2 q) (elim_inclt P2 t) (elim_inclt P2 t') :=
|
||||
begin
|
||||
rewrite [↑[incl2,elim],ap_eq_of_con_inv_eq_idp],
|
||||
xrewrite [eq_top_of_square (elim_incl2 P0 P1 (elim_1 A R Q P P0 P1 P2) (Qmk R q))],
|
||||
xrewrite [{simple_two_quotient.elim_inclt (elim_1 A R Q P P0 P1 P2)
|
||||
(t ⬝r t'⁻¹ʳ)}
|
||||
idpath (ap_con (simple_two_quotient.elim P0 P1 (elim_1 A R Q P P0 P1 P2))
|
||||
(inclt t) (inclt t')⁻¹ ⬝
|
||||
(simple_two_quotient.elim_inclt (elim_1 A R Q P P0 P1 P2) t ◾
|
||||
(ap_inv (simple_two_quotient.elim P0 P1 (elim_1 A R Q P P0 P1 P2))
|
||||
(inclt t') ⬝
|
||||
inverse2 (simple_two_quotient.elim_inclt (elim_1 A R Q P P0 P1 P2) t')))),▸*],
|
||||
rewrite [-con.assoc _ _ (con_inv_eq_idp _),-con.assoc _ _ (_ ◾ _),con.assoc _ _ (ap_con _ _ _),
|
||||
con.left_inv,↑whisker_left,con2_con_con2,-con.assoc (ap_inv _ _)⁻¹,
|
||||
con.left_inv,+idp_con,eq_of_con_inv_eq_idp_con2],
|
||||
xrewrite [to_left_inv !eq_equiv_con_inv_eq_idp (P2 q)],
|
||||
apply top_deg_square
|
||||
end
|
||||
|
||||
definition elim_inclt_rel [unfold_full] {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (r : R a a') : elim_inclt P2 [r] = elim_incl1 P2 r :=
|
||||
idp
|
||||
|
||||
definition elim_inclt_inv [unfold_full] {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (t : T a a')
|
||||
: elim_inclt P2 t⁻¹ʳ = ap_inv (elim P0 P1 P2) (inclt t) ⬝ (elim_inclt P2 t)⁻² :=
|
||||
idp
|
||||
|
||||
definition elim_inclt_con [unfold_full] {P : Type} {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' a'' : A⦄ (t : T a a') (t': T a' a'')
|
||||
: elim_inclt P2 (t ⬝r t') =
|
||||
ap_con (elim P0 P1 P2) (inclt t) (inclt t') ⬝ (elim_inclt P2 t ◾ elim_inclt P2 t') :=
|
||||
idp
|
||||
|
||||
definition inclt_rel [unfold_full] (r : R a a') : inclt [r] = incl1 r := idp
|
||||
definition inclt_inv [unfold_full] (t : T a a') : inclt t⁻¹ʳ = (inclt t)⁻¹ := idp
|
||||
definition inclt_con [unfold_full] (t : T a a') (t' : T a' a'')
|
||||
: inclt (t ⬝r t') = inclt t ⬝ inclt t' := idp
|
||||
end
|
||||
end two_quotient
|
||||
|
||||
attribute two_quotient.incl0 [constructor]
|
||||
attribute two_quotient.rec two_quotient.elim [unfold 8] [recursor 8]
|
||||
--attribute two_quotient.elim_type [unfold 9]
|
||||
attribute two_quotient.rec_on two_quotient.elim_on [unfold 5]
|
||||
--attribute two_quotient.elim_type_on [unfold 6]
|
||||
|
||||
open two_quotient is_trunc trunc
|
||||
|
||||
namespace trunc_two_quotient
|
||||
|
||||
section
|
||||
parameters (n : ℕ₋₂) {A : Type}
|
||||
(R : A → A → Type)
|
||||
local abbreviation T := e_closure R -- the (type-valued) equivalence closure of R
|
||||
parameter (Q : Π⦃a a'⦄, T a a' → T a a' → Type)
|
||||
variables ⦃a a' a'' : A⦄ {s : R a a'} {t t' : T a a'}
|
||||
|
||||
definition trunc_two_quotient := trunc n (two_quotient R Q)
|
||||
|
||||
parameters {n R Q}
|
||||
definition incl0 (a : A) : trunc_two_quotient := tr (!incl0 a)
|
||||
definition incl1 (s : R a a') : incl0 a = incl0 a' := ap tr (!incl1 s)
|
||||
definition incltw (t : T a a') : incl0 a = incl0 a' := ap tr (!inclt t)
|
||||
definition inclt (t : T a a') : incl0 a = incl0 a' := e_closure.elim incl1 t
|
||||
definition incl2w (q : Q t t') : incltw t = incltw t' :=
|
||||
ap02 tr (!incl2 q)
|
||||
definition incl2 (q : Q t t') : inclt t = inclt t' :=
|
||||
!ap_e_closure_elim⁻¹ ⬝ ap02 tr (!incl2 q) ⬝ !ap_e_closure_elim
|
||||
|
||||
local attribute trunc_two_quotient incl0 [reducible]
|
||||
definition is_trunc_trunc_two_quotient [instance] : is_trunc n trunc_two_quotient := _
|
||||
|
||||
protected definition rec {P : trunc_two_quotient → Type} [H : Πx, is_trunc n (P x)]
|
||||
(P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
(x : trunc_two_quotient) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
induction a,
|
||||
{ exact P0 a},
|
||||
{ exact !pathover_of_pathover_ap (P1 s)},
|
||||
{ exact abstract [irreducible]
|
||||
by rewrite [+ e_closure_elimo_ap, ↓incl1, -P2 q, change_path_pathover_of_pathover_ap,
|
||||
- + change_path_con, ↑incl2, con_inv_cancel_right] end}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : trunc_two_quotient → Type} [H : Πx, is_trunc n (P x)]
|
||||
(x : trunc_two_quotient)
|
||||
(P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t') : P x :=
|
||||
rec P0 P1 P2 x
|
||||
|
||||
theorem rec_incl1 {P : trunc_two_quotient → Type} [H : Πx, is_trunc n (P x)]
|
||||
(P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
⦃a a' : A⦄ (s : R a a') : apd (rec P0 P1 P2) (incl1 s) = P1 s :=
|
||||
!apd_ap ⬝ ap !pathover_ap !rec_incl1 ⬝ to_right_inv !pathover_compose (P1 s)
|
||||
|
||||
theorem rec_inclt {P : trunc_two_quotient → Type} [H : Πx, is_trunc n (P x)]
|
||||
(P0 : Π(a : A), P (incl0 a))
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a =[incl1 s] P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'),
|
||||
change_path (incl2 q) (e_closure.elimo incl1 P1 t) = e_closure.elimo incl1 P1 t')
|
||||
⦃a a' : A⦄ (t : T a a') : apd (rec P0 P1 P2) (inclt t) = e_closure.elimo incl1 P1 t :=
|
||||
ap_e_closure_elimo_h incl1 P1 (rec_incl1 P0 P1 P2) t
|
||||
|
||||
protected definition elim {P : Type} (P0 : A → P) [H : is_trunc n P]
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
(x : trunc_two_quotient) : P :=
|
||||
begin
|
||||
induction x,
|
||||
induction a,
|
||||
{ exact P0 a},
|
||||
{ exact P1 s},
|
||||
{ exact P2 q},
|
||||
end
|
||||
local attribute elim [unfold 10]
|
||||
|
||||
protected definition elim_on {P : Type} [H : is_trunc n P] (x : trunc_two_quotient) (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
: P :=
|
||||
elim P0 P1 P2 x
|
||||
|
||||
definition elim_incl1 {P : Type} [H : is_trunc n P] {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (s : R a a') : ap (elim P0 P1 P2) (incl1 s) = P1 s :=
|
||||
!ap_compose⁻¹ ⬝ !elim_incl1
|
||||
|
||||
definition elim_inclt {P : Type} [H : is_trunc n P] {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (t : T a a') : ap (elim P0 P1 P2) (inclt t) = e_closure.elim P1 t :=
|
||||
ap_e_closure_elim_h incl1 (elim_incl1 P2) t
|
||||
|
||||
open function
|
||||
|
||||
theorem elim_incl2 {P : Type} [H : is_trunc n P] (P0 : A → P)
|
||||
(P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a')
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t')
|
||||
: square (ap02 (elim P0 P1 P2) (incl2 q)) (P2 q) (elim_inclt P2 t) (elim_inclt P2 t') :=
|
||||
begin
|
||||
note Ht' := ap_ap_e_closure_elim tr (elim P0 P1 P2) (two_quotient.incl1 R Q) t',
|
||||
note Ht := ap_ap_e_closure_elim tr (elim P0 P1 P2) (two_quotient.incl1 R Q) t,
|
||||
note Hn := natural_square_tr (ap_compose (elim P0 P1 P2) tr) (two_quotient.incl2 R Q q),
|
||||
note H7 := eq_top_of_square (Ht⁻¹ʰ ⬝h Hn⁻¹ᵛ ⬝h Ht'), clear [Hn, Ht, Ht'],
|
||||
unfold [ap02,incl2], rewrite [+ap_con,ap_inv,-ap_compose (ap _)],
|
||||
xrewrite [H7, ↑function.compose, eq_top_of_square (elim_incl2 P0 P1 P2 q)], clear [H7],
|
||||
have H : Π(t : T a a'),
|
||||
ap_e_closure_elim (elim P0 P1 P2) (λa a' (r : R a a'), ap tr (two_quotient.incl1 R Q r)) t ⬝
|
||||
(ap_e_closure_elim_h (two_quotient.incl1 R Q)
|
||||
(λa a' (s : R a a'), ap_compose (elim P0 P1 P2) tr (two_quotient.incl1 R Q s)) t)⁻¹ ⬝
|
||||
two_quotient.elim_inclt P2 t = elim_inclt P2 t, from
|
||||
ap_e_closure_elim_h_zigzag (elim P0 P1 P2)
|
||||
(two_quotient.incl1 R Q)
|
||||
(two_quotient.elim_incl1 P2),
|
||||
rewrite [con.assoc5, con.assoc5, H t, -inv_con_inv_right, -con_inv], xrewrite [H t'],
|
||||
apply top_deg_square
|
||||
end
|
||||
|
||||
definition elim_inclt_rel [unfold_full] {P : Type} [is_trunc n P] {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (r : R a a') : elim_inclt P2 [r] = elim_incl1 P2 r :=
|
||||
idp
|
||||
|
||||
definition elim_inclt_inv [unfold_full] {P : Type} [is_trunc n P] {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' : A⦄ (t : T a a')
|
||||
: elim_inclt P2 t⁻¹ʳ = ap_inv (elim P0 P1 P2) (inclt t) ⬝ (elim_inclt P2 t)⁻² :=
|
||||
idp
|
||||
|
||||
definition elim_inclt_con [unfold_full] {P : Type} [is_trunc n P] {P0 : A → P}
|
||||
{P1 : Π⦃a a' : A⦄ (s : R a a'), P0 a = P0 a'}
|
||||
(P2 : Π⦃a a' : A⦄ ⦃t t' : T a a'⦄ (q : Q t t'), e_closure.elim P1 t = e_closure.elim P1 t')
|
||||
⦃a a' a'' : A⦄ (t : T a a') (t': T a' a'')
|
||||
: elim_inclt P2 (t ⬝r t') =
|
||||
ap_con (elim P0 P1 P2) (inclt t) (inclt t') ⬝ (elim_inclt P2 t ◾ elim_inclt P2 t') :=
|
||||
idp
|
||||
|
||||
definition inclt_rel [unfold_full] (r : R a a') : inclt [r] = incl1 r := idp
|
||||
definition inclt_inv [unfold_full] (t : T a a') : inclt t⁻¹ʳ = (inclt t)⁻¹ := idp
|
||||
definition inclt_con [unfold_full] (t : T a a') (t' : T a' a'')
|
||||
: inclt (t ⬝r t') = inclt t ⬝ inclt t' := idp
|
||||
|
||||
|
||||
end
|
||||
end trunc_two_quotient
|
||||
|
||||
attribute trunc_two_quotient.incl0 [constructor]
|
||||
attribute trunc_two_quotient.rec trunc_two_quotient.elim [unfold 10] [recursor 10]
|
||||
attribute trunc_two_quotient.rec_on trunc_two_quotient.elim_on [unfold 7]
|
||||
|
|
@ -1,512 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
||||
Eilenberg MacLane spaces
|
||||
-/
|
||||
|
||||
import hit.groupoid_quotient homotopy.hopf homotopy.freudenthal homotopy.homotopy_group
|
||||
open algebra pointed nat eq category group is_trunc iso unit trunc equiv is_conn function is_equiv
|
||||
trunc_index
|
||||
|
||||
namespace EM
|
||||
open groupoid_quotient
|
||||
|
||||
variables {G : Group}
|
||||
definition EM1' (G : Group) : Type :=
|
||||
groupoid_quotient (Groupoid_of_Group G)
|
||||
definition EM1 [constructor] (G : Group) : Type* :=
|
||||
pointed.MK (EM1' G) (elt star)
|
||||
|
||||
definition base : EM1' G := elt star
|
||||
definition pth : G → base = base := pth
|
||||
definition resp_mul (g h : G) : pth (g * h) = pth g ⬝ pth h := resp_comp h g
|
||||
definition resp_one : pth (1 : G) = idp :=
|
||||
resp_id star
|
||||
|
||||
definition resp_inv (g : G) : pth (g⁻¹) = (pth g)⁻¹ :=
|
||||
resp_inv g
|
||||
|
||||
local attribute pointed.MK pointed.carrier EM1 EM1' [reducible]
|
||||
protected definition rec {P : EM1' G → Type} [H : Π(x : EM1' G), is_trunc 1 (P x)]
|
||||
(Pb : P base) (Pp : Π(g : G), Pb =[pth g] Pb)
|
||||
(Pmul : Π(g h : G), change_path (resp_mul g h) (Pp (g * h)) = Pp g ⬝o Pp h) (x : EM1' G) :
|
||||
P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ induction g, exact Pb},
|
||||
{ induction a, induction b, exact Pp f},
|
||||
{ induction a, induction b, induction c, exact Pmul f g}
|
||||
end
|
||||
|
||||
protected definition rec_on {P : EM1' G → Type} [H : Π(x : EM1' G), is_trunc 1 (P x)]
|
||||
(x : EM1' G) (Pb : P base) (Pp : Π(g : G), Pb =[pth g] Pb)
|
||||
(Pmul : Π(g h : G), change_path (resp_mul g h) (Pp (g * h)) = Pp g ⬝o Pp h) : P x :=
|
||||
EM.rec Pb Pp Pmul x
|
||||
|
||||
protected definition set_rec {P : EM1' G → Type} [H : Π(x : EM1' G), is_set (P x)]
|
||||
(Pb : P base) (Pp : Π(g : G), Pb =[pth g] Pb) (x : EM1' G) : P x :=
|
||||
EM.rec Pb Pp !center x
|
||||
|
||||
protected definition prop_rec {P : EM1' G → Type} [H : Π(x : EM1' G), is_prop (P x)]
|
||||
(Pb : P base) (x : EM1' G) : P x :=
|
||||
EM.rec Pb !center !center x
|
||||
|
||||
definition rec_pth {P : EM1' G → Type} [H : Π(x : EM1' G), is_trunc 1 (P x)]
|
||||
{Pb : P base} {Pp : Π(g : G), Pb =[pth g] Pb}
|
||||
(Pmul : Π(g h : G), change_path (resp_mul g h) (Pp (g * h)) = Pp g ⬝o Pp h)
|
||||
(g : G) : apd (EM.rec Pb Pp Pmul) (pth g) = Pp g :=
|
||||
proof !rec_pth qed
|
||||
|
||||
protected definition elim {P : Type} [is_trunc 1 P] (Pb : P) (Pp : Π(g : G), Pb = Pb)
|
||||
(Pmul : Π(g h : G), Pp (g * h) = Pp g ⬝ Pp h) (x : EM1' G) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact Pb},
|
||||
{ exact Pp f},
|
||||
{ exact Pmul f g}
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} [is_trunc 1 P] (x : EM1' G)
|
||||
(Pb : P) (Pp : G → Pb = Pb) (Pmul : Π(g h : G), Pp (g * h) = Pp g ⬝ Pp h) : P :=
|
||||
EM.elim Pb Pp Pmul x
|
||||
|
||||
protected definition set_elim [reducible] {P : Type} [is_set P] (Pb : P) (Pp : G → Pb = Pb)
|
||||
(x : EM1' G) : P :=
|
||||
EM.elim Pb Pp !center x
|
||||
|
||||
protected definition prop_elim [reducible] {P : Type} [is_prop P] (Pb : P) (x : EM1' G) : P :=
|
||||
EM.elim Pb !center !center x
|
||||
|
||||
definition elim_pth {P : Type} [is_trunc 1 P] {Pb : P} {Pp : G → Pb = Pb}
|
||||
(Pmul : Π(g h : G), Pp (g * h) = Pp g ⬝ Pp h) (g : G) : ap (EM.elim Pb Pp Pmul) (pth g) = Pp g :=
|
||||
proof !elim_pth qed
|
||||
|
||||
protected definition elim_set.{u} (Pb : Set.{u}) (Pp : Π(g : G), Pb ≃ Pb)
|
||||
(Pmul : Π(g h : G) (x : Pb), Pp (g * h) x = Pp h (Pp g x)) (x : EM1' G) : Set.{u} :=
|
||||
groupoid_quotient.elim_set (λu, Pb) (λu v, Pp) (λu v w g h, proof Pmul h g qed) x
|
||||
|
||||
theorem elim_set_pth {Pb : Set} {Pp : Π(g : G), Pb ≃ Pb}
|
||||
(Pmul : Π(g h : G) (x : Pb), Pp (g * h) x = Pp h (Pp g x)) (g : G) :
|
||||
transport (EM.elim_set Pb Pp Pmul) (pth g) = Pp g :=
|
||||
!elim_set_pth
|
||||
|
||||
end EM
|
||||
|
||||
attribute EM.base [constructor]
|
||||
attribute EM.rec EM.elim [unfold 7] [recursor 7]
|
||||
attribute EM.rec_on EM.elim_on [unfold 4]
|
||||
attribute EM.set_rec EM.set_elim [unfold 6]
|
||||
attribute EM.prop_rec EM.prop_elim EM.elim_set [unfold 5]
|
||||
|
||||
namespace EM
|
||||
open groupoid_quotient
|
||||
|
||||
variables (G : Group)
|
||||
definition base_eq_base_equiv : (base = base :> EM1 G) ≃ G :=
|
||||
!elt_eq_elt_equiv
|
||||
|
||||
definition fundamental_group_EM1 : π₁ (EM1 G) ≃g G :=
|
||||
begin
|
||||
fapply isomorphism_of_equiv,
|
||||
{ exact trunc_equiv_trunc 0 !base_eq_base_equiv ⬝e trunc_equiv 0 G},
|
||||
{ intros g h, induction g with p, induction h with q,
|
||||
exact encode_con p q}
|
||||
end
|
||||
|
||||
proposition is_trunc_EM1 [instance] : is_trunc 1 (EM1 G) :=
|
||||
!is_trunc_groupoid_quotient
|
||||
|
||||
proposition is_trunc_EM1' [instance] : is_trunc 1 (EM1' G) :=
|
||||
!is_trunc_groupoid_quotient
|
||||
|
||||
proposition is_conn_EM1' [instance] : is_conn 0 (EM1' G) :=
|
||||
by apply @is_conn_groupoid_quotient; esimp; exact _
|
||||
|
||||
proposition is_conn_EM1 [instance] : is_conn 0 (EM1 G) :=
|
||||
is_conn_EM1' G
|
||||
|
||||
variable {G}
|
||||
definition EM1_map [unfold 7] {X : Type*} (e : G → Ω X)
|
||||
(r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G → X :=
|
||||
begin
|
||||
intro x, induction x using EM.elim,
|
||||
{ exact Point X },
|
||||
{ exact e g },
|
||||
{ exact r g h }
|
||||
end
|
||||
|
||||
/- Uniqueness of K(G, 1) -/
|
||||
|
||||
definition EM1_pmap [constructor] {X : Type*} (e : G → Ω X)
|
||||
(r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G →* X :=
|
||||
pmap.mk (EM1_map e r) idp
|
||||
|
||||
variable (G)
|
||||
definition loop_EM1 [constructor] : G ≃* Ω (EM1 G) :=
|
||||
(pequiv_of_equiv (base_eq_base_equiv G) idp)⁻¹ᵉ*
|
||||
|
||||
variable {G}
|
||||
definition loop_EM1_pmap {X : Type*} (e : G →* Ω X)
|
||||
(r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] :
|
||||
Ω→(EM1_pmap e r) ∘* loop_EM1 G ~* e :=
|
||||
begin
|
||||
fapply phomotopy.mk,
|
||||
{ intro g, refine !idp_con ⬝ elim_pth r g },
|
||||
{ apply is_set.elim }
|
||||
end
|
||||
|
||||
definition EM1_pequiv'.{u} {G : Group.{u}} {X : pType.{u}} (e : G ≃* Ω X)
|
||||
(r : Πg h, e (g * h) = e g ⬝ e h) [is_conn 0 X] [is_trunc 1 X] : EM1 G ≃* X :=
|
||||
begin
|
||||
apply pequiv_of_pmap (EM1_pmap e r),
|
||||
apply whitehead_principle_pointed 1,
|
||||
intro k, cases k with k,
|
||||
{ apply @is_equiv_of_is_contr,
|
||||
all_goals (esimp; exact _)},
|
||||
{ cases k with k,
|
||||
{ apply is_equiv_trunc_functor, esimp,
|
||||
apply is_equiv.homotopy_closed, rotate 1,
|
||||
{ symmetry, exact phomotopy_pinv_right_of_phomotopy (loop_EM1_pmap _ _) },
|
||||
apply is_equiv_compose e },
|
||||
{ apply @is_equiv_of_is_contr,
|
||||
do 2 exact trivial_homotopy_group_of_is_trunc _ (succ_lt_succ !zero_lt_succ)}}
|
||||
end
|
||||
|
||||
definition EM1_pequiv.{u} {G : Group.{u}} {X : pType.{u}} (e : G ≃g π₁ X)
|
||||
[is_conn 0 X] [is_trunc 1 X] : EM1 G ≃* X :=
|
||||
begin
|
||||
apply EM1_pequiv' (pequiv_of_isomorphism e ⬝e* ptrunc_pequiv 0 (Ω X)),
|
||||
refine is_equiv.preserve_binary_of_inv_preserve _ mul concat _,
|
||||
intro p q,
|
||||
exact to_respect_mul e⁻¹ᵍ (tr p) (tr q)
|
||||
end
|
||||
|
||||
definition EM1_pequiv_type (X : Type*) [is_conn 0 X] [is_trunc 1 X] : EM1 (π₁ X) ≃* X :=
|
||||
EM1_pequiv !isomorphism.refl
|
||||
|
||||
end EM
|
||||
|
||||
open hopf susp
|
||||
namespace EM
|
||||
/- EM1 G is an h-space if G is an abelian group. This allows us to construct K(G,n) for n ≥ 2 -/
|
||||
variables {G : AbGroup} (n : ℕ)
|
||||
|
||||
definition EM1_mul [unfold 2 3] (x x' : EM1' G) : EM1' G :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact x'},
|
||||
{ induction x' using EM.set_rec,
|
||||
{ exact pth g},
|
||||
{ exact abstract begin apply loop_pathover, apply square_of_eq,
|
||||
refine !resp_mul⁻¹ ⬝ _ ⬝ !resp_mul,
|
||||
exact ap pth !mul.comm end end}},
|
||||
{ refine EM.prop_rec _ x', apply resp_mul }
|
||||
end
|
||||
|
||||
variable (G)
|
||||
definition EM1_mul_one (x : EM1' G) : EM1_mul x base = x :=
|
||||
begin
|
||||
induction x using EM.set_rec,
|
||||
{ reflexivity},
|
||||
{ apply eq_pathover_id_right, apply hdeg_square, refine EM.elim_pth _ g}
|
||||
end
|
||||
|
||||
definition h_space_EM1 [constructor] [instance] : h_space (EM1' G) :=
|
||||
begin
|
||||
fapply h_space.mk,
|
||||
{ exact EM1_mul},
|
||||
{ exact base},
|
||||
{ intro x', reflexivity},
|
||||
{ apply EM1_mul_one}
|
||||
end
|
||||
|
||||
/- K(G, n+1) -/
|
||||
definition EMadd1 : ℕ → Type*
|
||||
| 0 := EM1 G
|
||||
| (n+1) := ptrunc (n+2) (psusp (EMadd1 n))
|
||||
|
||||
definition EMadd1_succ [unfold_full] (n : ℕ) :
|
||||
EMadd1 G (succ n) = ptrunc (n.+2) (psusp (EMadd1 G n)) :=
|
||||
idp
|
||||
|
||||
definition loop_EM2 : Ω[1] (EMadd1 G 1) ≃* EM1 G :=
|
||||
hopf.delooping (EM1' G) idp
|
||||
|
||||
definition is_conn_EMadd1 [instance] (n : ℕ) : is_conn n (EMadd1 G n) :=
|
||||
begin
|
||||
induction n with n IH,
|
||||
{ apply is_conn_EM1 },
|
||||
{ rewrite EMadd1_succ, esimp, exact _ }
|
||||
end
|
||||
|
||||
definition is_trunc_EMadd1 [instance] (n : ℕ) : is_trunc (n+1) (EMadd1 G n) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ apply is_trunc_EM1 },
|
||||
{ apply is_trunc_trunc }
|
||||
end
|
||||
|
||||
/- loops of an EM-space -/
|
||||
definition loop_EMadd1 (n : ℕ) : EMadd1 G n ≃* Ω (EMadd1 G (succ n)) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ exact !loop_EM2⁻¹ᵉ* },
|
||||
{ rewrite [EMadd1_succ G (succ n)],
|
||||
refine (ptrunc_pequiv (succ n + 1) _)⁻¹ᵉ* ⬝e* _ ⬝e* (loop_ptrunc_pequiv _ _)⁻¹ᵉ*,
|
||||
have succ n + 1 ≤ 2 * succ n, from add_mul_le_mul_add n 1 1,
|
||||
refine freudenthal_pequiv _ this }
|
||||
end
|
||||
|
||||
definition loopn_EMadd1_pequiv_EM1 (G : AbGroup) (n : ℕ) : EM1 G ≃* Ω[n] (EMadd1 G n) :=
|
||||
begin
|
||||
induction n with n e,
|
||||
{ reflexivity },
|
||||
{ refine _ ⬝e* !loopn_succ_in⁻¹ᵉ*,
|
||||
refine _ ⬝e* loopn_pequiv_loopn n !loop_EMadd1,
|
||||
exact e }
|
||||
end
|
||||
|
||||
-- use loopn_EMadd1_pequiv_EM1 in this definition?
|
||||
definition loopn_EMadd1 (G : AbGroup) (n : ℕ) : G ≃* Ω[succ n] (EMadd1 G n) :=
|
||||
begin
|
||||
induction n with n e,
|
||||
{ apply loop_EM1 },
|
||||
{ refine _ ⬝e* !loopn_succ_in⁻¹ᵉ*,
|
||||
refine _ ⬝e* loopn_pequiv_loopn (succ n) !loop_EMadd1,
|
||||
exact e }
|
||||
end
|
||||
|
||||
definition loopn_EMadd1_succ [unfold_full] (G : AbGroup) (n : ℕ) : loopn_EMadd1 G (succ n) ~*
|
||||
!loopn_succ_in⁻¹ᵉ* ∘* apn (succ n) !loop_EMadd1 ∘* loopn_EMadd1 G n :=
|
||||
by reflexivity
|
||||
|
||||
definition EM_up {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ (succ n)] X ≃* G)
|
||||
: Ω[succ n] (Ω X) ≃* G :=
|
||||
!loopn_succ_in⁻¹ᵉ* ⬝e* e
|
||||
|
||||
definition is_homomorphism_EM_up {G : AbGroup} {X : Type*} {n : ℕ}
|
||||
(e : Ω[succ (succ n)] X ≃* G)
|
||||
(r : Π(p q : Ω[succ (succ n)] X), e (p ⬝ q) = e p * e q)
|
||||
(p q : Ω[succ n] (Ω X)) : EM_up e (p ⬝ q) = EM_up e p * EM_up e q :=
|
||||
begin
|
||||
refine _ ⬝ !r, apply ap e, esimp, apply apn_con
|
||||
end
|
||||
|
||||
definition EMadd1_pmap [unfold 8] {G : AbGroup} {X : Type*} (n : ℕ)
|
||||
(e : Ω[succ n] X ≃* G)
|
||||
(r : Πp q, e (p ⬝ q) = e p * e q)
|
||||
[H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n →* X :=
|
||||
begin
|
||||
revert X e r H1 H2, induction n with n f: intro X e r H1 H2,
|
||||
{ exact EM1_pmap e⁻¹ᵉ* (equiv.inv_preserve_binary e concat mul r) },
|
||||
rewrite [EMadd1_succ],
|
||||
exact ptrunc.elim ((succ n).+1)
|
||||
(psusp.elim (f _ (EM_up e) (is_homomorphism_EM_up e r) _ _)),
|
||||
end
|
||||
|
||||
definition EMadd1_pmap_succ {G : AbGroup} {X : Type*} (n : ℕ) (e : Ω[succ (succ n)] X ≃* G)
|
||||
r [H1 : is_conn (succ n) X] [H2 : is_trunc ((succ n).+1) X] : EMadd1_pmap (succ n) e r =
|
||||
ptrunc.elim ((succ n).+1) (psusp.elim (EMadd1_pmap n (EM_up e) (is_homomorphism_EM_up e r))) :=
|
||||
by reflexivity
|
||||
|
||||
definition loop_EMadd1_pmap {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ (succ n)] X ≃* G)
|
||||
(r : Πp q, e (p ⬝ q) = e p * e q)
|
||||
[H1 : is_conn (succ n) X] [H2 : is_trunc ((succ n).+1) X] :
|
||||
Ω→(EMadd1_pmap (succ n) e r) ∘* loop_EMadd1 G n ~*
|
||||
EMadd1_pmap n (EM_up e) (is_homomorphism_EM_up e r) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ apply hopf_delooping_elim },
|
||||
{ refine !passoc⁻¹* ⬝* _,
|
||||
rewrite [EMadd1_pmap_succ (succ n)],
|
||||
refine pwhisker_right _ !ap1_ptrunc_elim ⬝* _,
|
||||
refine !passoc⁻¹* ⬝* _,
|
||||
refine pwhisker_right _ (ptrunc_elim_freudenthal_pequiv
|
||||
(succ n) (succ (succ n)) (add_mul_le_mul_add n 1 1) _) ⬝* _,
|
||||
reflexivity }
|
||||
end
|
||||
|
||||
definition loopn_EMadd1_pmap' {G : AbGroup} {X : Type*} {n : ℕ} (e : Ω[succ n] X ≃* G)
|
||||
(r : Πp q, e (p ⬝ q) = e p * e q)
|
||||
[H1 : is_conn n X] [H2 : is_trunc (n.+1) X] :
|
||||
Ω→[succ n](EMadd1_pmap n e r) ∘* loopn_EMadd1 G n ~* e⁻¹ᵉ* :=
|
||||
begin
|
||||
revert X e r H1 H2, induction n with n IH: intro X e r H1 H2,
|
||||
{ apply loop_EM1_pmap },
|
||||
refine pwhisker_left _ !loopn_EMadd1_succ ⬝* _,
|
||||
refine !passoc⁻¹* ⬝* _,
|
||||
refine pwhisker_right _ !loopn_succ_in_inv_natural ⬝* _,
|
||||
refine !passoc ⬝* _,
|
||||
refine pwhisker_left _ (!passoc⁻¹* ⬝*
|
||||
pwhisker_right _ (!apn_pcompose⁻¹* ⬝* apn_phomotopy _ !loop_EMadd1_pmap) ⬝*
|
||||
!IH ⬝* !pinv_trans_pinv_left) ⬝* _,
|
||||
apply pinv_pcompose_cancel_left
|
||||
end
|
||||
|
||||
definition EMadd1_pequiv' {G : AbGroup} {X : Type*} (n : ℕ) (e : Ω[succ n] X ≃* G)
|
||||
(r : Π(p q : Ω[succ n] X), e (p ⬝ q) = e p * e q)
|
||||
[H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n ≃* X :=
|
||||
begin
|
||||
apply pequiv_of_pmap (EMadd1_pmap n e r),
|
||||
have is_conn 0 (EMadd1 G n), from is_conn_of_le _ (zero_le_of_nat n),
|
||||
have is_trunc (n.+1) (EMadd1 G n), from !is_trunc_EMadd1,
|
||||
refine whitehead_principle_pointed (n.+1) _ _,
|
||||
intro k, apply @nat.lt_by_cases k (succ n): intro H,
|
||||
{ apply @is_equiv_of_is_contr,
|
||||
do 2 exact trivial_homotopy_group_of_is_conn _ (le_of_lt_succ H)},
|
||||
{ cases H, esimp, apply is_equiv_trunc_functor, esimp,
|
||||
apply is_equiv.homotopy_closed, rotate 1,
|
||||
{ symmetry, exact phomotopy_pinv_right_of_phomotopy (loopn_EMadd1_pmap' _ _) },
|
||||
apply is_equiv_compose (e⁻¹ᵉ*)},
|
||||
{ apply @is_equiv_of_is_contr,
|
||||
do 2 exact trivial_homotopy_group_of_is_trunc _ H}
|
||||
end
|
||||
|
||||
definition EMadd1_pequiv {G : AbGroup} {X : Type*} (n : ℕ) (e : πg[n+1] X ≃g G)
|
||||
[H1 : is_conn n X] [H2 : is_trunc (n.+1) X] : EMadd1 G n ≃* X :=
|
||||
begin
|
||||
have is_set (Ω[succ n] X), from !is_set_loopn,
|
||||
apply EMadd1_pequiv' n ((ptrunc_pequiv _ _)⁻¹ᵉ* ⬝e* pequiv_of_isomorphism e),
|
||||
intro p q, esimp, exact to_respect_mul e (tr p) (tr q)
|
||||
end
|
||||
|
||||
definition EMadd1_pequiv_succ {G : AbGroup} {X : Type*} (n : ℕ) (e : πag[n+2] X ≃g G)
|
||||
[H1 : is_conn (n.+1) X] [H2 : is_trunc (n.+2) X] : EMadd1 G (succ n) ≃* X :=
|
||||
EMadd1_pequiv (succ n) e
|
||||
|
||||
definition ghomotopy_group_EMadd1 (n : ℕ) : πg[n+1] (EMadd1 G n) ≃g G :=
|
||||
begin
|
||||
change π₁ (Ω[n] (EMadd1 G n)) ≃g G,
|
||||
refine homotopy_group_isomorphism_of_pequiv 0 (loopn_EMadd1_pequiv_EM1 G n)⁻¹ᵉ* ⬝g _,
|
||||
apply fundamental_group_EM1,
|
||||
end
|
||||
|
||||
definition EMadd1_pequiv_type (X : Type*) (n : ℕ) [is_conn (n+1) X] [is_trunc (n+1+1) X]
|
||||
: EMadd1 (πag[n+2] X) (succ n) ≃* X :=
|
||||
EMadd1_pequiv_succ n !isomorphism.refl
|
||||
|
||||
/- K(G, n) -/
|
||||
definition EM (G : AbGroup) : ℕ → Type*
|
||||
| 0 := G
|
||||
| (k+1) := EMadd1 G k
|
||||
|
||||
namespace ops
|
||||
abbreviation K := @EM
|
||||
end ops
|
||||
open ops
|
||||
|
||||
definition homotopy_group_EM (n : ℕ) : π[n] (EM G n) ≃* G :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ rexact ptrunc_pequiv 0 G },
|
||||
{ exact pequiv_of_isomorphism (ghomotopy_group_EMadd1 G n)}
|
||||
end
|
||||
|
||||
definition ghomotopy_group_EM (n : ℕ) : πg[n+1] (EM G (n+1)) ≃g G :=
|
||||
ghomotopy_group_EMadd1 G n
|
||||
|
||||
definition is_conn_EM [instance] (n : ℕ) : is_conn (n.-1) (EM G n) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ apply is_conn_minus_one, apply tr, unfold [EM], exact 1},
|
||||
{ apply is_conn_EMadd1}
|
||||
end
|
||||
|
||||
definition is_conn_EM_succ [instance] (n : ℕ) : is_conn n (EM G (succ n)) :=
|
||||
is_conn_EM G (succ n)
|
||||
|
||||
definition is_trunc_EM [instance] (n : ℕ) : is_trunc n (EM G n) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ unfold [EM], apply semigroup.is_set_carrier},
|
||||
{ apply is_trunc_EMadd1}
|
||||
end
|
||||
|
||||
definition loop_EM (n : ℕ) : Ω (K G (succ n)) ≃* K G n :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ refine _ ⬝e* pequiv_of_isomorphism (fundamental_group_EM1 G),
|
||||
symmetry, apply ptrunc_pequiv },
|
||||
{ exact !loop_EMadd1⁻¹ᵉ* }
|
||||
end
|
||||
|
||||
open circle int
|
||||
definition EM_pequiv_circle : K agℤ 1 ≃* S¹* :=
|
||||
EM1_pequiv fundamental_group_of_circle⁻¹ᵍ
|
||||
|
||||
/- Functorial action of Eilenberg-Maclane spaces -/
|
||||
|
||||
definition EM1_functor [constructor] {G H : Group} (φ : G →g H) : EM1 G →* EM1 H :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro g, induction g,
|
||||
{ exact base },
|
||||
{ exact pth (φ g) },
|
||||
{ exact ap pth (to_respect_mul φ g h) ⬝ resp_mul (φ g) (φ h) }},
|
||||
{ reflexivity }
|
||||
end
|
||||
|
||||
definition EMadd1_functor [constructor] {G H : AbGroup} (φ : G →g H) (n : ℕ) :
|
||||
EMadd1 G n →* EMadd1 H n :=
|
||||
begin
|
||||
induction n with n ψ,
|
||||
{ exact EM1_functor φ },
|
||||
{ apply ptrunc_functor, apply psusp_functor, exact ψ }
|
||||
end
|
||||
|
||||
definition EM_functor [unfold 4] {G H : AbGroup} (φ : G →g H) (n : ℕ) :
|
||||
K G n →* K H n :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ exact pmap_of_homomorphism φ },
|
||||
{ exact EMadd1_functor φ n }
|
||||
end
|
||||
|
||||
-- TODO: (K G n →* K H n) ≃ (G →g H)
|
||||
|
||||
/- Equivalence of Groups and pointed connected 1-truncated types -/
|
||||
|
||||
definition ptruncconntype10_pequiv (X Y : 1-Type*[0]) (e : π₁ X ≃g π₁ Y) : X ≃* Y :=
|
||||
(EM1_pequiv !isomorphism.refl)⁻¹ᵉ* ⬝e* EM1_pequiv e
|
||||
|
||||
definition EM1_pequiv_ptruncconntype10 (X : 1-Type*[0]) : EM1 (π₁ X) ≃* X :=
|
||||
EM1_pequiv_type X
|
||||
|
||||
definition Group_equiv_ptruncconntype10 [constructor] : Group ≃ 1-Type*[0] :=
|
||||
equiv.MK (λG, ptruncconntype.mk (EM1 G) _ pt !is_conn_EM1)
|
||||
(λX, π₁ X)
|
||||
begin intro X, apply ptruncconntype_eq, esimp, exact EM1_pequiv_type X end
|
||||
begin intro G, apply eq_of_isomorphism, apply fundamental_group_EM1 end
|
||||
|
||||
/- Equivalence of AbGroups and pointed n-connected (n+1)-truncated types (n ≥ 1) -/
|
||||
|
||||
open trunc_index
|
||||
definition ptruncconntype_pequiv : Π(n : ℕ) (X Y : (n.+1)-Type*[n])
|
||||
(e : πg[n+1] X ≃g πg[n+1] Y), X ≃* Y
|
||||
| 0 X Y e := ptruncconntype10_pequiv X Y e
|
||||
| (succ n) X Y e :=
|
||||
begin
|
||||
refine (EMadd1_pequiv_succ n _)⁻¹ᵉ* ⬝e* EMadd1_pequiv_succ n !isomorphism.refl,
|
||||
exact e
|
||||
end
|
||||
|
||||
definition EM1_pequiv_ptruncconntype (n : ℕ) (X : (n+1+1)-Type*[n+1]) :
|
||||
EMadd1 (πag[n+2] X) (succ n) ≃* X :=
|
||||
EMadd1_pequiv_type X n
|
||||
|
||||
definition AbGroup_equiv_ptruncconntype' [constructor] (n : ℕ) :
|
||||
AbGroup ≃ (n + 1 + 1)-Type*[n+1] :=
|
||||
equiv.MK
|
||||
(λG, ptruncconntype.mk (EMadd1 G (n+1)) _ pt _)
|
||||
(λX, πag[n+2] X)
|
||||
begin intro X, apply ptruncconntype_eq, apply EMadd1_pequiv_type end
|
||||
begin intro G, apply AbGroup_eq_of_isomorphism, exact ghomotopy_group_EMadd1 G (n+1) end
|
||||
|
||||
definition AbGroup_equiv_ptruncconntype [constructor] (n : ℕ) :
|
||||
AbGroup ≃ (n.+2)-Type*[n.+1] :=
|
||||
AbGroup_equiv_ptruncconntype' n
|
||||
|
||||
end EM
|
||||
|
|
@ -1,817 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
||||
We define the fiber sequence of a pointed map f : X →* Y. We mostly follow the proof in section 8.4
|
||||
of the book.
|
||||
|
||||
PART 1:
|
||||
We define a sequence fiber_sequence as in Definition 8.4.3.
|
||||
It has types X(n) : Type*
|
||||
X(0) := Y,
|
||||
X(1) := X,
|
||||
X(n+1) := fiber (f(n))
|
||||
with functions f(n) : X(n+1) →* X(n)
|
||||
f(0) := f
|
||||
f(n+1) := point (f(n)) [this is the first projection]
|
||||
We prove that this is an exact sequence.
|
||||
Then we prove Lemma 8.4.3, by showing that X(n+3) ≃* Ω(X(n)) and that this equivalence sends
|
||||
the pointed map f(n+3) to -Ω(f(n)), i.e. the composition of Ω(f(n)) with path inversion.
|
||||
Using this equivalence we get a boundary_map : Ω(Y) → pfiber f.
|
||||
|
||||
PART 2:
|
||||
Now we can define a new fiber sequence X'(n) : Type*, and here we slightly diverge from the book.
|
||||
We define it as
|
||||
X'(0) := Y,
|
||||
X'(1) := X,
|
||||
X'(2) := fiber f
|
||||
X'(n+3) := Ω(X'(n))
|
||||
with maps f'(n) : X'(n+1) →* X'(n)
|
||||
f'(0) := f
|
||||
f'(1) := point f
|
||||
f'(2) := boundary_map
|
||||
f'(n+3) := Ω(f'(n))
|
||||
|
||||
This sequence is not equivalent to the previous sequence. The difference is in the signs.
|
||||
The sequence f has negative signs (i.e. is composed with the inverse maps) for n ≡ 3, 4, 5 mod 6.
|
||||
This sign information is captured by e : X'(n) ≃* X'(n) such that
|
||||
e(k) := 1 for k = 0,1,2,3
|
||||
e(k+3) := Ω(e(k)) ∘ (-)⁻¹ for k > 0
|
||||
|
||||
Now the sequence (X', f' ∘ e) is equivalent to (X, f), Hence (X', f' ∘ e) is an exact sequence.
|
||||
We then prove that (X', f') is an exact sequence by using that there are other equivalences
|
||||
eₗ and eᵣ such that
|
||||
f' = eᵣ ∘ f' ∘ e
|
||||
f' ∘ eₗ = e ∘ f'.
|
||||
(this fact is type_chain_complex_cancel_aut and is_exact_at_t_cancel_aut in the file chain_complex)
|
||||
eₗ and eᵣ are almost the same as e, except that the places where the inverse is taken is
|
||||
slightly shifted:
|
||||
eᵣ = (-)⁻¹ for n ≡ 3, 4, 5 mod 6 and eᵣ = 1 otherwise
|
||||
e = (-)⁻¹ for n ≡ 4, 5, 6 mod 6 (except for n = 0) and e = 1 otherwise
|
||||
eₗ = (-)⁻¹ for n ≡ 5, 6, 7 mod 6 (except for n = 0, 1) and eₗ = 1 otherwise
|
||||
|
||||
PART 3:
|
||||
We change the type over which the sequence of types and maps are indexed from ℕ to ℕ × 3
|
||||
(where 3 is the finite type with 3 elements). The reason is that we have that X'(3n) = Ωⁿ(Y), but
|
||||
this equality is not definitionally true. Hence we cannot even state whether f'(3n) = Ωⁿ(f) without
|
||||
using transports. This gets ugly. However, if we use as index type ℕ × 3, we can do this. We can
|
||||
define
|
||||
Y : ℕ × 3 → Type* as
|
||||
Y(n, 0) := Ωⁿ(Y)
|
||||
Y(n, 1) := Ωⁿ(X)
|
||||
Y(n, 2) := Ωⁿ(fiber f)
|
||||
with maps g(n) : Y(S n) →* Y(n) (where the successor is defined in the obvious way)
|
||||
g(n, 0) := Ωⁿ(f)
|
||||
g(n, 1) := Ωⁿ(point f)
|
||||
g(n, 2) := Ωⁿ(boundary_map) ∘ cast
|
||||
|
||||
Here "cast" is the transport over the equality Ωⁿ⁺¹(Y) = Ωⁿ(Ω(Y)). We show that the sequence
|
||||
(ℕ, X', f') is equivalent to (ℕ × 3, Y, g).
|
||||
|
||||
PART 4:
|
||||
We get the long exact sequence of homotopy groups by taking the set-truncation of (Y, g).
|
||||
-/
|
||||
|
||||
import .chain_complex algebra.homotopy_group eq2
|
||||
|
||||
open eq pointed sigma fiber equiv is_equiv sigma.ops is_trunc nat trunc algebra function sum
|
||||
/--------------
|
||||
PART 1
|
||||
--------------/
|
||||
|
||||
namespace chain_complex
|
||||
|
||||
definition fiber_sequence_helper [constructor] (v : Σ(X Y : Type*), X →* Y)
|
||||
: Σ(Z X : Type*), Z →* X :=
|
||||
⟨pfiber v.2.2, v.1, ppoint v.2.2⟩
|
||||
|
||||
definition fiber_sequence_helpern (v : Σ(X Y : Type*), X →* Y) (n : ℕ)
|
||||
: Σ(Z X : Type*), Z →* X :=
|
||||
iterate fiber_sequence_helper n v
|
||||
|
||||
section
|
||||
universe variable u
|
||||
parameters {X Y : pType.{u}} (f : X →* Y)
|
||||
include f
|
||||
|
||||
definition fiber_sequence_carrier (n : ℕ) : Type* :=
|
||||
(fiber_sequence_helpern ⟨X, Y, f⟩ n).2.1
|
||||
|
||||
definition fiber_sequence_fun (n : ℕ)
|
||||
: fiber_sequence_carrier (n + 1) →* fiber_sequence_carrier n :=
|
||||
(fiber_sequence_helpern ⟨X, Y, f⟩ n).2.2
|
||||
|
||||
/- Definition 8.4.3 -/
|
||||
definition fiber_sequence : type_chain_complex.{0 u} +ℕ :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ exact fiber_sequence_carrier},
|
||||
{ exact fiber_sequence_fun},
|
||||
{ intro n x, cases n with n,
|
||||
{ exact point_eq x},
|
||||
{ exact point_eq x}}
|
||||
end
|
||||
|
||||
definition is_exact_fiber_sequence : is_exact_t fiber_sequence :=
|
||||
λn x p, fiber.mk (fiber.mk x p) rfl
|
||||
|
||||
/- (generalization of) Lemma 8.4.4(i)(ii) -/
|
||||
definition fiber_sequence_carrier_equiv (n : ℕ)
|
||||
: fiber_sequence_carrier (n+3) ≃ Ω(fiber_sequence_carrier n) :=
|
||||
calc
|
||||
fiber_sequence_carrier (n+3) ≃ fiber (fiber_sequence_fun (n+1)) pt : erfl
|
||||
... ≃ Σ(x : fiber_sequence_carrier _), fiber_sequence_fun (n+1) x = pt
|
||||
: fiber.sigma_char
|
||||
... ≃ Σ(x : fiber (fiber_sequence_fun n) pt), fiber_sequence_fun _ x = pt
|
||||
: erfl
|
||||
... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), fiber_sequence_fun _ x = pt),
|
||||
fiber_sequence_fun _ (fiber.mk v.1 v.2) = pt
|
||||
: by exact sigma_equiv_sigma !fiber.sigma_char (λa, erfl)
|
||||
... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), fiber_sequence_fun _ x = pt),
|
||||
v.1 = pt
|
||||
: erfl
|
||||
... ≃ Σ(v : Σ(x : fiber_sequence_carrier _), x = pt),
|
||||
fiber_sequence_fun _ v.1 = pt
|
||||
: sigma_assoc_comm_equiv
|
||||
... ≃ fiber_sequence_fun _ !center.1 = pt
|
||||
: @(sigma_equiv_of_is_contr_left _) !is_contr_sigma_eq'
|
||||
... ≃ fiber_sequence_fun _ pt = pt
|
||||
: erfl
|
||||
... ≃ pt = pt
|
||||
: by exact !equiv_eq_closed_left !respect_pt
|
||||
... ≃ Ω(fiber_sequence_carrier n) : erfl
|
||||
|
||||
/- computation rule -/
|
||||
definition fiber_sequence_carrier_equiv_eq (n : ℕ)
|
||||
(x : fiber_sequence_carrier (n+1)) (p : fiber_sequence_fun n x = pt)
|
||||
(q : fiber_sequence_fun (n+1) (fiber.mk x p) = pt)
|
||||
: fiber_sequence_carrier_equiv n (fiber.mk (fiber.mk x p) q)
|
||||
= !respect_pt⁻¹ ⬝ ap (fiber_sequence_fun n) q⁻¹ ⬝ p :=
|
||||
begin
|
||||
refine _ ⬝ !con.assoc⁻¹,
|
||||
apply whisker_left,
|
||||
refine eq_transport_Fl _ _ ⬝ _,
|
||||
apply whisker_right,
|
||||
refine inverse2 !ap_inv ⬝ !inv_inv ⬝ _,
|
||||
refine ap_compose (fiber_sequence_fun n) pr₁ _ ⬝
|
||||
ap02 (fiber_sequence_fun n) !ap_pr1_center_eq_sigma_eq',
|
||||
end
|
||||
|
||||
definition fiber_sequence_carrier_equiv_inv_eq (n : ℕ)
|
||||
(p : Ω(fiber_sequence_carrier n)) : (fiber_sequence_carrier_equiv n)⁻¹ᵉ p =
|
||||
fiber.mk (fiber.mk pt (respect_pt (fiber_sequence_fun n) ⬝ p)) idp :=
|
||||
begin
|
||||
apply inv_eq_of_eq,
|
||||
refine _ ⬝ !fiber_sequence_carrier_equiv_eq⁻¹, esimp,
|
||||
exact !inv_con_cancel_left⁻¹
|
||||
end
|
||||
|
||||
definition fiber_sequence_carrier_pequiv (n : ℕ)
|
||||
: fiber_sequence_carrier (n+3) ≃* Ω(fiber_sequence_carrier n) :=
|
||||
pequiv_of_equiv (fiber_sequence_carrier_equiv n)
|
||||
begin
|
||||
esimp,
|
||||
apply con.left_inv
|
||||
end
|
||||
|
||||
definition fiber_sequence_carrier_pequiv_eq (n : ℕ)
|
||||
(x : fiber_sequence_carrier (n+1)) (p : fiber_sequence_fun n x = pt)
|
||||
(q : fiber_sequence_fun (n+1) (fiber.mk x p) = pt)
|
||||
: fiber_sequence_carrier_pequiv n (fiber.mk (fiber.mk x p) q)
|
||||
= !respect_pt⁻¹ ⬝ ap (fiber_sequence_fun n) q⁻¹ ⬝ p :=
|
||||
fiber_sequence_carrier_equiv_eq n x p q
|
||||
|
||||
definition fiber_sequence_carrier_pequiv_inv_eq (n : ℕ)
|
||||
(p : Ω(fiber_sequence_carrier n)) : (fiber_sequence_carrier_pequiv n)⁻¹ᵉ* p =
|
||||
fiber.mk (fiber.mk pt (respect_pt (fiber_sequence_fun n) ⬝ p)) idp :=
|
||||
by rexact fiber_sequence_carrier_equiv_inv_eq n p
|
||||
|
||||
/- Lemma 8.4.4(iii) -/
|
||||
definition fiber_sequence_fun_eq_helper (n : ℕ)
|
||||
(p : Ω(fiber_sequence_carrier (n + 1))) :
|
||||
fiber_sequence_carrier_pequiv n
|
||||
(fiber_sequence_fun (n + 3)
|
||||
((fiber_sequence_carrier_pequiv (n + 1))⁻¹ᵉ* p)) =
|
||||
ap1 (fiber_sequence_fun n) p⁻¹ :=
|
||||
begin
|
||||
refine ap (λx, fiber_sequence_carrier_pequiv n (fiber_sequence_fun (n + 3) x))
|
||||
(fiber_sequence_carrier_pequiv_inv_eq (n+1) p) ⬝ _,
|
||||
/- the following three lines are rewriting some reflexivities: -/
|
||||
-- replace (n + 3) with (n + 2 + 1),
|
||||
-- refine ap (fiber_sequence_carrier_pequiv n)
|
||||
-- (fiber_sequence_fun_eq1 (n+2) _ idp) ⬝ _,
|
||||
refine fiber_sequence_carrier_pequiv_eq n pt (respect_pt (fiber_sequence_fun n)) _ ⬝ _,
|
||||
esimp,
|
||||
apply whisker_right,
|
||||
apply whisker_left,
|
||||
apply ap02, apply inverse2, apply idp_con,
|
||||
end
|
||||
|
||||
theorem fiber_sequence_carrier_pequiv_eq_point_eq_idp (n : ℕ) :
|
||||
fiber_sequence_carrier_pequiv_eq n
|
||||
(Point (fiber_sequence_carrier (n+1)))
|
||||
(respect_pt (fiber_sequence_fun n))
|
||||
(respect_pt (fiber_sequence_fun (n + 1))) = idp :=
|
||||
begin
|
||||
apply con_inv_eq_idp,
|
||||
refine ap (λx, whisker_left _ (_ ⬝ x)) _ ⬝ _,
|
||||
{ reflexivity},
|
||||
{ reflexivity},
|
||||
refine ap (whisker_left _)
|
||||
(eq_transport_Fl_idp_left (fiber_sequence_fun n)
|
||||
(respect_pt (fiber_sequence_fun n))) ⬝ _,
|
||||
apply whisker_left_idp_con_eq_assoc
|
||||
end
|
||||
|
||||
theorem fiber_sequence_fun_phomotopy_helper (n : ℕ) :
|
||||
(fiber_sequence_carrier_pequiv n ∘*
|
||||
fiber_sequence_fun (n + 3)) ∘*
|
||||
(fiber_sequence_carrier_pequiv (n + 1))⁻¹ᵉ* ~*
|
||||
ap1 (fiber_sequence_fun n) ∘* pinverse :=
|
||||
begin
|
||||
fapply phomotopy.mk,
|
||||
{ exact chain_complex.fiber_sequence_fun_eq_helper f n},
|
||||
{ esimp, rewrite [idp_con], refine _ ⬝ whisker_left _ !idp_con⁻¹,
|
||||
apply whisker_right,
|
||||
apply whisker_left,
|
||||
exact chain_complex.fiber_sequence_carrier_pequiv_eq_point_eq_idp f n}
|
||||
end
|
||||
|
||||
theorem fiber_sequence_fun_eq (n : ℕ) : Π(x : fiber_sequence_carrier (n + 4)),
|
||||
fiber_sequence_carrier_pequiv n (fiber_sequence_fun (n + 3) x) =
|
||||
ap1 (fiber_sequence_fun n) (fiber_sequence_carrier_pequiv (n + 1) x)⁻¹ :=
|
||||
begin
|
||||
apply homotopy_of_inv_homotopy_pre (fiber_sequence_carrier_pequiv (n + 1)),
|
||||
apply fiber_sequence_fun_eq_helper n
|
||||
end
|
||||
|
||||
theorem fiber_sequence_fun_phomotopy (n : ℕ) :
|
||||
fiber_sequence_carrier_pequiv n ∘*
|
||||
fiber_sequence_fun (n + 3) ~*
|
||||
(ap1 (fiber_sequence_fun n) ∘* pinverse) ∘* fiber_sequence_carrier_pequiv (n + 1) :=
|
||||
begin
|
||||
apply phomotopy_of_pinv_right_phomotopy,
|
||||
apply fiber_sequence_fun_phomotopy_helper
|
||||
end
|
||||
|
||||
definition boundary_map : Ω Y →* pfiber f :=
|
||||
fiber_sequence_fun 2 ∘* (fiber_sequence_carrier_pequiv 0)⁻¹ᵉ*
|
||||
|
||||
/--------------
|
||||
PART 2
|
||||
--------------/
|
||||
|
||||
/- Now we are ready to define the long exact sequence of homotopy groups.
|
||||
First we define its carrier -/
|
||||
definition loop_spaces : ℕ → Type*
|
||||
| 0 := Y
|
||||
| 1 := X
|
||||
| 2 := pfiber f
|
||||
| (k+3) := Ω (loop_spaces k)
|
||||
|
||||
/- The maps between the homotopy groups -/
|
||||
definition loop_spaces_fun
|
||||
: Π(n : ℕ), loop_spaces (n+1) →* loop_spaces n
|
||||
| 0 := proof f qed
|
||||
| 1 := proof ppoint f qed
|
||||
| 2 := proof boundary_map qed
|
||||
| (k+3) := proof ap1 (loop_spaces_fun k) qed
|
||||
|
||||
definition loop_spaces_fun_add3 [unfold_full] (n : ℕ) :
|
||||
loop_spaces_fun (n + 3) = ap1 (loop_spaces_fun n) :=
|
||||
proof idp qed
|
||||
|
||||
definition fiber_sequence_pequiv_loop_spaces :
|
||||
Πn, fiber_sequence_carrier n ≃* loop_spaces n
|
||||
| 0 := by reflexivity
|
||||
| 1 := by reflexivity
|
||||
| 2 := by reflexivity
|
||||
| (k+3) :=
|
||||
begin
|
||||
refine fiber_sequence_carrier_pequiv k ⬝e* _,
|
||||
apply loop_pequiv_loop,
|
||||
exact fiber_sequence_pequiv_loop_spaces k
|
||||
end
|
||||
|
||||
definition fiber_sequence_pequiv_loop_spaces_add3 (n : ℕ)
|
||||
: fiber_sequence_pequiv_loop_spaces (n + 3) =
|
||||
ap1 (fiber_sequence_pequiv_loop_spaces n) ∘* fiber_sequence_carrier_pequiv n :=
|
||||
by reflexivity
|
||||
|
||||
definition fiber_sequence_pequiv_loop_spaces_3_phomotopy
|
||||
: fiber_sequence_pequiv_loop_spaces 3 ~* proof fiber_sequence_carrier_pequiv nat.zero qed :=
|
||||
begin
|
||||
refine pwhisker_right _ ap1_pid ⬝* _,
|
||||
apply pid_pcompose
|
||||
end
|
||||
|
||||
definition pid_or_pinverse : Π(n : ℕ), loop_spaces n ≃* loop_spaces n
|
||||
| 0 := pequiv.rfl
|
||||
| 1 := pequiv.rfl
|
||||
| 2 := pequiv.rfl
|
||||
| 3 := pequiv.rfl
|
||||
| (k+4) := !pequiv_pinverse ⬝e* loop_pequiv_loop (pid_or_pinverse (k+1))
|
||||
|
||||
definition pid_or_pinverse_add4 (n : ℕ)
|
||||
: pid_or_pinverse (n + 4) = !pequiv_pinverse ⬝e* loop_pequiv_loop (pid_or_pinverse (n + 1)) :=
|
||||
by reflexivity
|
||||
|
||||
definition pid_or_pinverse_add4_rev : Π(n : ℕ),
|
||||
pid_or_pinverse (n + 4) ~* pinverse ∘* Ω→(pid_or_pinverse (n + 1))
|
||||
| 0 := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
|
||||
replace pid_or_pinverse (0 + 1) with pequiv.refl X,
|
||||
refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
|
||||
exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
|
||||
| 1 := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
|
||||
replace pid_or_pinverse (1 + 1) with pequiv.refl (pfiber f),
|
||||
refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
|
||||
exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
|
||||
| 2 := begin rewrite [pid_or_pinverse_add4, + to_pmap_pequiv_trans],
|
||||
replace pid_or_pinverse (2 + 1) with pequiv.refl (Ω Y),
|
||||
refine pwhisker_right _ !loop_pequiv_loop_rfl ⬝* _, refine !pid_pcompose ⬝* _,
|
||||
exact !pcompose_pid⁻¹* ⬝* pwhisker_left _ !ap1_pid⁻¹* end
|
||||
| (k+3) :=
|
||||
begin
|
||||
replace (k + 3 + 1) with (k + 4),
|
||||
rewrite [+ pid_or_pinverse_add4, + to_pmap_pequiv_trans],
|
||||
refine _ ⬝* pwhisker_left _ !ap1_pcompose⁻¹*,
|
||||
refine _ ⬝* !passoc,
|
||||
apply pconcat2,
|
||||
{ refine ap1_phomotopy (pid_or_pinverse_add4_rev k) ⬝* _,
|
||||
refine !ap1_pcompose ⬝* _, apply pwhisker_right, apply ap1_pinverse},
|
||||
{ refine !ap1_pinverse⁻¹*}
|
||||
end
|
||||
|
||||
theorem fiber_sequence_phomotopy_loop_spaces : Π(n : ℕ),
|
||||
fiber_sequence_pequiv_loop_spaces n ∘* fiber_sequence_fun n ~*
|
||||
(loop_spaces_fun n ∘* pid_or_pinverse (n + 1)) ∘* fiber_sequence_pequiv_loop_spaces (n + 1)
|
||||
| 0 := proof proof phomotopy.rfl qed ⬝* pwhisker_right _ !pcompose_pid⁻¹* qed
|
||||
| 1 := by reflexivity
|
||||
| 2 :=
|
||||
begin
|
||||
refine !pid_pcompose ⬝* _,
|
||||
replace loop_spaces_fun 2 with boundary_map,
|
||||
refine _ ⬝* pwhisker_left _ fiber_sequence_pequiv_loop_spaces_3_phomotopy⁻¹*,
|
||||
apply phomotopy_of_pinv_right_phomotopy,
|
||||
exact !pid_pcompose⁻¹*
|
||||
end
|
||||
| (k+3) :=
|
||||
begin
|
||||
replace (k + 3 + 1) with (k + 1 + 3),
|
||||
rewrite [fiber_sequence_pequiv_loop_spaces_add3 k,
|
||||
fiber_sequence_pequiv_loop_spaces_add3 (k+1)],
|
||||
refine !passoc ⬝* _,
|
||||
refine pwhisker_left _ (fiber_sequence_fun_phomotopy k) ⬝* _,
|
||||
refine !passoc⁻¹* ⬝* _ ⬝* !passoc,
|
||||
apply pwhisker_right,
|
||||
replace (k + 1 + 3) with (k + 4),
|
||||
xrewrite [loop_spaces_fun_add3, pid_or_pinverse_add4, to_pmap_pequiv_trans],
|
||||
refine _ ⬝* !passoc⁻¹*,
|
||||
refine _ ⬝* pwhisker_left _ !passoc⁻¹*,
|
||||
refine _ ⬝* pwhisker_left _ (pwhisker_left _ !ap1_pcompose_pinverse),
|
||||
refine !passoc⁻¹* ⬝* _ ⬝* !passoc ⬝* !passoc,
|
||||
apply pwhisker_right,
|
||||
refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose ⬝* pwhisker_right _ !ap1_pcompose,
|
||||
apply ap1_phomotopy,
|
||||
exact fiber_sequence_phomotopy_loop_spaces k
|
||||
end
|
||||
|
||||
definition pid_or_pinverse_right : Π(n : ℕ), loop_spaces n →* loop_spaces n
|
||||
| 0 := !pid
|
||||
| 1 := !pid
|
||||
| 2 := !pid
|
||||
| (k+3) := Ω→(pid_or_pinverse_right k) ∘* pinverse
|
||||
|
||||
definition pid_or_pinverse_left : Π(n : ℕ), loop_spaces n →* loop_spaces n
|
||||
| 0 := pequiv.rfl
|
||||
| 1 := pequiv.rfl
|
||||
| 2 := pequiv.rfl
|
||||
| 3 := pequiv.rfl
|
||||
| 4 := pequiv.rfl
|
||||
| (k+5) := Ω→(pid_or_pinverse_left (k+2)) ∘* pinverse
|
||||
|
||||
definition pid_or_pinverse_right_add3 (n : ℕ)
|
||||
: pid_or_pinverse_right (n + 3) = Ω→(pid_or_pinverse_right n) ∘* pinverse :=
|
||||
by reflexivity
|
||||
|
||||
definition pid_or_pinverse_left_add5 (n : ℕ)
|
||||
: pid_or_pinverse_left (n + 5) = Ω→(pid_or_pinverse_left (n+2)) ∘* pinverse :=
|
||||
by reflexivity
|
||||
|
||||
theorem pid_or_pinverse_commute_right : Π(n : ℕ),
|
||||
loop_spaces_fun n ~* pid_or_pinverse_right n ∘* loop_spaces_fun n ∘* pid_or_pinverse (n + 1)
|
||||
| 0 := proof !pcompose_pid⁻¹* ⬝* !pid_pcompose⁻¹* qed
|
||||
| 1 := proof !pcompose_pid⁻¹* ⬝* !pid_pcompose⁻¹* qed
|
||||
| 2 := proof !pcompose_pid⁻¹* ⬝* !pid_pcompose⁻¹* qed
|
||||
| (k+3) :=
|
||||
begin
|
||||
replace (k + 3 + 1) with (k + 4),
|
||||
rewrite [pid_or_pinverse_right_add3, loop_spaces_fun_add3],
|
||||
refine _ ⬝* pwhisker_left _ (pwhisker_left _ !pid_or_pinverse_add4_rev⁻¹*),
|
||||
refine ap1_phomotopy (pid_or_pinverse_commute_right k) ⬝* _,
|
||||
refine !ap1_pcompose ⬝* _ ⬝* !passoc⁻¹*,
|
||||
apply pwhisker_left,
|
||||
refine !ap1_pcompose ⬝* _ ⬝* !passoc ⬝* !passoc,
|
||||
apply pwhisker_right,
|
||||
refine _ ⬝* pwhisker_right _ !ap1_pcompose_pinverse,
|
||||
refine _ ⬝* !passoc⁻¹*,
|
||||
refine !pcompose_pid⁻¹* ⬝* pwhisker_left _ _,
|
||||
symmetry, apply pinverse_pinverse
|
||||
end
|
||||
|
||||
theorem pid_or_pinverse_commute_left : Π(n : ℕ),
|
||||
loop_spaces_fun n ∘* pid_or_pinverse_left (n + 1) ~* pid_or_pinverse n ∘* loop_spaces_fun n
|
||||
| 0 := proof !pcompose_pid ⬝* !pid_pcompose⁻¹* qed
|
||||
| 1 := proof !pcompose_pid ⬝* !pid_pcompose⁻¹* qed
|
||||
| 2 := proof !pcompose_pid ⬝* !pid_pcompose⁻¹* qed
|
||||
| 3 := proof !pcompose_pid ⬝* !pid_pcompose⁻¹* qed
|
||||
| (k+4) :=
|
||||
begin
|
||||
replace (k + 4 + 1) with (k + 5),
|
||||
rewrite [pid_or_pinverse_left_add5, pid_or_pinverse_add4, to_pmap_pequiv_trans],
|
||||
replace (k + 4) with (k + 1 + 3),
|
||||
rewrite [loop_spaces_fun_add3],
|
||||
refine !passoc⁻¹* ⬝* _ ⬝* !passoc⁻¹*,
|
||||
refine _ ⬝* pwhisker_left _ !ap1_pcompose_pinverse,
|
||||
refine _ ⬝* !passoc,
|
||||
apply pwhisker_right,
|
||||
refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose,
|
||||
exact ap1_phomotopy (pid_or_pinverse_commute_left (k+1))
|
||||
end
|
||||
|
||||
definition LES_of_loop_spaces' [constructor] : type_chain_complex +ℕ :=
|
||||
transfer_type_chain_complex
|
||||
fiber_sequence
|
||||
(λn, loop_spaces_fun n ∘* pid_or_pinverse (n + 1))
|
||||
fiber_sequence_pequiv_loop_spaces
|
||||
fiber_sequence_phomotopy_loop_spaces
|
||||
|
||||
definition LES_of_loop_spaces [constructor] : type_chain_complex +ℕ :=
|
||||
type_chain_complex_cancel_aut
|
||||
LES_of_loop_spaces'
|
||||
loop_spaces_fun
|
||||
pid_or_pinverse
|
||||
pid_or_pinverse_right
|
||||
(λn x, idp)
|
||||
pid_or_pinverse_commute_right
|
||||
|
||||
definition is_exact_LES_of_loop_spaces : is_exact_t LES_of_loop_spaces :=
|
||||
begin
|
||||
intro n,
|
||||
refine is_exact_at_t_cancel_aut n pid_or_pinverse_left _ _ pid_or_pinverse_commute_left _,
|
||||
apply is_exact_at_t_transfer,
|
||||
apply is_exact_fiber_sequence
|
||||
end
|
||||
|
||||
open prod succ_str fin
|
||||
|
||||
/--------------
|
||||
PART 3
|
||||
--------------/
|
||||
|
||||
definition loop_spaces2 [reducible] : +3ℕ → Type*
|
||||
| (n, fin.mk 0 H) := Ω[n] Y
|
||||
| (n, fin.mk 1 H) := Ω[n] X
|
||||
| (n, fin.mk k H) := Ω[n] (pfiber f)
|
||||
|
||||
definition loop_spaces2_add1 (n : ℕ) : Π(x : fin 3),
|
||||
loop_spaces2 (n+1, x) = Ω (loop_spaces2 (n, x))
|
||||
| (fin.mk 0 H) := by reflexivity
|
||||
| (fin.mk 1 H) := by reflexivity
|
||||
| (fin.mk 2 H) := by reflexivity
|
||||
| (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition loop_spaces_fun2 : Π(n : +3ℕ), loop_spaces2 (S n) →* loop_spaces2 n
|
||||
| (n, fin.mk 0 H) := proof Ω→[n] f qed
|
||||
| (n, fin.mk 1 H) := proof Ω→[n] (ppoint f) qed
|
||||
| (n, fin.mk 2 H) := proof Ω→[n] boundary_map ∘* loopn_succ_in Y n qed
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition loop_spaces_fun2_add1_0 (n : ℕ) (H : 0 < succ 2)
|
||||
: loop_spaces_fun2 (n+1, fin.mk 0 H) ~*
|
||||
cast proof idp qed ap1 (loop_spaces_fun2 (n, fin.mk 0 H)) :=
|
||||
by reflexivity
|
||||
|
||||
definition loop_spaces_fun2_add1_1 (n : ℕ) (H : 1 < succ 2)
|
||||
: loop_spaces_fun2 (n+1, fin.mk 1 H) ~*
|
||||
cast proof idp qed ap1 (loop_spaces_fun2 (n, fin.mk 1 H)) :=
|
||||
by reflexivity
|
||||
|
||||
definition loop_spaces_fun2_add1_2 (n : ℕ) (H : 2 < succ 2)
|
||||
: loop_spaces_fun2 (n+1, fin.mk 2 H) ~*
|
||||
cast proof idp qed ap1 (loop_spaces_fun2 (n, fin.mk 2 H)) :=
|
||||
proof !ap1_pcompose⁻¹* qed
|
||||
|
||||
definition nat_of_str [unfold 2] [reducible] {n : ℕ} : ℕ × fin (succ n) → ℕ :=
|
||||
λx, succ n * pr1 x + val (pr2 x)
|
||||
|
||||
definition str_of_nat {n : ℕ} : ℕ → ℕ × fin (succ n) :=
|
||||
λm, (m / (succ n), mk_mod n m)
|
||||
|
||||
definition nat_of_str_3S [unfold 2] [reducible]
|
||||
: Π(x : stratified +ℕ 2), nat_of_str x + 1 = nat_of_str (@S (stratified +ℕ 2) x)
|
||||
| (n, fin.mk 0 H) := by reflexivity
|
||||
| (n, fin.mk 1 H) := by reflexivity
|
||||
| (n, fin.mk 2 H) := by reflexivity
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition fin_prod_nat_equiv_nat [constructor] (n : ℕ) : ℕ × fin (succ n) ≃ ℕ :=
|
||||
equiv.MK nat_of_str str_of_nat
|
||||
abstract begin
|
||||
intro m, unfold [nat_of_str, str_of_nat, mk_mod],
|
||||
refine _ ⬝ (eq_div_mul_add_mod m (succ n))⁻¹,
|
||||
rewrite [mul.comm]
|
||||
end end
|
||||
abstract begin
|
||||
intro x, cases x with m k,
|
||||
cases k with k H,
|
||||
apply prod_eq: esimp [str_of_nat],
|
||||
{ rewrite [add.comm, add_mul_div_self_left _ _ (!zero_lt_succ), ▸*,
|
||||
div_eq_zero_of_lt H, zero_add]},
|
||||
{ apply eq_of_veq, esimp [mk_mod],
|
||||
rewrite [add.comm, add_mul_mod_self_left, ▸*, mod_eq_of_lt H]}
|
||||
end end
|
||||
|
||||
/-
|
||||
note: in the following theorem the (n+1) case is 3 times the same,
|
||||
so maybe this can be simplified
|
||||
-/
|
||||
definition loop_spaces2_pequiv' : Π(n : ℕ) (x : fin (nat.succ 2)),
|
||||
loop_spaces (nat_of_str (n, x)) ≃* loop_spaces2 (n, x)
|
||||
| 0 (fin.mk 0 H) := by reflexivity
|
||||
| 0 (fin.mk 1 H) := by reflexivity
|
||||
| 0 (fin.mk 2 H) := by reflexivity
|
||||
| (n+1) (fin.mk 0 H) :=
|
||||
begin
|
||||
apply loop_pequiv_loop,
|
||||
rexact loop_spaces2_pequiv' n (fin.mk 0 H)
|
||||
end
|
||||
| (n+1) (fin.mk 1 H) :=
|
||||
begin
|
||||
apply loop_pequiv_loop,
|
||||
rexact loop_spaces2_pequiv' n (fin.mk 1 H)
|
||||
end
|
||||
| (n+1) (fin.mk 2 H) :=
|
||||
begin
|
||||
apply loop_pequiv_loop,
|
||||
rexact loop_spaces2_pequiv' n (fin.mk 2 H)
|
||||
end
|
||||
| n (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition loop_spaces2_pequiv : Π(x : +3ℕ),
|
||||
loop_spaces (nat_of_str x) ≃* loop_spaces2 x
|
||||
| (n, x) := loop_spaces2_pequiv' n x
|
||||
|
||||
local attribute loop_pequiv_loop [reducible]
|
||||
|
||||
/- all cases where n>0 are basically the same -/
|
||||
definition loop_spaces_fun2_phomotopy (x : +3ℕ) :
|
||||
loop_spaces2_pequiv x ∘* loop_spaces_fun (nat_of_str x) ~*
|
||||
(loop_spaces_fun2 x ∘* loop_spaces2_pequiv (S x))
|
||||
∘* pcast (ap (loop_spaces) (nat_of_str_3S x)) :=
|
||||
begin
|
||||
cases x with n x, cases x with k H,
|
||||
do 3 (cases k with k; rotate 1),
|
||||
{ /-k≥3-/ exfalso, apply lt_le_antisymm H, apply le_add_left},
|
||||
{ /-k=0-/
|
||||
induction n with n IH,
|
||||
{ refine !pid_pcompose ⬝* _ ⬝* !pcompose_pid⁻¹* ⬝* !pcompose_pid⁻¹*,
|
||||
reflexivity},
|
||||
{ refine _ ⬝* !pcompose_pid⁻¹*,
|
||||
refine _ ⬝* pwhisker_right _ !loop_spaces_fun2_add1_0⁻¹*,
|
||||
refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose, apply ap1_phomotopy,
|
||||
exact IH ⬝* !pcompose_pid}},
|
||||
{ /-k=1-/
|
||||
induction n with n IH,
|
||||
{ refine !pid_pcompose ⬝* _ ⬝* !pcompose_pid⁻¹* ⬝* !pcompose_pid⁻¹*,
|
||||
reflexivity},
|
||||
{ refine _ ⬝* !pcompose_pid⁻¹*,
|
||||
refine _ ⬝* pwhisker_right _ !loop_spaces_fun2_add1_1⁻¹*,
|
||||
refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose, apply ap1_phomotopy,
|
||||
exact IH ⬝* !pcompose_pid}},
|
||||
{ /-k=2-/
|
||||
induction n with n IH,
|
||||
{ refine !pid_pcompose ⬝* _ ⬝* !pcompose_pid⁻¹*,
|
||||
refine !pcompose_pid⁻¹* ⬝* pconcat2 _ _,
|
||||
{ exact (pcompose_pid (chain_complex.boundary_map f))⁻¹*},
|
||||
{ refine !loop_pequiv_loop_rfl⁻¹* }},
|
||||
{ refine _ ⬝* !pcompose_pid⁻¹*,
|
||||
refine _ ⬝* pwhisker_right _ !loop_spaces_fun2_add1_2⁻¹*,
|
||||
refine !ap1_pcompose⁻¹* ⬝* _ ⬝* !ap1_pcompose, apply ap1_phomotopy,
|
||||
exact IH ⬝* !pcompose_pid}},
|
||||
end
|
||||
|
||||
definition LES_of_loop_spaces2 [constructor] : type_chain_complex +3ℕ :=
|
||||
transfer_type_chain_complex2
|
||||
LES_of_loop_spaces
|
||||
!fin_prod_nat_equiv_nat
|
||||
nat_of_str_3S
|
||||
@loop_spaces_fun2
|
||||
@loop_spaces2_pequiv
|
||||
begin
|
||||
intro m x,
|
||||
refine loop_spaces_fun2_phomotopy m x ⬝ _,
|
||||
apply ap (loop_spaces_fun2 m), apply ap (loop_spaces2_pequiv (S m)),
|
||||
esimp, exact ap010 cast !ap_compose⁻¹ x
|
||||
end
|
||||
|
||||
definition is_exact_LES_of_loop_spaces2 : is_exact_t LES_of_loop_spaces2 :=
|
||||
begin
|
||||
intro n,
|
||||
apply is_exact_at_t_transfer2,
|
||||
apply is_exact_LES_of_loop_spaces
|
||||
end
|
||||
|
||||
definition LES_of_homotopy_groups' [constructor] : chain_complex +3ℕ :=
|
||||
trunc_chain_complex LES_of_loop_spaces2
|
||||
|
||||
/--------------
|
||||
PART 4
|
||||
--------------/
|
||||
|
||||
definition homotopy_groups [reducible] : +3ℕ → Set*
|
||||
| (n, fin.mk 0 H) := π[n] Y
|
||||
| (n, fin.mk 1 H) := π[n] X
|
||||
| (n, fin.mk k H) := π[n] (pfiber f)
|
||||
|
||||
definition homotopy_groups_pequiv_loop_spaces2 [reducible]
|
||||
: Π(n : +3ℕ), ptrunc 0 (loop_spaces2 n) ≃* homotopy_groups n
|
||||
| (n, fin.mk 0 H) := by reflexivity
|
||||
| (n, fin.mk 1 H) := by reflexivity
|
||||
| (n, fin.mk 2 H) := by reflexivity
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition homotopy_groups_fun : Π(n : +3ℕ), homotopy_groups (S n) →* homotopy_groups n
|
||||
| (n, fin.mk 0 H) := proof π→[n] f qed
|
||||
| (n, fin.mk 1 H) := proof π→[n] (ppoint f) qed
|
||||
| (n, fin.mk 2 H) :=
|
||||
proof π→[n] boundary_map ∘* homotopy_group_succ_in Y n qed
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition homotopy_groups_fun_phomotopy_loop_spaces_fun2 [reducible]
|
||||
: Π(n : +3ℕ), homotopy_groups_pequiv_loop_spaces2 n ∘* ptrunc_functor 0 (loop_spaces_fun2 n) ~*
|
||||
homotopy_groups_fun n ∘* homotopy_groups_pequiv_loop_spaces2 (S n)
|
||||
| (n, fin.mk 0 H) := by reflexivity
|
||||
| (n, fin.mk 1 H) := by reflexivity
|
||||
| (n, fin.mk 2 H) :=
|
||||
begin
|
||||
refine !pid_pcompose ⬝* _ ⬝* !pcompose_pid⁻¹*,
|
||||
refine !ptrunc_functor_pcompose
|
||||
end
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition LES_of_homotopy_groups [constructor] : chain_complex +3ℕ :=
|
||||
transfer_chain_complex
|
||||
LES_of_homotopy_groups'
|
||||
homotopy_groups_fun
|
||||
homotopy_groups_pequiv_loop_spaces2
|
||||
homotopy_groups_fun_phomotopy_loop_spaces_fun2
|
||||
|
||||
definition is_exact_LES_of_homotopy_groups : is_exact LES_of_homotopy_groups :=
|
||||
begin
|
||||
intro n,
|
||||
apply is_exact_at_transfer,
|
||||
apply is_exact_at_trunc,
|
||||
apply is_exact_LES_of_loop_spaces2
|
||||
end
|
||||
|
||||
variable (n : ℕ)
|
||||
|
||||
/- the carrier of the fiber sequence is definitionally what we want (as pointed sets) -/
|
||||
example : LES_of_homotopy_groups (str_of_nat 6) = π[2] Y :> Set* := by reflexivity
|
||||
example : LES_of_homotopy_groups (str_of_nat 7) = π[2] X :> Set* := by reflexivity
|
||||
example : LES_of_homotopy_groups (str_of_nat 8) = π[2] (pfiber f) :> Set* := by reflexivity
|
||||
example : LES_of_homotopy_groups (str_of_nat 9) = π[3] Y :> Set* := by reflexivity
|
||||
example : LES_of_homotopy_groups (str_of_nat 10) = π[3] X :> Set* := by reflexivity
|
||||
example : LES_of_homotopy_groups (str_of_nat 11) = π[3] (pfiber f) :> Set* := by reflexivity
|
||||
|
||||
definition LES_of_homotopy_groups_0 : LES_of_homotopy_groups (n, 0) = π[n] Y :=
|
||||
by reflexivity
|
||||
definition LES_of_homotopy_groups_1 : LES_of_homotopy_groups (n, 1) = π[n] X :=
|
||||
by reflexivity
|
||||
definition LES_of_homotopy_groups_2 : LES_of_homotopy_groups (n, 2) = π[n] (pfiber f) :=
|
||||
by reflexivity
|
||||
|
||||
/-
|
||||
the functions of the fiber sequence is definitionally what we want (as pointed function).
|
||||
-/
|
||||
|
||||
definition LES_of_homotopy_groups_fun_0 :
|
||||
cc_to_fn LES_of_homotopy_groups (n, 0) = π→[n] f :=
|
||||
by reflexivity
|
||||
definition LES_of_homotopy_groups_fun_1 :
|
||||
cc_to_fn LES_of_homotopy_groups (n, 1) = π→[n] (ppoint f) :=
|
||||
by reflexivity
|
||||
definition LES_of_homotopy_groups_fun_2 : cc_to_fn LES_of_homotopy_groups (n, 2) =
|
||||
π→[n] boundary_map ∘* homotopy_group_succ_in Y n :=
|
||||
by reflexivity
|
||||
|
||||
open group
|
||||
|
||||
definition group_LES_of_homotopy_groups (n : ℕ) : Π(x : fin (succ 2)),
|
||||
group (LES_of_homotopy_groups (n + 1, x))
|
||||
| (fin.mk 0 H) := begin rexact group_homotopy_group n Y end
|
||||
| (fin.mk 1 H) := begin rexact group_homotopy_group n X end
|
||||
| (fin.mk 2 H) := begin rexact group_homotopy_group n (pfiber f) end
|
||||
| (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition ab_group_LES_of_homotopy_groups (n : ℕ) : Π(x : fin (succ 2)),
|
||||
ab_group (LES_of_homotopy_groups (n + 2, x))
|
||||
| (fin.mk 0 H) := proof ab_group_homotopy_group n Y qed
|
||||
| (fin.mk 1 H) := proof ab_group_homotopy_group n X qed
|
||||
| (fin.mk 2 H) := proof ab_group_homotopy_group n (pfiber f) qed
|
||||
| (fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition Group_LES_of_homotopy_groups (x : +3ℕ) : Group.{u} :=
|
||||
Group.mk (LES_of_homotopy_groups (nat.succ (pr1 x), pr2 x))
|
||||
(group_LES_of_homotopy_groups (pr1 x) (pr2 x))
|
||||
|
||||
definition AbGroup_LES_of_homotopy_groups (n : +3ℕ) : AbGroup.{u} :=
|
||||
AbGroup.mk (LES_of_homotopy_groups (pr1 n + 2, pr2 n))
|
||||
(ab_group_LES_of_homotopy_groups (pr1 n) (pr2 n))
|
||||
|
||||
definition homomorphism_LES_of_homotopy_groups_fun : Π(k : +3ℕ),
|
||||
Group_LES_of_homotopy_groups (S k) →g Group_LES_of_homotopy_groups k
|
||||
| (k, fin.mk 0 H) :=
|
||||
proof homomorphism.mk (cc_to_fn LES_of_homotopy_groups (k + 1, 0))
|
||||
(homotopy_group_functor_mul _ _) qed
|
||||
| (k, fin.mk 1 H) :=
|
||||
proof homomorphism.mk (cc_to_fn LES_of_homotopy_groups (k + 1, 1))
|
||||
(homotopy_group_functor_mul _ _) qed
|
||||
| (k, fin.mk 2 H) :=
|
||||
begin
|
||||
apply homomorphism.mk (cc_to_fn LES_of_homotopy_groups (k + 1, 2)),
|
||||
exact abstract begin rewrite [LES_of_homotopy_groups_fun_2],
|
||||
refine homomorphism.struct ((π→g[k+1] boundary_map) ∘g ghomotopy_group_succ_in Y k),
|
||||
end end
|
||||
end
|
||||
| (k, fin.mk (l+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
end
|
||||
|
||||
/-
|
||||
Fibration sequences
|
||||
|
||||
This is a similar construction, but with as input data two pointed maps,
|
||||
and a pointed equivalence between the domain of the second map and the fiber of the first map,
|
||||
and a pointed homotopy.
|
||||
-/
|
||||
|
||||
section
|
||||
universe variable u
|
||||
parameters {F X Y : pType.{u}} (f : X →* Y) (g : F →* X) (e : pfiber f ≃* F)
|
||||
(p : ppoint f ~* g ∘* e)
|
||||
include f p
|
||||
open succ_str prod nat
|
||||
definition fibration_sequence_car [reducible] : +3ℕ → Type*
|
||||
| (n, fin.mk 0 H) := Ω[n] Y
|
||||
| (n, fin.mk 1 H) := Ω[n] X
|
||||
| (n, fin.mk k H) := Ω[n] F
|
||||
|
||||
definition fibration_sequence_fun
|
||||
: Π(n : +3ℕ), fibration_sequence_car (S n) →* fibration_sequence_car n
|
||||
| (n, fin.mk 0 H) := proof Ω→[n] f qed
|
||||
| (n, fin.mk 1 H) := proof Ω→[n] g qed
|
||||
| (n, fin.mk 2 H) := proof Ω→[n] (e ∘* boundary_map f) ∘* loopn_succ_in Y n qed
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition fibration_sequence_pequiv : Π(x : +3ℕ),
|
||||
loop_spaces2 f x ≃* fibration_sequence_car x
|
||||
| (n, fin.mk 0 H) := by reflexivity
|
||||
| (n, fin.mk 1 H) := by reflexivity
|
||||
| (n, fin.mk 2 H) := loopn_pequiv_loopn n e
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition fibration_sequence_fun_phomotopy : Π(x : +3ℕ),
|
||||
fibration_sequence_pequiv x ∘* loop_spaces_fun2 f x ~*
|
||||
(fibration_sequence_fun x ∘* fibration_sequence_pequiv (S x))
|
||||
| (n, fin.mk 0 H) := by reflexivity
|
||||
| (n, fin.mk 1 H) :=
|
||||
begin refine !pid_pcompose ⬝* _, refine apn_phomotopy n p ⬝* _,
|
||||
refine !apn_pcompose ⬝* _, reflexivity end
|
||||
| (n, fin.mk 2 H) := begin refine !passoc⁻¹* ⬝* _ ⬝* !pcompose_pid⁻¹*, apply pwhisker_right,
|
||||
refine _ ⬝* !apn_pcompose⁻¹*, reflexivity end
|
||||
| (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
|
||||
|
||||
definition type_fibration_sequence [constructor] : type_chain_complex +3ℕ :=
|
||||
transfer_type_chain_complex
|
||||
(LES_of_loop_spaces2 f)
|
||||
fibration_sequence_fun
|
||||
fibration_sequence_pequiv
|
||||
fibration_sequence_fun_phomotopy
|
||||
|
||||
definition is_exact_type_fibration_sequence : is_exact_t type_fibration_sequence :=
|
||||
begin
|
||||
intro n,
|
||||
apply is_exact_at_t_transfer,
|
||||
apply is_exact_LES_of_loop_spaces2
|
||||
end
|
||||
|
||||
definition fibration_sequence [constructor] : chain_complex +3ℕ :=
|
||||
trunc_chain_complex type_fibration_sequence
|
||||
|
||||
end
|
||||
|
||||
|
||||
end chain_complex
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Ulrik Buchholtz. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Ulrik Buchholtz
|
||||
-/
|
||||
import types.trunc homotopy.sphere hit.pushout
|
||||
|
||||
open eq is_trunc is_equiv nat equiv trunc prod pushout sigma sphere_index unit
|
||||
|
||||
-- where should this be?
|
||||
definition family : Type := ΣX, X → Type
|
||||
|
||||
namespace cellcomplex
|
||||
|
||||
/-
|
||||
define by recursion on ℕ
|
||||
both the type of fdccs of dimension n
|
||||
and the realization map fdcc n → Type
|
||||
|
||||
in other words, we define a function
|
||||
fdcc : ℕ → family
|
||||
|
||||
an alternative to the approach here (perhaps necessary) is to
|
||||
define relative cell complexes relative to a type A, and then use
|
||||
spherical indexing, so a -1-dimensional relative cell complex is
|
||||
just star : unit with realization A
|
||||
-/
|
||||
|
||||
definition fdcc_family [reducible] : ℕ → family :=
|
||||
nat.rec
|
||||
-- a zero-dimensional cell complex is just an set
|
||||
-- with realization the identity map
|
||||
⟨Set , λA, trunctype.carrier A⟩
|
||||
(λn fdcc_family_n, -- sigma.rec (λ fdcc_n realize_n,
|
||||
/- a (succ n)-dimensional cell complex is a triple of
|
||||
an n-dimensional cell complex X, an set of (succ n)-cells A,
|
||||
and an attaching map f : A × sphere n → |X| -/
|
||||
⟨Σ X : pr1 fdcc_family_n , Σ A : Set, A × sphere n → pr2 fdcc_family_n X ,
|
||||
/- the realization of such is the pushout of f with
|
||||
canonical map A × sphere n → unit -/
|
||||
sigma.rec (λX , sigma.rec (λA f, pushout (λx , star) f))
|
||||
⟩)
|
||||
|
||||
definition fdcc (n : ℕ) : Type := pr1 (fdcc_family n)
|
||||
|
||||
definition cell : Πn, fdcc n → Set :=
|
||||
nat.cases (λA, A) (λn T, pr1 (pr2 T))
|
||||
|
||||
end cellcomplex
|
||||
|
|
@ -1,547 +0,0 @@
|
|||
/-
|
||||
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
|
||||
|
||||
Chain complexes.
|
||||
|
||||
We define chain complexes in a general way as a sequence X of types indexes over an arbitrary type
|
||||
N with a successor S. There are maps X (S n) → X n for n : N. We can vary N to have chain complexes
|
||||
indexed by ℕ, ℤ, a finite type or something else, and for both ℕ and ℤ we can choose the maps to
|
||||
go up or down. We also use the indexing ℕ × 3 for the LES of homotopy groups, because then it
|
||||
computes better (see [LES_of_homotopy_groups]).
|
||||
|
||||
We have two separate notions of
|
||||
chain complexes:
|
||||
- type_chain_complex: sequence of types, where exactness is formulated using pure existence.
|
||||
- chain_complex: sequence of sets, where exactness is formulated using mere existence.
|
||||
|
||||
-/
|
||||
|
||||
import types.int algebra.group_theory types.fin types.unit
|
||||
|
||||
open eq pointed int unit is_equiv equiv is_trunc trunc function algebra group sigma.ops
|
||||
sum prod nat bool fin
|
||||
|
||||
structure succ_str : Type :=
|
||||
(carrier : Type)
|
||||
(succ : carrier → carrier)
|
||||
|
||||
attribute succ_str.carrier [coercion]
|
||||
|
||||
definition succ_str.S {X : succ_str} : X → X := succ_str.succ X
|
||||
|
||||
open succ_str
|
||||
|
||||
definition snat [reducible] [constructor] : succ_str := succ_str.mk ℕ nat.succ
|
||||
definition snat' [reducible] [constructor] : succ_str := succ_str.mk ℕ nat.pred
|
||||
definition sint [reducible] [constructor] : succ_str := succ_str.mk ℤ int.succ
|
||||
definition sint' [reducible] [constructor] : succ_str := succ_str.mk ℤ int.pred
|
||||
|
||||
notation `+ℕ` := snat
|
||||
notation `-ℕ` := snat'
|
||||
notation `+ℤ` := sint
|
||||
notation `-ℤ` := sint'
|
||||
|
||||
definition stratified_type [reducible] (N : succ_str) (n : ℕ) : Type₀ := N × fin (succ n)
|
||||
|
||||
definition stratified_succ {N : succ_str} {n : ℕ} (x : stratified_type N n)
|
||||
: stratified_type N n :=
|
||||
(if val (pr2 x) = n then S (pr1 x) else pr1 x, cyclic_succ (pr2 x))
|
||||
|
||||
definition stratified [reducible] [constructor] (N : succ_str) (n : ℕ) : succ_str :=
|
||||
succ_str.mk (stratified_type N n) stratified_succ
|
||||
|
||||
notation `+3ℕ` := stratified +ℕ 2
|
||||
notation `-3ℕ` := stratified -ℕ 2
|
||||
notation `+3ℤ` := stratified +ℤ 2
|
||||
notation `-3ℤ` := stratified -ℤ 2
|
||||
notation `+6ℕ` := stratified +ℕ 5
|
||||
notation `-6ℕ` := stratified -ℕ 5
|
||||
notation `+6ℤ` := stratified +ℤ 5
|
||||
notation `-6ℤ` := stratified -ℤ 5
|
||||
|
||||
namespace succ_str
|
||||
protected definition add [reducible] {N : succ_str} (n : N) (k : ℕ) : N :=
|
||||
iterate S k n
|
||||
|
||||
infix ` +' `:65 := succ_str.add
|
||||
|
||||
definition add_succ {N : succ_str} (n : N) (k : ℕ) : n +' (k + 1) = (S n) +' k :=
|
||||
by induction k with k p; reflexivity; exact ap S p
|
||||
|
||||
end succ_str
|
||||
|
||||
namespace chain_complex
|
||||
|
||||
export [notation] succ_str
|
||||
|
||||
/-
|
||||
We define "type chain complexes" which are chain complexes without the
|
||||
"set"-requirement. Exactness is formulated without propositional truncation.
|
||||
-/
|
||||
structure type_chain_complex (N : succ_str) : Type :=
|
||||
(car : N → Type*)
|
||||
(fn : Π(n : N), car (S n) →* car n)
|
||||
(is_chain_complex : Π(n : N) (x : car (S (S n))), fn n (fn (S n) x) = pt)
|
||||
|
||||
section
|
||||
variables {N : succ_str} (X : type_chain_complex N) (n : N)
|
||||
definition tcc_to_car [unfold 2] [coercion] := @type_chain_complex.car
|
||||
definition tcc_to_fn [unfold 2] : X (S n) →* X n := type_chain_complex.fn X n
|
||||
definition tcc_is_chain_complex [unfold 2]
|
||||
: Π(x : X (S (S n))), tcc_to_fn X n (tcc_to_fn X (S n) x) = pt :=
|
||||
type_chain_complex.is_chain_complex X n
|
||||
|
||||
-- important: these notions are shifted by one! (this is to avoid transports)
|
||||
definition is_exact_at_t [reducible] /- X n -/ : Type :=
|
||||
Π(x : X (S n)), tcc_to_fn X n x = pt → fiber (tcc_to_fn X (S n)) x
|
||||
|
||||
definition is_exact_t [reducible] /- X -/ : Type :=
|
||||
Π(n : N), is_exact_at_t X n
|
||||
|
||||
-- A chain complex on +ℕ can be trivially extended to a chain complex on +ℤ
|
||||
definition type_chain_complex_from_left (X : type_chain_complex +ℕ)
|
||||
: type_chain_complex +ℤ :=
|
||||
type_chain_complex.mk (int.rec X (λn, punit))
|
||||
begin
|
||||
intro n, fconstructor,
|
||||
{ induction n with n n,
|
||||
{ exact tcc_to_fn X n},
|
||||
{ esimp, intro x, exact star}},
|
||||
{ induction n with n n,
|
||||
{ apply respect_pt},
|
||||
{ reflexivity}}
|
||||
end
|
||||
begin
|
||||
intro n, induction n with n n,
|
||||
{ exact tcc_is_chain_complex X n},
|
||||
{ esimp, intro x, reflexivity}
|
||||
end
|
||||
|
||||
definition is_exact_t_from_left {X : type_chain_complex +ℕ} {n : ℕ}
|
||||
(H : is_exact_at_t X n)
|
||||
: is_exact_at_t (type_chain_complex_from_left X) (of_nat n) :=
|
||||
H
|
||||
|
||||
/-
|
||||
Given a natural isomorphism between a chain complex and any other sequence,
|
||||
we can give the other sequence the structure of a chain complex, which is exact at the
|
||||
positions where the original sequence is.
|
||||
-/
|
||||
definition transfer_type_chain_complex [constructor] /- X -/
|
||||
{Y : N → Type*} (g : Π{n : N}, Y (S n) →* Y n) (e : Π{n}, X n ≃* Y n)
|
||||
(p : Π{n} (x : X (S n)), e (tcc_to_fn X n x) = g (e x)) : type_chain_complex N :=
|
||||
type_chain_complex.mk Y @g
|
||||
abstract begin
|
||||
intro n, apply equiv_rect (equiv_of_pequiv e), intro x,
|
||||
refine ap g (p x)⁻¹ ⬝ _,
|
||||
refine (p _)⁻¹ ⬝ _,
|
||||
refine ap e (tcc_is_chain_complex X n _) ⬝ _,
|
||||
apply respect_pt
|
||||
end end
|
||||
|
||||
theorem is_exact_at_t_transfer {X : type_chain_complex N} {Y : N → Type*}
|
||||
{g : Π{n : N}, Y (S n) →* Y n} (e : Π{n}, X n ≃* Y n)
|
||||
(p : Π{n} (x : X (S n)), e (tcc_to_fn X n x) = g (e x)) {n : N}
|
||||
(H : is_exact_at_t X n) : is_exact_at_t (transfer_type_chain_complex X @g @e @p) n :=
|
||||
begin
|
||||
intro y q, esimp at *,
|
||||
have H2 : tcc_to_fn X n (e⁻¹ᵉ* y) = pt,
|
||||
begin
|
||||
refine (inv_commute (λn, equiv_of_pequiv e) _ _ @p _)⁻¹ᵖ ⬝ _,
|
||||
refine ap _ q ⬝ _,
|
||||
exact respect_pt e⁻¹ᵉ*
|
||||
end,
|
||||
cases (H _ H2) with x r,
|
||||
refine fiber.mk (e x) _,
|
||||
refine (p x)⁻¹ ⬝ _,
|
||||
refine ap e r ⬝ _,
|
||||
apply right_inv
|
||||
end
|
||||
|
||||
/-
|
||||
We want a theorem which states that if we have a chain complex, but with some
|
||||
where the maps are composed by an equivalences, we want to remove this equivalence.
|
||||
The following two theorems give sufficient conditions for when this is allowed.
|
||||
We use this to transform the LES of homotopy groups where on the odd levels we have
|
||||
maps -πₙ(...) into the LES of homotopy groups where we remove the minus signs (which
|
||||
represents composition with path inversion).
|
||||
-/
|
||||
definition type_chain_complex_cancel_aut [constructor] /- X -/
|
||||
(g : Π{n : N}, X (S n) →* X n) (e : Π{n}, X n ≃* X n)
|
||||
(r : Π{n}, X n →* X n)
|
||||
(p : Π{n : N} (x : X (S n)), g (e x) = tcc_to_fn X n x)
|
||||
(pr : Π{n : N} (x : X (S n)), g x = r (g (e x))) : type_chain_complex N :=
|
||||
type_chain_complex.mk X @g
|
||||
abstract begin
|
||||
have p' : Π{n : N} (x : X (S n)), g x = tcc_to_fn X n (e⁻¹ x),
|
||||
from λn, homotopy_inv_of_homotopy_pre e _ _ p,
|
||||
intro n x,
|
||||
refine ap g !p' ⬝ !pr ⬝ _,
|
||||
refine ap r !p ⬝ _,
|
||||
refine ap r (tcc_is_chain_complex X n _) ⬝ _,
|
||||
apply respect_pt
|
||||
end end
|
||||
|
||||
theorem is_exact_at_t_cancel_aut {X : type_chain_complex N}
|
||||
{g : Π{n : N}, X (S n) →* X n} {e : Π{n}, X n ≃* X n}
|
||||
{r : Π{n}, X n →* X n} (l : Π{n}, X n →* X n)
|
||||
(p : Π{n : N} (x : X (S n)), g (e x) = tcc_to_fn X n x)
|
||||
(pr : Π{n : N} (x : X (S n)), g x = r (g (e x)))
|
||||
(pl : Π{n : N} (x : X (S n)), g (l x) = e (g x))
|
||||
(H : is_exact_at_t X n) : is_exact_at_t (type_chain_complex_cancel_aut X @g @e @r @p @pr) n :=
|
||||
begin
|
||||
intro y q, esimp at *,
|
||||
have H2 : tcc_to_fn X n (e⁻¹ y) = pt,
|
||||
from (homotopy_inv_of_homotopy_pre e _ _ p _)⁻¹ ⬝ q,
|
||||
cases (H _ H2) with x s,
|
||||
refine fiber.mk (l (e x)) _,
|
||||
refine !pl ⬝ _,
|
||||
refine ap e (!p ⬝ s) ⬝ _,
|
||||
apply right_inv
|
||||
end
|
||||
|
||||
/-
|
||||
A more general transfer theorem.
|
||||
Here the base type can also change by an equivalence.
|
||||
-/
|
||||
definition transfer_type_chain_complex2 [constructor] {M : succ_str} {Y : M → Type*}
|
||||
(f : M ≃ N) (c : Π(m : M), S (f m) = f (S m))
|
||||
(g : Π{m : M}, Y (S m) →* Y m) (e : Π{m}, X (f m) ≃* Y m)
|
||||
(p : Π{m} (x : X (S (f m))), e (tcc_to_fn X (f m) x) = g (e (cast (ap (λx, X x) (c m)) x)))
|
||||
: type_chain_complex M :=
|
||||
type_chain_complex.mk Y @g
|
||||
begin
|
||||
intro m,
|
||||
apply equiv_rect (equiv_of_pequiv e),
|
||||
apply equiv_rect (equiv_of_eq (ap (λx, X x) (c (S m)))), esimp,
|
||||
apply equiv_rect (equiv_of_eq (ap (λx, X (S x)) (c m))), esimp,
|
||||
intro x, refine ap g (p _)⁻¹ ⬝ _,
|
||||
refine ap g (ap e (fn_cast_eq_cast_fn (c m) (tcc_to_fn X) x)) ⬝ _,
|
||||
refine (p _)⁻¹ ⬝ _,
|
||||
refine ap e (tcc_is_chain_complex X (f m) _) ⬝ _,
|
||||
apply respect_pt
|
||||
end
|
||||
|
||||
definition is_exact_at_t_transfer2 {X : type_chain_complex N} {M : succ_str} {Y : M → Type*}
|
||||
(f : M ≃ N) (c : Π(m : M), S (f m) = f (S m))
|
||||
(g : Π{m : M}, Y (S m) →* Y m) (e : Π{m}, X (f m) ≃* Y m)
|
||||
(p : Π{m} (x : X (S (f m))), e (tcc_to_fn X (f m) x) = g (e (cast (ap (λx, X x) (c m)) x)))
|
||||
{m : M} (H : is_exact_at_t X (f m))
|
||||
: is_exact_at_t (transfer_type_chain_complex2 X f c @g @e @p) m :=
|
||||
begin
|
||||
intro y q, esimp at *,
|
||||
have H2 : tcc_to_fn X (f m) ((equiv_of_eq (ap (λx, X x) (c m)))⁻¹ᵉ (e⁻¹ y)) = pt,
|
||||
begin
|
||||
refine _ ⬝ ap e⁻¹ᵉ* q ⬝ (respect_pt (e⁻¹ᵉ*)), apply eq_inv_of_eq, clear q, revert y,
|
||||
apply inv_homotopy_of_homotopy_pre e,
|
||||
apply inv_homotopy_of_homotopy_pre, apply p
|
||||
end,
|
||||
induction (H _ H2) with x r,
|
||||
refine fiber.mk (e (cast (ap (λx, X x) (c (S m))) (cast (ap (λx, X (S x)) (c m)) x))) _,
|
||||
refine (p _)⁻¹ ⬝ _,
|
||||
refine ap e (fn_cast_eq_cast_fn (c m) (tcc_to_fn X) x) ⬝ _,
|
||||
refine ap (λx, e (cast _ x)) r ⬝ _,
|
||||
esimp [equiv.symm], rewrite [-ap_inv],
|
||||
refine ap e !cast_cast_inv ⬝ _,
|
||||
apply right_inv
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
/- actual (set) chain complexes -/
|
||||
structure chain_complex (N : succ_str) : Type :=
|
||||
(car : N → Set*)
|
||||
(fn : Π(n : N), car (S n) →* car n)
|
||||
(is_chain_complex : Π(n : N) (x : car (S (S n))), fn n (fn (S n) x) = pt)
|
||||
|
||||
section
|
||||
variables {N : succ_str} (X : chain_complex N) (n : N)
|
||||
|
||||
definition cc_to_car [unfold 2] [coercion] := @chain_complex.car
|
||||
definition cc_to_fn [unfold 2] : X (S n) →* X n := @chain_complex.fn N X n
|
||||
definition cc_is_chain_complex [unfold 2]
|
||||
: Π(x : X (S (S n))), cc_to_fn X n (cc_to_fn X (S n) x) = pt :=
|
||||
@chain_complex.is_chain_complex N X n
|
||||
|
||||
-- important: these notions are shifted by one! (this is to avoid transports)
|
||||
definition is_exact_at [reducible] /- X n -/ : Type :=
|
||||
Π(x : X (S n)), cc_to_fn X n x = pt → image (cc_to_fn X (S n)) x
|
||||
|
||||
definition is_exact [reducible] /- X -/ : Type := Π(n : N), is_exact_at X n
|
||||
|
||||
definition chain_complex_from_left (X : chain_complex +ℕ) : chain_complex +ℤ :=
|
||||
chain_complex.mk (int.rec X (λn, punit))
|
||||
begin
|
||||
intro n, fconstructor,
|
||||
{ induction n with n n,
|
||||
{ exact cc_to_fn X n},
|
||||
{ esimp, intro x, exact star}},
|
||||
{ induction n with n n,
|
||||
{ apply respect_pt},
|
||||
{ reflexivity}}
|
||||
end
|
||||
begin
|
||||
intro n, induction n with n n,
|
||||
{ exact cc_is_chain_complex X n},
|
||||
{ esimp, intro x, reflexivity}
|
||||
end
|
||||
|
||||
definition is_exact_from_left {X : chain_complex +ℕ} {n : ℕ} (H : is_exact_at X n)
|
||||
: is_exact_at (chain_complex_from_left X) (of_nat n) :=
|
||||
H
|
||||
|
||||
definition transfer_chain_complex [constructor] {Y : N → Set*}
|
||||
(g : Π{n : N}, Y (S n) →* Y n) (e : Π{n}, X n ≃* Y n)
|
||||
(p : Π{n} (x : X (S n)), e (cc_to_fn X n x) = g (e x)) : chain_complex N :=
|
||||
chain_complex.mk Y @g
|
||||
abstract begin
|
||||
intro n, apply equiv_rect (equiv_of_pequiv e), intro x,
|
||||
refine ap g (p x)⁻¹ ⬝ _,
|
||||
refine (p _)⁻¹ ⬝ _,
|
||||
refine ap e (cc_is_chain_complex X n _) ⬝ _,
|
||||
apply respect_pt
|
||||
end end
|
||||
|
||||
theorem is_exact_at_transfer {X : chain_complex N} {Y : N → Set*}
|
||||
(g : Π{n : N}, Y (S n) →* Y n) (e : Π{n}, X n ≃* Y n)
|
||||
(p : Π{n} (x : X (S n)), e (cc_to_fn X n x) = g (e x))
|
||||
{n : N} (H : is_exact_at X n) : is_exact_at (transfer_chain_complex X @g @e @p) n :=
|
||||
begin
|
||||
intro y q, esimp at *,
|
||||
have H2 : cc_to_fn X n (e⁻¹ᵉ* y) = pt,
|
||||
begin
|
||||
refine (inv_commute (λn, equiv_of_pequiv e) _ _ @p _)⁻¹ᵖ ⬝ _,
|
||||
refine ap _ q ⬝ _,
|
||||
exact respect_pt e⁻¹ᵉ*
|
||||
end,
|
||||
induction (H _ H2) with x r,
|
||||
refine image.mk (e x) _,
|
||||
refine (p x)⁻¹ ⬝ _,
|
||||
refine ap e r ⬝ _,
|
||||
apply right_inv
|
||||
end
|
||||
|
||||
/- A type chain complex can be set-truncated to a chain complex -/
|
||||
definition trunc_chain_complex [constructor] (X : type_chain_complex N)
|
||||
: chain_complex N :=
|
||||
chain_complex.mk
|
||||
(λn, ptrunc 0 (X n))
|
||||
(λn, ptrunc_functor 0 (tcc_to_fn X n))
|
||||
begin
|
||||
intro n x, esimp at *,
|
||||
refine @trunc.rec _ _ _ (λH, !is_trunc_eq) _ x,
|
||||
clear x, intro x, esimp,
|
||||
exact ap tr (tcc_is_chain_complex X n x)
|
||||
end
|
||||
|
||||
definition is_exact_at_trunc (X : type_chain_complex N) {n : N}
|
||||
(H : is_exact_at_t X n) : is_exact_at (trunc_chain_complex X) n :=
|
||||
begin
|
||||
intro x p, esimp at *,
|
||||
induction x with x, esimp at *,
|
||||
note q := !tr_eq_tr_equiv p,
|
||||
induction q with q,
|
||||
induction H x q with y r,
|
||||
refine image.mk (tr y) _,
|
||||
esimp, exact ap tr r
|
||||
end
|
||||
|
||||
definition transfer_chain_complex2 [constructor] {M : succ_str} {Y : M → Set*}
|
||||
(f : N ≃ M) (c : Π(n : N), f (S n) = S (f n))
|
||||
(g : Π{m : M}, Y (S m) →* Y m) (e : Π{n}, X n ≃* Y (f n))
|
||||
(p : Π{n} (x : X (S n)), e (cc_to_fn X n x) = g (c n ▸ e x)) : chain_complex M :=
|
||||
chain_complex.mk Y @g
|
||||
begin
|
||||
refine equiv_rect f _ _, intro n,
|
||||
have H : Π (x : Y (f (S (S n)))), g (c n ▸ g (c (S n) ▸ x)) = pt,
|
||||
begin
|
||||
apply equiv_rect (equiv_of_pequiv e), intro x,
|
||||
refine ap (λx, g (c n ▸ x)) (@p (S n) x)⁻¹ᵖ ⬝ _,
|
||||
refine (p _)⁻¹ ⬝ _,
|
||||
refine ap e (cc_is_chain_complex X n _) ⬝ _,
|
||||
apply respect_pt
|
||||
end,
|
||||
refine pi.pi_functor _ _ H,
|
||||
{ intro x, exact (c (S n))⁻¹ ▸ (c n)⁻¹ ▸ x}, -- with implicit arguments, this is:
|
||||
-- transport (λx, Y x) (c (S n))⁻¹ (transport (λx, Y (S x)) (c n)⁻¹ x)
|
||||
{ intro x, intro p, refine _ ⬝ p, rewrite [tr_inv_tr, fn_tr_eq_tr_fn (c n)⁻¹ @g, tr_inv_tr]}
|
||||
end
|
||||
|
||||
definition is_exact_at_transfer2 {X : chain_complex N} {M : succ_str} {Y : M → Set*}
|
||||
(f : N ≃ M) (c : Π(n : N), f (S n) = S (f n))
|
||||
(g : Π{m : M}, Y (S m) →* Y m) (e : Π{n}, X n ≃* Y (f n))
|
||||
(p : Π{n} (x : X (S n)), e (cc_to_fn X n x) = g (c n ▸ e x))
|
||||
{n : N} (H : is_exact_at X n) : is_exact_at (transfer_chain_complex2 X f c @g @e @p) (f n) :=
|
||||
begin
|
||||
intro y q, esimp at *,
|
||||
have H2 : cc_to_fn X n (e⁻¹ᵉ* ((c n)⁻¹ ▸ y)) = pt,
|
||||
begin
|
||||
refine (inv_commute (λn, equiv_of_pequiv e) _ _ @p _)⁻¹ᵖ ⬝ _,
|
||||
rewrite [tr_inv_tr, q],
|
||||
exact respect_pt e⁻¹ᵉ*
|
||||
end,
|
||||
induction (H _ H2) with x r,
|
||||
refine image.mk (c n ▸ c (S n) ▸ e x) _,
|
||||
rewrite [fn_tr_eq_tr_fn (c n) @g],
|
||||
refine ap (λx, c n ▸ x) (p x)⁻¹ ⬝ _,
|
||||
refine ap (λx, c n ▸ e x) r ⬝ _,
|
||||
refine ap (λx, c n ▸ x) !right_inv ⬝ _,
|
||||
apply tr_inv_tr,
|
||||
end
|
||||
|
||||
/-
|
||||
This is a start of a development of chain complexes consisting only on groups.
|
||||
This might be useful to have in stable algebraic topology, but in the unstable case it's less
|
||||
useful, since the smallest terms usually don't have a group structure.
|
||||
We don't use it yet, so it's commented out for now
|
||||
-/
|
||||
-- structure group_chain_complex : Type :=
|
||||
-- (car : N → Group)
|
||||
-- (fn : Π(n : N), car (S n) →g car n)
|
||||
-- (is_chain_complex : Π{n : N} (x : car ((S n) + 1)), fn n (fn (S n) x) = 1)
|
||||
|
||||
-- structure group_chain_complex : Type := -- chain complex on the naturals with maps going down
|
||||
-- (car : N → Group)
|
||||
-- (fn : Π(n : N), car (S n) →g car n)
|
||||
-- (is_chain_complex : Π{n : N} (x : car ((S n) + 1)), fn n (fn (S n) x) = 1)
|
||||
|
||||
-- structure right_group_chain_complex : Type := -- chain complex on the naturals with maps going up
|
||||
-- (car : N → Group)
|
||||
-- (fn : Π(n : N), car n →g car (S n))
|
||||
-- (is_chain_complex : Π{n : N} (x : car n), fn (S n) (fn n x) = 1)
|
||||
|
||||
-- definition gcc_to_car [unfold 1] [coercion] := @group_chain_complex.car
|
||||
-- definition gcc_to_fn [unfold 1] := @group_chain_complex.fn
|
||||
-- definition gcc_is_chain_complex [unfold 1] := @group_chain_complex.is_chain_complex
|
||||
-- definition lgcc_to_car [unfold 1] [coercion] := @left_group_chain_complex.car
|
||||
-- definition lgcc_to_fn [unfold 1] := @left_group_chain_complex.fn
|
||||
-- definition lgcc_is_chain_complex [unfold 1] := @left_group_chain_complex.is_chain_complex
|
||||
-- definition rgcc_to_car [unfold 1] [coercion] := @right_group_chain_complex.car
|
||||
-- definition rgcc_to_fn [unfold 1] := @right_group_chain_complex.fn
|
||||
-- definition rgcc_is_chain_complex [unfold 1] := @right_group_chain_complex.is_chain_complex
|
||||
|
||||
-- -- important: these notions are shifted by one! (this is to avoid transports)
|
||||
-- definition is_exact_at_g [reducible] (X : group_chain_complex) (n : N) : Type :=
|
||||
-- Π(x : X (S n)), gcc_to_fn X n x = 1 → image (gcc_to_fn X (S n)) x
|
||||
-- definition is_exact_at_lg [reducible] (X : left_group_chain_complex) (n : N) : Type :=
|
||||
-- Π(x : X (S n)), lgcc_to_fn X n x = 1 → image (lgcc_to_fn X (S n)) x
|
||||
-- definition is_exact_at_rg [reducible] (X : right_group_chain_complex) (n : N) : Type :=
|
||||
-- Π(x : X (S n)), rgcc_to_fn X (S n) x = 1 → image (rgcc_to_fn X n) x
|
||||
|
||||
-- definition is_exact_g [reducible] (X : group_chain_complex) : Type :=
|
||||
-- Π(n : N), is_exact_at_g X n
|
||||
-- definition is_exact_lg [reducible] (X : left_group_chain_complex) : Type :=
|
||||
-- Π(n : N), is_exact_at_lg X n
|
||||
-- definition is_exact_rg [reducible] (X : right_group_chain_complex) : Type :=
|
||||
-- Π(n : N), is_exact_at_rg X n
|
||||
|
||||
-- definition group_chain_complex_from_left (X : left_group_chain_complex) : group_chain_complex :=
|
||||
-- group_chain_complex.mk (int.rec X (λn, G0))
|
||||
-- begin
|
||||
-- intro n, fconstructor,
|
||||
-- { induction n with n n,
|
||||
-- { exact @lgcc_to_fn X n},
|
||||
-- { esimp, intro x, exact star}},
|
||||
-- { induction n with n n,
|
||||
-- { apply respect_mul},
|
||||
-- { intro g h, reflexivity}}
|
||||
-- end
|
||||
-- begin
|
||||
-- intro n, induction n with n n,
|
||||
-- { exact lgcc_is_chain_complex X},
|
||||
-- { esimp, intro x, reflexivity}
|
||||
-- end
|
||||
|
||||
-- definition is_exact_g_from_left {X : left_group_chain_complex} {n : N} (H : is_exact_at_lg X n)
|
||||
-- : is_exact_at_g (group_chain_complex_from_left X) n :=
|
||||
-- H
|
||||
|
||||
-- definition transfer_left_group_chain_complex [constructor] (X : left_group_chain_complex)
|
||||
-- {Y : N → Group} (g : Π{n : N}, Y (S n) →g Y n) (e : Π{n}, X n ≃* Y n)
|
||||
-- (p : Π{n} (x : X (S n)), e (lgcc_to_fn X n x) = g (e x)) : left_group_chain_complex :=
|
||||
-- left_group_chain_complex.mk Y @g
|
||||
-- begin
|
||||
-- intro n, apply equiv_rect (pequiv_of_equiv e), intro x,
|
||||
-- refine ap g (p x)⁻¹ ⬝ _,
|
||||
-- refine (p _)⁻¹ ⬝ _,
|
||||
-- refine ap e (lgcc_is_chain_complex X _) ⬝ _,
|
||||
-- exact respect_pt
|
||||
-- end
|
||||
|
||||
-- definition is_exact_at_t_transfer {X : left_group_chain_complex} {Y : N → Type*}
|
||||
-- {g : Π{n : N}, Y (S n) →* Y n} (e : Π{n}, X n ≃* Y n)
|
||||
-- (p : Π{n} (x : X (S n)), e (lgcc_to_fn X n x) = g (e x)) {n : N}
|
||||
-- (H : is_exact_at_lg X n) : is_exact_at_lg (transfer_left_group_chain_complex X @g @e @p) n :=
|
||||
-- begin
|
||||
-- intro y q, esimp at *,
|
||||
-- have H2 : lgcc_to_fn X n (e⁻¹ᵉ* y) = pt,
|
||||
-- begin
|
||||
-- refine (inv_commute (λn, equiv_of_pequiv e) _ _ @p _)⁻¹ᵖ ⬝ _,
|
||||
-- refine ap _ q ⬝ _,
|
||||
-- exact respect_pt e⁻¹ᵉ*
|
||||
-- end,
|
||||
-- cases (H _ H2) with x r,
|
||||
-- refine image.mk (e x) _,
|
||||
-- refine (p x)⁻¹ ⬝ _,
|
||||
-- refine ap e r ⬝ _,
|
||||
-- apply right_inv
|
||||
-- end
|
||||
|
||||
/-
|
||||
The following theorems state that in a chain complex, if certain types are contractible, and
|
||||
the chain complex is exact at the right spots, a map in the chain complex is an
|
||||
embedding/surjection/equivalence. For the first and third we also need to assume that
|
||||
the map is a group homomorphism (and hence that the two types around it are groups).
|
||||
-/
|
||||
|
||||
definition is_embedding_of_trivial (X : chain_complex N) {n : N}
|
||||
(H : is_exact_at X n) [HX : is_contr (X (S (S n)))]
|
||||
[pgroup (X n)] [pgroup (X (S n))] [is_mul_hom (cc_to_fn X n)]
|
||||
: is_embedding (cc_to_fn X n) :=
|
||||
begin
|
||||
apply is_embedding_of_is_mul_hom,
|
||||
intro g p,
|
||||
induction H g p with x q,
|
||||
have r : pt = x, from !is_prop.elim,
|
||||
induction r,
|
||||
refine q⁻¹ ⬝ _,
|
||||
apply respect_pt
|
||||
end
|
||||
|
||||
definition is_surjective_of_trivial (X : chain_complex N) {n : N}
|
||||
(H : is_exact_at X n) [HX : is_contr (X n)] : is_surjective (cc_to_fn X (S n)) :=
|
||||
begin
|
||||
intro g,
|
||||
refine trunc.elim _ (H g !is_prop.elim),
|
||||
apply tr
|
||||
end
|
||||
|
||||
definition is_equiv_of_trivial (X : chain_complex N) {n : N}
|
||||
(H1 : is_exact_at X n) (H2 : is_exact_at X (S n))
|
||||
[HX1 : is_contr (X n)] [HX2 : is_contr (X (S (S (S n))))]
|
||||
[pgroup (X (S n))] [pgroup (X (S (S n)))] [is_mul_hom (cc_to_fn X (S n))]
|
||||
: is_equiv (cc_to_fn X (S n)) :=
|
||||
begin
|
||||
apply is_equiv_of_is_surjective_of_is_embedding,
|
||||
{ apply is_embedding_of_trivial X, apply H2},
|
||||
{ apply is_surjective_of_trivial X, apply H1},
|
||||
end
|
||||
|
||||
definition is_contr_of_is_embedding_of_is_surjective {N : succ_str} (X : chain_complex N) {n : N}
|
||||
(H : is_exact_at X (S n)) [is_embedding (cc_to_fn X n)]
|
||||
[H2 : is_surjective (cc_to_fn X (S (S (S n))))] : is_contr (X (S (S n))) :=
|
||||
begin
|
||||
apply is_contr.mk pt, intro x,
|
||||
have p : cc_to_fn X n (cc_to_fn X (S n) x) = cc_to_fn X n pt,
|
||||
from !cc_is_chain_complex ⬝ !respect_pt⁻¹,
|
||||
have q : cc_to_fn X (S n) x = pt, from is_injective_of_is_embedding p,
|
||||
induction H x q with y r,
|
||||
induction H2 y with z s,
|
||||
exact (cc_is_chain_complex X _ z)⁻¹ ⬝ ap (cc_to_fn X _) s ⬝ r
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
end chain_complex
|
||||
|
|
@ -1,356 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Declaration of the circle
|
||||
-/
|
||||
|
||||
import .sphere
|
||||
import types.int.hott
|
||||
import algebra.homotopy_group .connectedness
|
||||
|
||||
open eq susp bool sphere_index is_equiv equiv is_trunc is_conn pi algebra pointed
|
||||
|
||||
definition circle : Type₀ := sphere 1
|
||||
|
||||
namespace circle
|
||||
notation `S¹` := circle
|
||||
definition base1 : S¹ := !north
|
||||
definition base2 : S¹ := !south
|
||||
definition seg1 : base1 = base2 := merid !north
|
||||
definition seg2 : base1 = base2 := merid !south
|
||||
|
||||
definition base : S¹ := base1
|
||||
definition loop : base = base := seg2 ⬝ seg1⁻¹
|
||||
|
||||
definition rec2 {P : S¹ → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2) (x : S¹) : P x :=
|
||||
begin
|
||||
induction x with b,
|
||||
{ exact Pb1},
|
||||
{ exact Pb2},
|
||||
{ esimp at *, induction b with y,
|
||||
{ exact Ps1},
|
||||
{ exact Ps2},
|
||||
{ cases y}},
|
||||
end
|
||||
|
||||
definition rec2_on [reducible] {P : S¹ → Type} (x : S¹) (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2) : P x :=
|
||||
circle.rec2 Pb1 Pb2 Ps1 Ps2 x
|
||||
|
||||
theorem rec2_seg1 {P : S¹ → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2)
|
||||
: apd (rec2 Pb1 Pb2 Ps1 Ps2) seg1 = Ps1 :=
|
||||
!rec_merid
|
||||
|
||||
theorem rec2_seg2 {P : S¹ → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2)
|
||||
: apd (rec2 Pb1 Pb2 Ps1 Ps2) seg2 = Ps2 :=
|
||||
!rec_merid
|
||||
|
||||
definition elim2 {P : Type} (Pb1 Pb2 : P) (Ps1 Ps2 : Pb1 = Pb2) (x : S¹) : P :=
|
||||
rec2 Pb1 Pb2 (pathover_of_eq _ Ps1) (pathover_of_eq _ Ps2) x
|
||||
|
||||
definition elim2_on [reducible] {P : Type} (x : S¹) (Pb1 Pb2 : P)
|
||||
(Ps1 : Pb1 = Pb2) (Ps2 : Pb1 = Pb2) : P :=
|
||||
elim2 Pb1 Pb2 Ps1 Ps2 x
|
||||
|
||||
theorem elim2_seg1 {P : Type} (Pb1 Pb2 : P) (Ps1 : Pb1 = Pb2) (Ps2 : Pb1 = Pb2)
|
||||
: ap (elim2 Pb1 Pb2 Ps1 Ps2) seg1 = Ps1 :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant seg1),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim2,rec2_seg1],
|
||||
end
|
||||
|
||||
theorem elim2_seg2 {P : Type} (Pb1 Pb2 : P) (Ps1 : Pb1 = Pb2) (Ps2 : Pb1 = Pb2)
|
||||
: ap (elim2 Pb1 Pb2 Ps1 Ps2) seg2 = Ps2 :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant seg2),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim2,rec2_seg2],
|
||||
end
|
||||
|
||||
definition elim2_type (Pb1 Pb2 : Type) (Ps1 Ps2 : Pb1 ≃ Pb2) (x : S¹) : Type :=
|
||||
elim2 Pb1 Pb2 (ua Ps1) (ua Ps2) x
|
||||
|
||||
definition elim2_type_on [reducible] (x : S¹) (Pb1 Pb2 : Type) (Ps1 Ps2 : Pb1 ≃ Pb2)
|
||||
: Type :=
|
||||
elim2_type Pb1 Pb2 Ps1 Ps2 x
|
||||
|
||||
theorem elim2_type_seg1 (Pb1 Pb2 : Type) (Ps1 Ps2 : Pb1 ≃ Pb2)
|
||||
: transport (elim2_type Pb1 Pb2 Ps1 Ps2) seg1 = Ps1 :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim2_type,elim2_seg1];apply cast_ua_fn
|
||||
|
||||
theorem elim2_type_seg2 (Pb1 Pb2 : Type) (Ps1 Ps2 : Pb1 ≃ Pb2)
|
||||
: transport (elim2_type Pb1 Pb2 Ps1 Ps2) seg2 = Ps2 :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim2_type,elim2_seg2];apply cast_ua_fn
|
||||
|
||||
protected definition rec {P : S¹ → Type} (Pbase : P base) (Ploop : Pbase =[loop] Pbase)
|
||||
(x : S¹) : P x :=
|
||||
begin
|
||||
fapply (rec2_on x),
|
||||
{ exact Pbase},
|
||||
{ exact (transport P seg1 Pbase)},
|
||||
{ apply pathover_tr},
|
||||
{ apply pathover_tr_of_pathover, exact Ploop}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : S¹ → Type} (x : S¹) (Pbase : P base)
|
||||
(Ploop : Pbase =[loop] Pbase) : P x :=
|
||||
circle.rec Pbase Ploop x
|
||||
|
||||
theorem rec_loop_helper {A : Type} (P : A → Type)
|
||||
{x y z : A} {p : x = y} {p' : z = y} {u : P x} {v : P z} (q : u =[p ⬝ p'⁻¹] v) :
|
||||
pathover_tr_of_pathover q ⬝o !pathover_tr⁻¹ᵒ = q :=
|
||||
by cases p'; cases q; exact idp
|
||||
|
||||
definition con_refl {A : Type} {x y : A} (p : x = y) : p ⬝ refl _ = p :=
|
||||
eq.rec_on p idp
|
||||
|
||||
theorem rec_loop {P : S¹ → Type} (Pbase : P base) (Ploop : Pbase =[loop] Pbase) :
|
||||
apd (circle.rec Pbase Ploop) loop = Ploop :=
|
||||
begin
|
||||
rewrite [↑loop,apd_con,↑circle.rec,↑circle.rec2_on,↑base,rec2_seg2,apd_inv,rec2_seg1],
|
||||
apply rec_loop_helper
|
||||
end
|
||||
|
||||
protected definition elim {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
|
||||
(x : S¹) : P :=
|
||||
circle.rec Pbase (pathover_of_eq _ Ploop) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : S¹) (Pbase : P)
|
||||
(Ploop : Pbase = Pbase) : P :=
|
||||
circle.elim Pbase Ploop x
|
||||
|
||||
theorem elim_loop {P : Type} (Pbase : P) (Ploop : Pbase = Pbase) :
|
||||
ap (circle.elim Pbase Ploop) loop = Ploop :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant loop),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,rec_loop],
|
||||
end
|
||||
|
||||
theorem elim_seg1 {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
|
||||
: ap (circle.elim Pbase Ploop) seg1 = (tr_constant seg1 Pbase)⁻¹ :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant seg1),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,↑circle.rec],
|
||||
rewrite [↑circle.rec2_on,rec2_seg1], apply inverse,
|
||||
apply pathover_of_eq_tr_constant_inv
|
||||
end
|
||||
|
||||
theorem elim_seg2 {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
|
||||
: ap (circle.elim Pbase Ploop) seg2 = Ploop ⬝ (tr_constant seg1 Pbase)⁻¹ :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant seg2),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑circle.elim,↑circle.rec],
|
||||
rewrite [↑circle.rec2_on,rec2_seg2],
|
||||
assert l : Π(A B : Type)(a a₂ a₂' : A)(b b' : B)(p : a = a₂)(p' : a₂' = a₂)
|
||||
(q : b = b'),
|
||||
pathover_tr_of_pathover (pathover_of_eq _ q)
|
||||
= pathover_of_eq _ (q ⬝ (tr_constant p' b')⁻¹)
|
||||
:> b =[p] p' ▸ b',
|
||||
{ intros, cases q, cases p', cases p, reflexivity },
|
||||
apply l
|
||||
end
|
||||
|
||||
protected definition elim_type (Pbase : Type) (Ploop : Pbase ≃ Pbase)
|
||||
(x : S¹) : Type :=
|
||||
circle.elim Pbase (ua Ploop) x
|
||||
|
||||
protected definition elim_type_on [reducible] (x : S¹) (Pbase : Type)
|
||||
(Ploop : Pbase ≃ Pbase) : Type :=
|
||||
circle.elim_type Pbase Ploop x
|
||||
|
||||
theorem elim_type_loop (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
|
||||
transport (circle.elim_type Pbase Ploop) loop = Ploop :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑circle.elim_type,elim_loop];apply cast_ua_fn
|
||||
|
||||
theorem elim_type_loop_inv (Pbase : Type) (Ploop : Pbase ≃ Pbase) :
|
||||
transport (circle.elim_type Pbase Ploop) loop⁻¹ = to_inv Ploop :=
|
||||
by rewrite [tr_inv_fn]; apply inv_eq_inv; apply elim_type_loop
|
||||
end circle
|
||||
|
||||
attribute circle.base1 circle.base2 circle.base [constructor]
|
||||
attribute circle.rec2 circle.elim2 [unfold 6] [recursor 6]
|
||||
attribute circle.elim2_type [unfold 5]
|
||||
attribute circle.rec2_on circle.elim2_on [unfold 2]
|
||||
attribute circle.elim2_type [unfold 1]
|
||||
attribute circle.rec circle.elim [unfold 4] [recursor 4]
|
||||
attribute circle.elim_type [unfold 3]
|
||||
attribute circle.rec_on circle.elim_on [unfold 2]
|
||||
attribute circle.elim_type_on [unfold 1]
|
||||
|
||||
namespace circle
|
||||
open sigma
|
||||
/- universal property of the circle -/
|
||||
definition circle_pi_equiv [constructor] (P : S¹ → Type)
|
||||
: (Π(x : S¹), P x) ≃ Σ(p : P base), p =[loop] p :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ⟨f base, apd f loop⟩},
|
||||
{ intro v x, induction v with p q, induction x,
|
||||
{ exact p},
|
||||
{ exact q}},
|
||||
{ intro v, induction v with p q, fapply sigma_eq,
|
||||
{ reflexivity},
|
||||
{ esimp, apply pathover_idp_of_eq, apply rec_loop}},
|
||||
{ intro f, apply eq_of_homotopy, intro x, induction x,
|
||||
{ reflexivity},
|
||||
{ apply eq_pathover_dep, apply hdeg_squareover, esimp, apply rec_loop}}
|
||||
end
|
||||
|
||||
definition circle_arrow_equiv [constructor] (P : Type)
|
||||
: (S¹ → P) ≃ Σ(p : P), p = p :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ⟨f base, ap f loop⟩},
|
||||
{ intro v x, induction v with p q, induction x,
|
||||
{ exact p},
|
||||
{ exact q}},
|
||||
{ intro v, induction v with p q, fapply sigma_eq,
|
||||
{ reflexivity},
|
||||
{ esimp, apply pathover_idp_of_eq, apply elim_loop}},
|
||||
{ intro f, apply eq_of_homotopy, intro x, induction x,
|
||||
{ reflexivity},
|
||||
{ apply eq_pathover, apply hdeg_square, esimp, apply elim_loop}}
|
||||
end
|
||||
|
||||
definition pointed_circle [instance] [constructor] : pointed S¹ :=
|
||||
pointed.mk base
|
||||
|
||||
definition pcircle [constructor] : Type* := pointed.mk' S¹
|
||||
notation `S¹*` := pcircle
|
||||
|
||||
definition loop_neq_idp : loop ≠ idp :=
|
||||
assume H : loop = idp,
|
||||
have H2 : Π{A : Type₁} {a : A} {p : a = a}, p = idp,
|
||||
from λA a p, calc
|
||||
p = ap (circle.elim a p) loop : elim_loop
|
||||
... = ap (circle.elim a p) (refl base) : by rewrite H,
|
||||
eq_bnot_ne_idp H2
|
||||
|
||||
definition circle_turn [reducible] (x : S¹) : x = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact loop },
|
||||
{ apply eq_pathover, apply square_of_eq, rewrite ap_id }
|
||||
end
|
||||
|
||||
definition turn_neq_idp : circle_turn ≠ (λx, idp) :=
|
||||
assume H : circle_turn = λx, idp,
|
||||
have H2 : loop = idp, from apd10 H base,
|
||||
absurd H2 loop_neq_idp
|
||||
|
||||
open int
|
||||
|
||||
protected definition code [unfold 1] (x : S¹) : Type₀ :=
|
||||
circle.elim_type_on x ℤ equiv_succ
|
||||
|
||||
definition transport_code_loop (a : ℤ) : transport circle.code loop a = succ a :=
|
||||
ap10 !elim_type_loop a
|
||||
|
||||
definition transport_code_loop_inv (a : ℤ) : transport circle.code loop⁻¹ a = pred a :=
|
||||
ap10 !elim_type_loop_inv a
|
||||
|
||||
protected definition encode [unfold 2] {x : S¹} (p : base = x) : circle.code x :=
|
||||
transport circle.code p (0 : ℤ)
|
||||
|
||||
protected definition decode [unfold 1] {x : S¹} : circle.code x → base = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact power loop},
|
||||
{ apply arrow_pathover_left, intro b, apply eq_pathover_constant_left_id_right,
|
||||
apply square_of_eq, rewrite [idp_con, power_con,transport_code_loop]}
|
||||
end
|
||||
|
||||
definition circle_eq_equiv [constructor] (x : S¹) : (base = x) ≃ circle.code x :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ exact circle.encode},
|
||||
{ exact circle.decode},
|
||||
{ exact abstract [irreducible] begin
|
||||
induction x,
|
||||
{ intro a, esimp, apply rec_nat_on a,
|
||||
{ exact idp},
|
||||
{ intros n p, rewrite [↑circle.encode, -power_con, con_tr, transport_code_loop],
|
||||
exact ap succ p},
|
||||
{ intros n p, rewrite [↑circle.encode, nat_succ_eq_int_succ, neg_succ, -power_con_inv,
|
||||
@con_tr _ circle.code, transport_code_loop_inv, ↑[circle.encode] at p, p, -neg_succ] }},
|
||||
{ apply pathover_of_tr_eq, apply eq_of_homotopy, intro a, apply @is_set.elim,
|
||||
esimp, exact _} end end},
|
||||
{ intro p, cases p, exact idp},
|
||||
end
|
||||
|
||||
definition base_eq_base_equiv [constructor] : base = base ≃ ℤ :=
|
||||
circle_eq_equiv base
|
||||
|
||||
definition decode_add (a b : ℤ) : circle.decode (a +[ℤ] b) = circle.decode a ⬝ circle.decode b :=
|
||||
!power_con_power⁻¹
|
||||
|
||||
definition encode_con (p q : base = base)
|
||||
: circle.encode (p ⬝ q) = circle.encode p +[ℤ] circle.encode q :=
|
||||
preserve_binary_of_inv_preserve base_eq_base_equiv concat (@add ℤ _) decode_add p q
|
||||
|
||||
--the carrier of π₁(S¹) is the set-truncation of base = base.
|
||||
open algebra trunc group
|
||||
|
||||
definition fg_carrier_equiv_int : π[1](S¹*) ≃ ℤ :=
|
||||
trunc_equiv_trunc 0 base_eq_base_equiv ⬝e @(trunc_equiv 0 ℤ) proof _ qed
|
||||
|
||||
definition con_comm_base (p q : base = base) : p ⬝ q = q ⬝ p :=
|
||||
eq_of_fn_eq_fn base_eq_base_equiv (by esimp;rewrite [+encode_con,add.comm])
|
||||
|
||||
definition fundamental_group_of_circle : π₁(S¹*) ≃g gℤ :=
|
||||
begin
|
||||
apply (isomorphism_of_equiv fg_carrier_equiv_int),
|
||||
intros g h,
|
||||
induction g with g', induction h with h',
|
||||
apply encode_con,
|
||||
end
|
||||
|
||||
open nat
|
||||
definition homotopy_group_of_circle (n : ℕ) : πg[n+2] S¹* ≃g G0 :=
|
||||
begin
|
||||
refine @trivial_homotopy_add_of_is_set_loopn S¹* 1 n _,
|
||||
apply is_trunc_equiv_closed_rev, apply base_eq_base_equiv
|
||||
end
|
||||
|
||||
definition eq_equiv_Z (x : S¹) : x = x ≃ ℤ :=
|
||||
begin
|
||||
induction x,
|
||||
{ apply base_eq_base_equiv},
|
||||
{ apply equiv_pathover, intro p p' q, apply pathover_of_eq,
|
||||
note H := eq_of_square (square_of_pathover q),
|
||||
rewrite con_comm_base at H,
|
||||
note H' := cancel_left _ H,
|
||||
induction H', reflexivity}
|
||||
end
|
||||
|
||||
proposition is_trunc_circle [instance] : is_trunc 1 S¹ :=
|
||||
begin
|
||||
apply is_trunc_succ_of_is_trunc_loop,
|
||||
{ apply trunc_index.minus_one_le_succ},
|
||||
{ intro x, apply is_trunc_equiv_closed_rev, apply eq_equiv_Z}
|
||||
end
|
||||
|
||||
proposition is_conn_circle [instance] : is_conn 0 S¹ :=
|
||||
sphere.is_conn_sphere -1.+2
|
||||
|
||||
definition is_conn_pcircle [instance] : is_conn 0 S¹* := !is_conn_circle
|
||||
definition is_trunc_pcircle [instance] : is_trunc 1 S¹* := !is_trunc_circle
|
||||
|
||||
definition circle_mul [reducible] (x y : S¹) : S¹ :=
|
||||
circle.elim y (circle_turn y) x
|
||||
|
||||
definition circle_mul_base (x : S¹) : circle_mul x base = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ reflexivity },
|
||||
{ apply eq_pathover_id_right, apply hdeg_square, apply elim_loop }
|
||||
end
|
||||
|
||||
definition circle_base_mul [reducible] (x : S¹) : circle_mul base x = x :=
|
||||
idp
|
||||
|
||||
end circle
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2016 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jakob von Raumer
|
||||
|
||||
The Cofiber Type
|
||||
-/
|
||||
import hit.pushout function .susp types.unit
|
||||
|
||||
open eq pushout unit pointed is_trunc is_equiv susp unit equiv
|
||||
|
||||
definition cofiber {A B : Type} (f : A → B) := pushout (λ (a : A), ⋆) f
|
||||
|
||||
namespace cofiber
|
||||
section
|
||||
parameters {A B : Type} (f : A → B)
|
||||
|
||||
protected definition base : cofiber f := inl ⋆
|
||||
|
||||
protected definition cod : B → cofiber f := inr
|
||||
|
||||
parameter {f}
|
||||
protected definition glue (a : A) : cofiber.base f = cofiber.cod f (f a) :=
|
||||
pushout.glue a
|
||||
|
||||
parameter (f)
|
||||
protected definition contr_of_equiv [H : is_equiv f] : is_contr (cofiber f) :=
|
||||
begin
|
||||
fapply is_contr.mk, exact base,
|
||||
intro a, induction a with [u, b],
|
||||
{ cases u, reflexivity },
|
||||
{ exact !glue ⬝ ap inr (right_inv f b) },
|
||||
{ apply eq_pathover, refine _ ⬝hp !ap_id⁻¹, refine !ap_constant ⬝ph _,
|
||||
apply move_bot_of_left, refine !idp_con ⬝ph _, apply transpose, esimp,
|
||||
refine _ ⬝hp (ap (ap inr) !adj⁻¹), refine _ ⬝hp !ap_compose, apply square_Flr_idp_ap },
|
||||
end
|
||||
|
||||
parameter {f}
|
||||
protected definition rec {P : cofiber f → Type}
|
||||
(Pbase : P base) (Pcod : Π (b : B), P (cod b))
|
||||
(Pglue : Π (a : A), pathover P Pbase (glue a) (Pcod (f a))) :
|
||||
(Π y, P y) :=
|
||||
begin
|
||||
intro y, induction y, induction x, exact Pbase, exact Pcod x, esimp, exact Pglue x,
|
||||
end
|
||||
|
||||
protected definition rec_on {P : cofiber f → Type} (y : cofiber f)
|
||||
(Pbase : P base) (Pcod : Π (b : B), P (cod b))
|
||||
(Pglue : Π (a : A), pathover P Pbase (glue a) (Pcod (f a))) : P y :=
|
||||
cofiber.rec Pbase Pcod Pglue y
|
||||
|
||||
protected definition elim {P : Type} (Pbase : P) (Pcod : B → P)
|
||||
(Pglue : Π (x : A), Pbase = Pcod (f x)) (y : cofiber f) : P :=
|
||||
pushout.elim (λu, Pbase) Pcod Pglue y
|
||||
|
||||
protected definition elim_on {P : Type} (y : cofiber f) (Pbase : P) (Pcod : B → P)
|
||||
(Pglue : Π (x : A), Pbase = Pcod (f x)) : P :=
|
||||
cofiber.elim Pbase Pcod Pglue y
|
||||
|
||||
protected theorem elim_glue {P : Type} (y : cofiber f) (Pbase : P) (Pcod : B → P)
|
||||
(Pglue : Π (x : A), Pbase = Pcod (f x)) (a : A)
|
||||
: ap (elim Pbase Pcod Pglue) (glue a) = Pglue a :=
|
||||
!pushout.elim_glue
|
||||
|
||||
end
|
||||
end cofiber
|
||||
|
||||
attribute cofiber.base cofiber.cod [constructor]
|
||||
attribute cofiber.rec cofiber.elim [recursor 8] [unfold 8]
|
||||
attribute cofiber.rec_on cofiber.elim_on [unfold 5]
|
||||
|
||||
-- pointed version
|
||||
|
||||
definition pcofiber [constructor] {A B : Type*} (f : A →* B) : Type* :=
|
||||
pointed.MK (cofiber f) !cofiber.base
|
||||
|
||||
notation `ℂ` := pcofiber
|
||||
|
||||
namespace cofiber
|
||||
|
||||
variables (A : Type*)
|
||||
|
||||
definition cofiber_unit : pcofiber (pconst A punit) ≃* psusp A :=
|
||||
begin
|
||||
fapply pequiv_of_pmap,
|
||||
{ fconstructor, intro x, induction x, exact north, exact south, exact merid x,
|
||||
reflexivity },
|
||||
{ esimp, fapply adjointify,
|
||||
{ intro s, induction s, exact inl ⋆, exact inr ⋆, apply glue a },
|
||||
{ intro s, induction s, do 2 reflexivity, esimp,
|
||||
apply eq_pathover, refine _ ⬝hp !ap_id⁻¹, apply hdeg_square,
|
||||
refine !(ap_compose (pushout.elim _ _ _)) ⬝ _,
|
||||
refine ap _ !elim_merid ⬝ _, apply elim_glue },
|
||||
{ intro c, induction c with s, reflexivity,
|
||||
induction s, reflexivity, esimp, apply eq_pathover, apply hdeg_square,
|
||||
refine _ ⬝ !ap_id⁻¹, refine !(ap_compose (pushout.elim _ _ _)) ⬝ _,
|
||||
refine ap02 _ !elim_glue ⬝ _, apply elim_merid }},
|
||||
end
|
||||
|
||||
end cofiber
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2016 Ulrik Buchholtz and Egbert Rijke. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Ulrik Buchholtz, Egbert Rijke, Floris van Doorn
|
||||
|
||||
The H-space structure on S¹ and the complex Hopf fibration
|
||||
(the standard one).
|
||||
-/
|
||||
|
||||
import .hopf .circle types.fin
|
||||
|
||||
open eq equiv is_equiv circle is_conn trunc is_trunc sphere susp pointed fiber sphere.ops function
|
||||
|
||||
namespace hopf
|
||||
|
||||
definition circle_h_space [instance] : h_space S¹ :=
|
||||
⦃ h_space, one := base, mul := circle_mul,
|
||||
one_mul := circle_base_mul, mul_one := circle_mul_base ⦄
|
||||
|
||||
definition circle_assoc (x y z : S¹) : (x * y) * z = x * (y * z) :=
|
||||
begin
|
||||
induction x,
|
||||
{ reflexivity },
|
||||
{ apply eq_pathover, induction y,
|
||||
{ exact natural_square
|
||||
(λa : S¹, ap (λb : S¹, b * z) (circle_mul_base a))
|
||||
loop },
|
||||
{ apply is_prop.elimo, apply is_trunc_square } }
|
||||
end
|
||||
|
||||
open sphere_index
|
||||
|
||||
definition complex_hopf : S 3 → S 2 :=
|
||||
begin
|
||||
intro x, apply @sigma.pr1 (susp S¹) (hopf S¹),
|
||||
apply inv (hopf.total S¹), apply inv (join.spheres 1 1), exact x
|
||||
end
|
||||
|
||||
definition complex_phopf [constructor] : S* 3 →* S* 2 :=
|
||||
proof pmap.mk complex_hopf idp qed
|
||||
|
||||
definition pfiber_complex_phopf : pfiber complex_phopf ≃* S* 1 :=
|
||||
begin
|
||||
fapply pequiv_of_equiv,
|
||||
{ esimp, unfold [complex_hopf],
|
||||
refine fiber.equiv_precompose (sigma.pr1 ∘ (hopf.total S¹)⁻¹ᵉ)
|
||||
(join.spheres (of_nat 1) (of_nat 1))⁻¹ᵉ _ ⬝e _,
|
||||
refine fiber.equiv_precompose _ (hopf.total S¹)⁻¹ᵉ _ ⬝e _,
|
||||
apply fiber_pr1},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
end hopf
|
||||
|
|
@ -1,441 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Ulrik Buchholtz. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Ulrik Buchholtz, Floris van Doorn
|
||||
|
||||
Connectedness of types and functions
|
||||
-/
|
||||
import types.trunc types.arrow_2 types.lift
|
||||
|
||||
open eq is_trunc is_equiv nat equiv trunc function fiber funext pi pointed
|
||||
|
||||
definition is_conn [reducible] (n : ℕ₋₂) (A : Type) : Type :=
|
||||
is_contr (trunc n A)
|
||||
|
||||
definition is_conn_fun [reducible] (n : ℕ₋₂) {A B : Type} (f : A → B) : Type :=
|
||||
Πb : B, is_conn n (fiber f b)
|
||||
|
||||
definition is_conn_inf [reducible] (A : Type) : Type := Πn, is_conn n A
|
||||
definition is_conn_fun_inf [reducible] {A B : Type} (f : A → B) : Type := Πn, is_conn_fun n f
|
||||
|
||||
namespace is_conn
|
||||
|
||||
definition is_conn_equiv_closed (n : ℕ₋₂) {A B : Type}
|
||||
: A ≃ B → is_conn n A → is_conn n B :=
|
||||
begin
|
||||
intros H C,
|
||||
fapply @is_contr_equiv_closed (trunc n A) _,
|
||||
apply trunc_equiv_trunc,
|
||||
assumption
|
||||
end
|
||||
|
||||
theorem is_conn_of_le (A : Type) {n k : ℕ₋₂} (H : n ≤ k) [is_conn k A] : is_conn n A :=
|
||||
begin
|
||||
apply is_contr_equiv_closed,
|
||||
apply trunc_trunc_equiv_left _ H
|
||||
end
|
||||
|
||||
theorem is_conn_fun_of_le {A B : Type} (f : A → B) {n k : ℕ₋₂} (H : n ≤ k)
|
||||
[is_conn_fun k f] : is_conn_fun n f :=
|
||||
λb, is_conn_of_le _ H
|
||||
|
||||
definition is_conn_of_is_conn_succ (n : ℕ₋₂) (A : Type) [is_conn (n.+1) A] : is_conn n A :=
|
||||
is_trunc_trunc_of_le A -2 (trunc_index.self_le_succ n)
|
||||
|
||||
namespace is_conn_fun
|
||||
section
|
||||
parameters (n : ℕ₋₂) {A B : Type} {h : A → B}
|
||||
(H : is_conn_fun n h) (P : B → Type) [Πb, is_trunc n (P b)]
|
||||
|
||||
private definition rec.helper : (Πa : A, P (h a)) → Πb : B, trunc n (fiber h b) → P b :=
|
||||
λt b, trunc.rec (λx, point_eq x ▸ t (point x))
|
||||
|
||||
private definition rec.g : (Πa : A, P (h a)) → (Πb : B, P b) :=
|
||||
λt b, rec.helper t b (@center (trunc n (fiber h b)) (H b))
|
||||
|
||||
-- induction principle for n-connected maps (Lemma 7.5.7)
|
||||
protected definition rec : is_equiv (λs : Πb : B, P b, λa : A, s (h a)) :=
|
||||
adjointify (λs a, s (h a)) rec.g
|
||||
begin
|
||||
intro t, apply eq_of_homotopy, intro a, unfold rec.g, unfold rec.helper,
|
||||
rewrite [@center_eq _ (H (h a)) (tr (fiber.mk a idp))],
|
||||
end
|
||||
begin
|
||||
intro k, apply eq_of_homotopy, intro b, unfold rec.g,
|
||||
generalize (@center _ (H b)), apply trunc.rec, apply fiber.rec,
|
||||
intros a p, induction p, reflexivity
|
||||
end
|
||||
|
||||
protected definition elim : (Πa : A, P (h a)) → (Πb : B, P b) :=
|
||||
@is_equiv.inv _ _ (λs a, s (h a)) rec
|
||||
|
||||
protected definition elim_β : Πf : (Πa : A, P (h a)), Πa : A, elim f (h a) = f a :=
|
||||
λf, apd10 (@is_equiv.right_inv _ _ (λs a, s (h a)) rec f)
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
parameters (n k : ℕ₋₂) {A B : Type} {f : A → B}
|
||||
(H : is_conn_fun n f) (P : B → Type) [HP : Πb, is_trunc (n +2+ k) (P b)]
|
||||
|
||||
include H HP
|
||||
-- Lemma 8.6.1
|
||||
proposition elim_general : is_trunc_fun k (pi_functor_left f P) :=
|
||||
begin
|
||||
revert P HP,
|
||||
induction k with k IH: intro P HP t,
|
||||
{ apply is_contr_fiber_of_is_equiv, apply is_conn_fun.rec, exact H, exact HP},
|
||||
{ apply is_trunc_succ_intro,
|
||||
intros x y, cases x with g p, cases y with h q,
|
||||
have e : fiber (λr : g ~ h, (λa, r (f a))) (apd10 (p ⬝ q⁻¹))
|
||||
≃ (fiber.mk g p = fiber.mk h q
|
||||
:> fiber (λs : (Πb, P b), (λa, s (f a))) t),
|
||||
begin
|
||||
apply equiv.trans !fiber.sigma_char,
|
||||
have e' : Πr : g ~ h,
|
||||
((λa, r (f a)) = apd10 (p ⬝ q⁻¹))
|
||||
≃ (ap (λv, (λa, v (f a))) (eq_of_homotopy r) ⬝ q = p),
|
||||
begin
|
||||
intro r,
|
||||
refine equiv.trans _ (eq_con_inv_equiv_con_eq q p
|
||||
(ap (λv a, v (f a)) (eq_of_homotopy r))),
|
||||
rewrite [-(ap (λv a, v (f a)) (apd10_eq_of_homotopy r))],
|
||||
rewrite [-(apd10_ap_precompose_dependent f (eq_of_homotopy r))],
|
||||
apply equiv.symm,
|
||||
apply eq_equiv_fn_eq (@apd10 A (λa, P (f a)) (λa, g (f a)) (λa, h (f a)))
|
||||
end,
|
||||
apply equiv.trans (sigma.sigma_equiv_sigma_right e'), clear e',
|
||||
apply equiv.trans (equiv.symm (sigma.sigma_equiv_sigma_left
|
||||
eq_equiv_homotopy)),
|
||||
apply equiv.symm, apply equiv.trans !fiber_eq_equiv,
|
||||
apply sigma.sigma_equiv_sigma_right, intro r,
|
||||
apply eq_equiv_eq_symm
|
||||
end,
|
||||
apply @is_trunc_equiv_closed _ _ k e, clear e,
|
||||
apply IH (λb : B, (g b = h b)) (λb, @is_trunc_eq (P b) (n +2+ k) (HP b) (g b) (h b))}
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
section
|
||||
universe variables u v
|
||||
parameters (n : ℕ₋₂) {A : Type.{u}} {B : Type.{v}} {h : A → B}
|
||||
parameter sec : ΠP : B → trunctype.{max u v} n,
|
||||
is_retraction (λs : (Πb : B, P b), λ a, s (h a))
|
||||
|
||||
private definition s := sec (λb, trunctype.mk' n (trunc n (fiber h b)))
|
||||
|
||||
include sec
|
||||
|
||||
-- the other half of Lemma 7.5.7
|
||||
definition intro : is_conn_fun n h :=
|
||||
begin
|
||||
intro b,
|
||||
apply is_contr.mk (@is_retraction.sect _ _ _ s (λa, tr (fiber.mk a idp)) b),
|
||||
esimp, apply trunc.rec, apply fiber.rec, intros a p,
|
||||
apply transport
|
||||
(λz : (Σy, h a = y), @sect _ _ _ s (λa, tr (mk a idp)) (sigma.pr1 z) =
|
||||
tr (fiber.mk a (sigma.pr2 z)))
|
||||
(@center_eq _ (is_contr_sigma_eq (h a)) (sigma.mk b p)),
|
||||
exact apd10 (@right_inverse _ _ _ s (λa, tr (fiber.mk a idp))) a
|
||||
end
|
||||
end
|
||||
end is_conn_fun
|
||||
|
||||
-- Connectedness is related to maps to and from the unit type, first to
|
||||
section
|
||||
parameters (n : ℕ₋₂) (A : Type)
|
||||
|
||||
definition is_conn_of_map_to_unit
|
||||
: is_conn_fun n (const A unit.star) → is_conn n A :=
|
||||
begin
|
||||
intro H, unfold is_conn_fun at H,
|
||||
exact is_conn_equiv_closed n (fiber.fiber_star_equiv A) _,
|
||||
end
|
||||
|
||||
definition is_conn_fun_to_unit_of_is_conn [H : is_conn n A] :
|
||||
is_conn_fun n (const A unit.star) :=
|
||||
begin
|
||||
intro u, induction u,
|
||||
exact is_conn_equiv_closed n (fiber.fiber_star_equiv A)⁻¹ᵉ _,
|
||||
end
|
||||
|
||||
-- now maps from unit
|
||||
definition is_conn_of_map_from_unit (a₀ : A) (H : is_conn_fun n (const unit a₀))
|
||||
: is_conn n .+1 A :=
|
||||
is_contr.mk (tr a₀)
|
||||
begin
|
||||
apply trunc.rec, intro a,
|
||||
exact trunc.elim (λz : fiber (const unit a₀) a, ap tr (point_eq z))
|
||||
(@center _ (H a))
|
||||
end
|
||||
|
||||
definition is_conn_fun_from_unit (a₀ : A) [H : is_conn n .+1 A]
|
||||
: is_conn_fun n (const unit a₀) :=
|
||||
begin
|
||||
intro a,
|
||||
apply is_conn_equiv_closed n (equiv.symm (fiber_const_equiv A a₀ a)),
|
||||
apply @is_contr_equiv_closed _ _ (tr_eq_tr_equiv n a₀ a),
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
-- as special case we get elimination principles for pointed connected types
|
||||
namespace is_conn
|
||||
open pointed unit
|
||||
section
|
||||
parameters (n : ℕ₋₂) {A : Type*}
|
||||
[H : is_conn n .+1 A] (P : A → Type) [Πa, is_trunc n (P a)]
|
||||
|
||||
include H
|
||||
protected definition rec : is_equiv (λs : Πa : A, P a, s (Point A)) :=
|
||||
@is_equiv_compose
|
||||
(Πa : A, P a) (unit → P (Point A)) (P (Point A))
|
||||
(λf, f unit.star) (λs x, s (Point A))
|
||||
(is_conn_fun.rec n (is_conn_fun_from_unit n A (Point A)) P)
|
||||
(to_is_equiv (arrow_unit_left (P (Point A))))
|
||||
|
||||
protected definition elim : P (Point A) → (Πa : A, P a) :=
|
||||
@is_equiv.inv _ _ (λs, s (Point A)) rec
|
||||
|
||||
protected definition elim_β (p : P (Point A)) : elim p (Point A) = p :=
|
||||
@is_equiv.right_inv _ _ (λs, s (Point A)) rec p
|
||||
end
|
||||
|
||||
section
|
||||
parameters (n k : ℕ₋₂) {A : Type*}
|
||||
[H : is_conn n .+1 A] (P : A → Type) [Πa, is_trunc (n +2+ k) (P a)]
|
||||
|
||||
include H
|
||||
proposition elim_general (p : P (Point A))
|
||||
: is_trunc k (fiber (λs : (Πa : A, P a), s (Point A)) p) :=
|
||||
@is_trunc_equiv_closed
|
||||
(fiber (λs x, s (Point A)) (λx, p))
|
||||
(fiber (λs, s (Point A)) p)
|
||||
k
|
||||
(equiv.symm (fiber.equiv_postcompose _ (arrow_unit_left (P (Point A))) _))
|
||||
(is_conn_fun.elim_general n k (is_conn_fun_from_unit n A (Point A)) P (λx, p))
|
||||
end
|
||||
end is_conn
|
||||
|
||||
-- Lemma 7.5.2
|
||||
definition minus_one_conn_of_surjective {A B : Type} (f : A → B)
|
||||
: is_surjective f → is_conn_fun -1 f :=
|
||||
begin
|
||||
intro H, intro b,
|
||||
exact @is_contr_of_inhabited_prop (∥fiber f b∥) (is_trunc_trunc -1 (fiber f b)) (H b),
|
||||
end
|
||||
|
||||
definition is_surjection_of_minus_one_conn {A B : Type} (f : A → B)
|
||||
: is_conn_fun -1 f → is_surjective f :=
|
||||
begin
|
||||
intro H, intro b,
|
||||
exact @center (∥fiber f b∥) (H b),
|
||||
end
|
||||
|
||||
definition merely_of_minus_one_conn {A : Type} : is_conn -1 A → ∥A∥ :=
|
||||
λH, @center (∥A∥) H
|
||||
|
||||
definition minus_one_conn_of_merely {A : Type} : ∥A∥ → is_conn -1 A :=
|
||||
@is_contr_of_inhabited_prop (∥A∥) (is_trunc_trunc -1 A)
|
||||
|
||||
section
|
||||
open arrow
|
||||
|
||||
variables {f g : arrow}
|
||||
|
||||
-- Lemma 7.5.4
|
||||
definition retract_of_conn_is_conn [instance] (r : arrow_hom f g) [H : is_retraction r]
|
||||
(n : ℕ₋₂) [K : is_conn_fun n f] : is_conn_fun n g :=
|
||||
begin
|
||||
intro b, unfold is_conn,
|
||||
apply is_contr_retract (trunc_functor n (retraction_on_fiber r b)),
|
||||
exact K (on_cod (arrow.is_retraction.sect r) b)
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
-- Corollary 7.5.5
|
||||
definition is_conn_homotopy (n : ℕ₋₂) {A B : Type} {f g : A → B}
|
||||
(p : f ~ g) (H : is_conn_fun n f) : is_conn_fun n g :=
|
||||
@retract_of_conn_is_conn _ _
|
||||
(arrow.arrow_hom_of_homotopy p) (arrow.is_retraction_arrow_hom_of_homotopy p) n H
|
||||
|
||||
-- all types are -2-connected
|
||||
definition is_conn_minus_two (A : Type) : is_conn -2 A :=
|
||||
_
|
||||
|
||||
-- merely inhabited types are -1-connected
|
||||
definition is_conn_minus_one (A : Type) (a : ∥ A ∥) : is_conn -1 A :=
|
||||
is_contr.mk a (is_prop.elim _)
|
||||
|
||||
definition is_conn_trunc [instance] (A : Type) (n k : ℕ₋₂) [H : is_conn n A]
|
||||
: is_conn n (trunc k A) :=
|
||||
begin
|
||||
apply is_trunc_equiv_closed, apply trunc_trunc_equiv_trunc_trunc
|
||||
end
|
||||
|
||||
definition is_conn_eq [instance] (n : ℕ₋₂) {A : Type} (a a' : A) [is_conn (n.+1) A] :
|
||||
is_conn n (a = a') :=
|
||||
begin
|
||||
apply is_trunc_equiv_closed, apply tr_eq_tr_equiv,
|
||||
end
|
||||
|
||||
definition is_conn_loop [instance] (n : ℕ₋₂) (A : Type*) [is_conn (n.+1) A] : is_conn n (Ω A) :=
|
||||
!is_conn_eq
|
||||
|
||||
open pointed
|
||||
definition is_conn_ptrunc [instance] (A : Type*) (n k : ℕ₋₂) [H : is_conn n A]
|
||||
: is_conn n (ptrunc k A) :=
|
||||
is_conn_trunc A n k
|
||||
|
||||
-- the following trivial cases are solved by type class inference
|
||||
definition is_conn_of_is_contr (k : ℕ₋₂) (A : Type) [is_contr A] : is_conn k A := _
|
||||
definition is_conn_fun_of_is_equiv (k : ℕ₋₂) {A B : Type} (f : A → B) [is_equiv f] :
|
||||
is_conn_fun k f :=
|
||||
_
|
||||
|
||||
-- Lemma 7.5.14
|
||||
theorem is_equiv_trunc_functor_of_is_conn_fun [instance] {A B : Type} (n : ℕ₋₂) (f : A → B)
|
||||
[H : is_conn_fun n f] : is_equiv (trunc_functor n f) :=
|
||||
begin
|
||||
fapply adjointify,
|
||||
{ intro b, induction b with b, exact trunc_functor n point (center (trunc n (fiber f b)))},
|
||||
{ intro b, induction b with b, esimp, generalize center (trunc n (fiber f b)), intro v,
|
||||
induction v with v, induction v with a p, esimp, exact ap tr p},
|
||||
{ intro a, induction a with a, esimp, rewrite [center_eq (tr (fiber.mk a idp))]}
|
||||
end
|
||||
|
||||
theorem trunc_equiv_trunc_of_is_conn_fun {A B : Type} (n : ℕ₋₂) (f : A → B)
|
||||
[H : is_conn_fun n f] : trunc n A ≃ trunc n B :=
|
||||
equiv.mk (trunc_functor n f) (is_equiv_trunc_functor_of_is_conn_fun n f)
|
||||
|
||||
definition is_conn_fun_trunc_functor_of_le {n k : ℕ₋₂} {A B : Type} (f : A → B) (H : k ≤ n)
|
||||
[H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
|
||||
begin
|
||||
apply is_conn_fun.intro,
|
||||
intro P, have Πb, is_trunc n (P b), from (λb, is_trunc_of_le _ H),
|
||||
fconstructor,
|
||||
{ intro f' b,
|
||||
induction b with b,
|
||||
refine is_conn_fun.elim k H2 _ _ b, intro a, exact f' (tr a)},
|
||||
{ intro f', apply eq_of_homotopy, intro a,
|
||||
induction a with a, esimp, rewrite [is_conn_fun.elim_β]}
|
||||
end
|
||||
|
||||
definition is_conn_fun_trunc_functor_of_ge {n k : ℕ₋₂} {A B : Type} (f : A → B) (H : n ≤ k)
|
||||
[H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
|
||||
begin
|
||||
apply is_conn_fun_of_is_equiv,
|
||||
apply is_equiv_trunc_functor_of_le f H
|
||||
end
|
||||
|
||||
-- Exercise 7.18
|
||||
definition is_conn_fun_trunc_functor {n k : ℕ₋₂} {A B : Type} (f : A → B)
|
||||
[H2 : is_conn_fun k f] : is_conn_fun k (trunc_functor n f) :=
|
||||
begin
|
||||
eapply algebra.le_by_cases k n: intro H,
|
||||
{ exact is_conn_fun_trunc_functor_of_le f H},
|
||||
{ exact is_conn_fun_trunc_functor_of_ge f H}
|
||||
end
|
||||
|
||||
open lift
|
||||
definition is_conn_fun_lift_functor (n : ℕ₋₂) {A B : Type} (f : A → B) [is_conn_fun n f] :
|
||||
is_conn_fun n (lift_functor f) :=
|
||||
begin
|
||||
intro b, cases b with b, apply is_trunc_equiv_closed_rev,
|
||||
{ apply trunc_equiv_trunc, apply fiber_lift_functor}
|
||||
end
|
||||
|
||||
open trunc_index
|
||||
definition is_conn_fun_inf.mk_nat {A B : Type} {f : A → B} (H : Π(n : ℕ), is_conn_fun n f)
|
||||
: is_conn_fun_inf f :=
|
||||
begin
|
||||
intro n,
|
||||
cases n with n, { exact _},
|
||||
cases n with n, { have -1 ≤ of_nat 0, from dec_star, apply is_conn_fun_of_le f this},
|
||||
rewrite -of_nat_add_two, exact _
|
||||
end
|
||||
|
||||
definition is_conn_inf.mk_nat {A : Type} (H : Π(n : ℕ), is_conn n A) : is_conn_inf A :=
|
||||
begin
|
||||
intro n,
|
||||
cases n with n, { exact _},
|
||||
cases n with n, { have -1 ≤ of_nat 0, from dec_star, apply is_conn_of_le A this},
|
||||
rewrite -of_nat_add_two, exact _
|
||||
end
|
||||
|
||||
end is_conn
|
||||
|
||||
/-
|
||||
(bundled) connected types, possibly also truncated or with a point
|
||||
The notation is n-Type*[k] for k-connected n-truncated pointed types, and you can remove
|
||||
`n-`, `[k]` or `*` in any combination to remove some conditions
|
||||
-/
|
||||
|
||||
structure conntype (n : ℕ₋₂) : Type :=
|
||||
(carrier : Type)
|
||||
(struct : is_conn n carrier)
|
||||
|
||||
notation `Type[`:95 n:0 `]`:0 := conntype n
|
||||
|
||||
attribute conntype.carrier [coercion]
|
||||
attribute conntype.struct [instance] [priority 1300]
|
||||
|
||||
section
|
||||
universe variable u
|
||||
structure pconntype (n : ℕ₋₂) extends conntype.{u} n, pType.{u}
|
||||
|
||||
notation `Type*[`:95 n:0 `]`:0 := pconntype n
|
||||
|
||||
/-
|
||||
There are multiple coercions from pconntype to Type. Type class inference doesn't recognize
|
||||
that all of them are definitionally equal (for performance reasons). One instance is
|
||||
automatically generated, and we manually add the missing instances.
|
||||
-/
|
||||
|
||||
definition is_conn_pconntype [instance] {n : ℕ₋₂} (X : Type*[n]) : is_conn n X :=
|
||||
conntype.struct X
|
||||
|
||||
structure truncconntype (n k : ℕ₋₂) extends trunctype.{u} n,
|
||||
conntype.{u} k renaming struct→conn_struct
|
||||
|
||||
notation n `-Type[`:95 k:0 `]`:0 := truncconntype n k
|
||||
|
||||
definition is_conn_truncconntype [instance] {n k : ℕ₋₂} (X : n-Type[k]) :
|
||||
is_conn k (truncconntype._trans_of_to_trunctype X) :=
|
||||
conntype.struct X
|
||||
|
||||
definition is_trunc_truncconntype [instance] {n k : ℕ₋₂} (X : n-Type[k]) : is_trunc n X :=
|
||||
trunctype.struct X
|
||||
|
||||
structure ptruncconntype (n k : ℕ₋₂) extends ptrunctype.{u} n,
|
||||
pconntype.{u} k renaming struct→conn_struct
|
||||
|
||||
notation n `-Type*[`:95 k:0 `]`:0 := ptruncconntype n k
|
||||
|
||||
attribute ptruncconntype._trans_of_to_pconntype ptruncconntype._trans_of_to_ptrunctype
|
||||
ptruncconntype._trans_of_to_pconntype_1 ptruncconntype._trans_of_to_ptrunctype_1
|
||||
ptruncconntype._trans_of_to_pconntype_2 ptruncconntype._trans_of_to_ptrunctype_2
|
||||
ptruncconntype.to_pconntype ptruncconntype.to_ptrunctype
|
||||
truncconntype._trans_of_to_conntype truncconntype._trans_of_to_trunctype
|
||||
truncconntype.to_conntype truncconntype.to_trunctype [unfold 3]
|
||||
attribute pconntype._trans_of_to_conntype pconntype._trans_of_to_pType
|
||||
pconntype.to_pType pconntype.to_conntype [unfold 2]
|
||||
|
||||
definition is_conn_ptruncconntype [instance] {n k : ℕ₋₂} (X : n-Type*[k]) :
|
||||
is_conn k (ptruncconntype._trans_of_to_ptrunctype X) :=
|
||||
conntype.struct X
|
||||
|
||||
definition is_trunc_ptruncconntype [instance] {n k : ℕ₋₂} (X : n-Type*[k]) :
|
||||
is_trunc n (ptruncconntype._trans_of_to_pconntype X) :=
|
||||
trunctype.struct X
|
||||
|
||||
definition ptruncconntype_eq {n k : ℕ₋₂} {X Y : n-Type*[k]} (p : X ≃* Y) : X = Y :=
|
||||
begin
|
||||
induction X with X Xt Xp Xc, induction Y with Y Yt Yp Yc,
|
||||
note q := pType_eq_elim (eq_of_pequiv p),
|
||||
cases q with r s, esimp at *, induction r,
|
||||
exact ap0111 (ptruncconntype.mk X) !is_prop.elim (eq_of_pathover_idp s) !is_prop.elim
|
||||
end
|
||||
end
|
||||
|
|
@ -1,144 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn
|
||||
|
||||
Declaration of mapping cylinders
|
||||
-/
|
||||
|
||||
import hit.quotient types.fiber
|
||||
|
||||
open quotient eq sum equiv fiber
|
||||
|
||||
namespace cylinder
|
||||
section
|
||||
|
||||
parameters {A B : Type} (f : A → B)
|
||||
|
||||
local abbreviation C := B + A
|
||||
inductive cylinder_rel : C → C → Type :=
|
||||
| Rmk : Π(a : A), cylinder_rel (inl (f a)) (inr a)
|
||||
open cylinder_rel
|
||||
local abbreviation R := cylinder_rel
|
||||
|
||||
definition cylinder := quotient cylinder_rel -- TODO: define this in root namespace
|
||||
|
||||
parameter {f}
|
||||
definition base (b : B) : cylinder :=
|
||||
class_of R (inl b)
|
||||
|
||||
definition top (a : A) : cylinder :=
|
||||
class_of R (inr a)
|
||||
|
||||
definition seg (a : A) : base (f a) = top a :=
|
||||
eq_of_rel cylinder_rel (Rmk f a)
|
||||
|
||||
protected definition rec {P : cylinder → Type}
|
||||
(Pbase : Π(b : B), P (base b)) (Ptop : Π(a : A), P (top a))
|
||||
(Pseg : Π(a : A), Pbase (f a) =[seg a] Ptop a) (x : cylinder) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ cases a,
|
||||
apply Pbase,
|
||||
apply Ptop},
|
||||
{ cases H, apply Pseg}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : cylinder → Type} (x : cylinder)
|
||||
(Pbase : Π(b : B), P (base b)) (Ptop : Π(a : A), P (top a))
|
||||
(Pseg : Π(a : A), Pbase (f a) =[seg a] Ptop a) : P x :=
|
||||
rec Pbase Ptop Pseg x
|
||||
|
||||
theorem rec_seg {P : cylinder → Type}
|
||||
(Pbase : Π(b : B), P (base b)) (Ptop : Π(a : A), P (top a))
|
||||
(Pseg : Π(a : A), Pbase (f a) =[seg a] Ptop a)
|
||||
(a : A) : apd (rec Pbase Ptop Pseg) (seg a) = Pseg a :=
|
||||
!rec_eq_of_rel
|
||||
|
||||
protected definition elim {P : Type} (Pbase : B → P) (Ptop : A → P)
|
||||
(Pseg : Π(a : A), Pbase (f a) = Ptop a) (x : cylinder) : P :=
|
||||
rec Pbase Ptop (λa, pathover_of_eq _ (Pseg a)) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : cylinder) (Pbase : B → P) (Ptop : A → P)
|
||||
(Pseg : Π(a : A), Pbase (f a) = Ptop a) : P :=
|
||||
elim Pbase Ptop Pseg x
|
||||
|
||||
theorem elim_seg {P : Type} (Pbase : B → P) (Ptop : A → P)
|
||||
(Pseg : Π(a : A), Pbase (f a) = Ptop a)
|
||||
(a : A) : ap (elim Pbase Ptop Pseg) (seg a) = Pseg a :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (seg a)),
|
||||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑elim,rec_seg],
|
||||
end
|
||||
|
||||
protected definition elim_type (Pbase : B → Type) (Ptop : A → Type)
|
||||
(Pseg : Π(a : A), Pbase (f a) ≃ Ptop a) (x : cylinder) : Type :=
|
||||
elim Pbase Ptop (λa, ua (Pseg a)) x
|
||||
|
||||
protected definition elim_type_on [reducible] (x : cylinder) (Pbase : B → Type) (Ptop : A → Type)
|
||||
(Pseg : Π(a : A), Pbase (f a) ≃ Ptop a) : Type :=
|
||||
elim_type Pbase Ptop Pseg x
|
||||
|
||||
theorem elim_type_seg (Pbase : B → Type) (Ptop : A → Type)
|
||||
(Pseg : Π(a : A), Pbase (f a) ≃ Ptop a)
|
||||
(a : A) : transport (elim_type Pbase Ptop Pseg) (seg a) = Pseg a :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim_type,elim_seg];apply cast_ua_fn
|
||||
|
||||
end
|
||||
|
||||
end cylinder
|
||||
|
||||
attribute cylinder.base cylinder.top [constructor]
|
||||
attribute cylinder.rec cylinder.elim [unfold 8] [recursor 8]
|
||||
attribute cylinder.elim_type [unfold 7]
|
||||
attribute cylinder.rec_on cylinder.elim_on [unfold 5]
|
||||
attribute cylinder.elim_type_on [unfold 4]
|
||||
|
||||
namespace cylinder
|
||||
open sigma sigma.ops
|
||||
variables {A B : Type} (f : A → B)
|
||||
|
||||
/- cylinder as a dependent family -/
|
||||
definition pr1 [unfold 4] : cylinder f → B :=
|
||||
cylinder.elim id f (λa, idp)
|
||||
|
||||
definition fcylinder : B → Type := fiber (pr1 f)
|
||||
|
||||
definition cylinder_equiv_sigma_fcylinder [constructor] : cylinder f ≃ Σb, fcylinder f b :=
|
||||
!sigma_fiber_equiv⁻¹ᵉ
|
||||
|
||||
variable {f}
|
||||
definition fbase (b : B) : fcylinder f b :=
|
||||
fiber.mk (base b) idp
|
||||
|
||||
definition ftop (a : A) : fcylinder f (f a) :=
|
||||
fiber.mk (top a) idp
|
||||
|
||||
definition fseg (a : A) : fbase (f a) = ftop a :=
|
||||
fiber_eq (seg a) !elim_seg⁻¹
|
||||
|
||||
-- TODO: define the induction principle for "fcylinder"
|
||||
-- set_option pp.notation false
|
||||
-- -- The induction principle for the dependent mapping cylinder (TODO)
|
||||
-- protected definition frec {P : Π(b), fcylinder f b → Type}
|
||||
-- (Pbase : Π(b : B), P _ (fbase b)) (Ptop : Π(a : A), P _ (ftop a))
|
||||
-- (Pseg : Π(a : A), Pbase (f a) =[fseg a] Ptop a) {b : B} (x : fcylinder f b) : P _ x :=
|
||||
-- begin
|
||||
-- cases x with x p, induction p,
|
||||
-- induction x: esimp,
|
||||
-- { apply Pbase},
|
||||
-- { apply Ptop},
|
||||
-- { esimp, --fapply fiber_pathover,
|
||||
-- --refine pathover_of_pathover_ap P (λx, fiber.mk x idp),
|
||||
|
||||
-- exact sorry}
|
||||
-- end
|
||||
|
||||
-- theorem frec_fseg {P : Π(b), fcylinder f b → Type}
|
||||
-- (Pbase : Π(b : B), P _ (fbase b)) (Ptop : Π(a : A), P _ (ftop a))
|
||||
-- (Pseg : Π(a : A), Pbase (f a) =[fseg a] Ptop a) (a : A)
|
||||
-- : apd (cylinder.frec Pbase Ptop Pseg) (fseg a) = Pseg a :=
|
||||
-- sorry
|
||||
|
||||
|
||||
end cylinder
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
/-
|
||||
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 .sphere2 .EM .torus .red_susp .quaternionic_hopf .smash .cellcomplex .interval .cylinder
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue