refactor(*): delete HoTT support
This commit is contained in:
Leonardo de Moura
parent
1d83939cc8
commit
9ef3ebbd5b
183 changed files with 13 additions and 32297 deletions
4
hott/.gitignore
vendored
4
hott/.gitignore
vendored
|
|
@ -1,4 +0,0 @@
|
|||
.ninja_deps
|
||||
.ninja_log
|
||||
TAGS
|
||||
build.ninja
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
+ *.hlean
|
||||
- flycheck*.lean
|
||||
- flycheck*.hlean
|
||||
- .#*.hlean
|
||||
|
|
@ -1,28 +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 HoTT specific:
|
||||
|
||||
* [hott](hott.hlean) : Basic theorems about the algebraic hierarchy specific to HoTT
|
||||
* [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
|
||||
|
||||
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), mB (f a) (f a') = f (mA a 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), mA (f⁻¹ b) (f⁻¹ b') = f⁻¹ (mB b 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), mB (f a) (f a') = f (mA a 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), mA (f⁻¹ b) (f⁻¹ b') = f⁻¹ (mB b 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,83 +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
|
||||
open algebra
|
||||
|
||||
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]
|
||||
|
||||
structure CommGroup :=
|
||||
(carrier : Type) (struct : comm_group carrier)
|
||||
|
||||
attribute CommGroup.carrier [coercion]
|
||||
attribute CommGroup.struct [instance]
|
||||
|
||||
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 AddCommGroup :=
|
||||
(carrier : Type) (struct : add_comm_group carrier)
|
||||
|
||||
attribute AddCommGroup.carrier [coercion]
|
||||
attribute AddCommGroup.struct [instance]
|
||||
end algebra
|
||||
|
|
@ -1,134 +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
|
||||
|
||||
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,20 +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
|
||||
|
||||
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)
|
||||
* [indiscrete](indiscrete.hlean)
|
||||
* [terminal](terminal.hlean)
|
||||
* [initial](initial.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 .functor .set .opposite .product .comma .sum .discrete .indiscrete .terminal .initial
|
||||
|
|
@ -1,74 +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,426 +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 ..nat_trans ..category .opposite
|
||||
|
||||
open eq category is_trunc nat_trans iso is_equiv category.hom
|
||||
|
||||
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 (apd011 nat_trans.mk),
|
||||
apply eq_of_homotopy, intro c, apply left_inverse,
|
||||
apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, apply eq_of_homotopy, intros,
|
||||
apply is_set.elim
|
||||
end
|
||||
|
||||
definition nat_trans_right_inverse : η ∘n nat_trans_inverse η = 1 :=
|
||||
begin
|
||||
fapply (apd011 nat_trans.mk),
|
||||
apply eq_of_homotopy, intro c, apply right_inverse,
|
||||
apply eq_of_homotopy, intros, apply eq_of_homotopy, intros, apply eq_of_homotopy, 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)))
|
||||
|
||||
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 (η : 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 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 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,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,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
|
||||
|
|
@ -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.elim
|
||||
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,159 +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 ..constructions.functor function arity
|
||||
|
||||
open eq functor trunc prod is_equiv iso equiv function is_trunc
|
||||
|
||||
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 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 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_of_F_iso_F (F : C ⇒ D)
|
||||
[H : fully_faithful F] (c c' : C) (g : F c ≅ F c') : c ≅ c' :=
|
||||
begin
|
||||
induction g with g G, induction G with h p q, fapply iso.MK,
|
||||
{ rexact (to_fun_hom F)⁻¹ᶠ g},
|
||||
{ rexact (to_fun_hom F)⁻¹ᶠ h},
|
||||
{ exact abstract begin
|
||||
apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
rewrite [respect_comp, respect_id,
|
||||
right_inv (to_fun_hom F), right_inv (to_fun_hom F), p],
|
||||
end end},
|
||||
{ exact abstract begin
|
||||
apply eq_of_fn_eq_fn' (to_fun_hom F),
|
||||
rewrite [respect_comp, respect_id,
|
||||
right_inv (to_fun_hom F), right_inv (@(to_fun_hom F) c' c), q],
|
||||
end end}
|
||||
end
|
||||
|
||||
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 iso_of_F_iso_F},
|
||||
{ exact abstract begin
|
||||
intro f, induction f with f F', induction F' with g p q, apply iso_eq,
|
||||
esimp [iso_of_F_iso_F], 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 [iso_of_F_iso_F], 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 _
|
||||
|
||||
theorem is_prop_is_weak_equivalence [instance] (F : C ⇒ D) : is_prop (is_weak_equivalence F) :=
|
||||
by unfold is_weak_equivalence; exact _
|
||||
|
||||
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)))
|
||||
-/
|
||||
|
||||
end category
|
||||
|
|
@ -1,276 +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₂ :=
|
||||
apd01111 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 (apd01111 functor.mk idp idp),
|
||||
apply is_set.elim,
|
||||
apply is_set.elim
|
||||
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⁻¹ ⬝ apd 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 (apd011 _ pF pH) id₁ = id₂)
|
||||
(pcomp : cast (apd0111 _ pF pH pid) comp₁ = comp₂) (c : C)
|
||||
: ap010 to_fun_ob (apd01111 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
|
||||
|
||||
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 .basic
|
||||
|
|
@ -1,418 +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
|
||||
|
||||
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)
|
||||
|
||||
infix ` ≃c `:25 := equivalence
|
||||
infix ` ≅c `:25 := isomorphism
|
||||
|
||||
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 (F : C ⇒ D)
|
||||
[H : 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
|
||||
|
||||
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 (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 is_fully_faithful_of_is_isomorphism [instance] [unfold 4] (F : C ⇒ D)
|
||||
[H : is_isomorphism F] : fully_faithful F :=
|
||||
pr1 H
|
||||
|
||||
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
|
||||
|
||||
definition is_equivalence_of_is_isomorphism [instance] [constructor] (F : C ⇒ D) [H : 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.elim
|
||||
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.elim
|
||||
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)) _
|
||||
|
||||
/- 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
|
||||
-/
|
||||
|
||||
|
||||
/- 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 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 .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,78 +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.group
|
||||
|
||||
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]
|
||||
|
||||
definition groupoid.mk [reducible] {ob : Type} (C : precategory ob)
|
||||
(H : Π (a b : ob) (f : a ⟶ b), is_iso f) : groupoid ob :=
|
||||
precategory.rec_on C groupoid.mk' H
|
||||
|
||||
-- We can turn each group into a groupoid on the unit type
|
||||
definition groupoid_of_group.{l} (A : Type.{l}) [G : group A] : groupoid.{0 l} unit :=
|
||||
begin
|
||||
fapply groupoid.mk, fapply precategory.mk,
|
||||
intros, exact A,
|
||||
intros, apply (@group.is_set_carrier A G),
|
||||
intros [a, b, c, g, h], exact (@group.mul A G g h),
|
||||
intro a, exact (@group.one A G),
|
||||
intros, exact (@group.mul_assoc A G h g f)⁻¹,
|
||||
intros, exact (@group.one_mul A G f),
|
||||
intros, exact (@group.mul_one A G f),
|
||||
intros, esimp [precategory.mk], apply is_iso.mk,
|
||||
apply mul.left_inv,
|
||||
apply mul.right_inv,
|
||||
end
|
||||
|
||||
definition hom_group {A : Type} [G : groupoid A] (a : A) :
|
||||
group (hom a a) :=
|
||||
begin
|
||||
fapply group.mk,
|
||||
intro f g, apply (comp f g),
|
||||
apply is_set_hom,
|
||||
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] (C : Groupoid) : Precategory :=
|
||||
Precategory.mk (Groupoid.carrier C) _
|
||||
|
||||
definition groupoid.Mk [reducible] := Groupoid.mk
|
||||
definition groupoid.MK [reducible] (C : Precategory) (H : Π (a b : C) (f : a ⟶ b), is_iso f)
|
||||
: Groupoid :=
|
||||
Groupoid.mk C (groupoid.mk C H)
|
||||
|
||||
definition Groupoid.eta (C : Groupoid) : Groupoid.mk C C = C :=
|
||||
Groupoid.rec (λob c, idp) C
|
||||
|
||||
end category
|
||||
|
|
@ -1,385 +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.elim,
|
||||
apply is_prop.elim,
|
||||
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 [parsing_only] `⁻¹ⁱ`:(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.elim
|
||||
|
||||
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))
|
||||
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⁻¹))
|
||||
|
||||
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⁻¹)⁻¹
|
||||
|
||||
variables (q)
|
||||
theorem comp.cancel_left (H : q ∘ p = q ∘ p') : p = p' :=
|
||||
by rewrite [-inverse_comp_cancel_left q, H, inverse_comp_cancel_left q]
|
||||
theorem comp.cancel_right (H : r ∘ q = r' ∘ q) : r = r' :=
|
||||
by rewrite [-comp_inverse_cancel_right _ q, H, comp_inverse_cancel_right _ q]
|
||||
end
|
||||
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 .limits .colimits
|
||||
|
|
@ -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,190 +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)
|
||||
|
||||
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.elim
|
||||
|
||||
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,286 +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 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 (apd (λ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,202 +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
|
||||
|
||||
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 {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}
|
||||
parameter {R}
|
||||
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 [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_inv [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_con [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 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 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
|
||||
|
||||
/-
|
||||
definition e_closure.transport_left {f : A → B} (e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(t : e_closure R a a') (p : a = a'')
|
||||
: e_closure.elim e (p ▸ t) = (ap f p)⁻¹ ⬝ e_closure.elim e t :=
|
||||
by induction p; exact !idp_con⁻¹
|
||||
|
||||
definition e_closure.transport_right {f : A → B} (e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(t : e_closure R a a') (p : a' = a'')
|
||||
: e_closure.elim e (p ▸ t) = e_closure.elim e t ⬝ (ap f p) :=
|
||||
by induction p; reflexivity
|
||||
|
||||
definition e_closure.transport_lr {f : A → B} (e : Π⦃a a' : A⦄, R a a' → f a = f a')
|
||||
(t : e_closure R a a) (p : a = a')
|
||||
: e_closure.elim e (p ▸ t) = (ap f p)⁻¹ ⬝ e_closure.elim e t ⬝ (ap f p) :=
|
||||
by induction p; esimp; exact !idp_con⁻¹
|
||||
-/
|
||||
|
||||
/- 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_inv [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_con [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'), apdo g' (p s) = po s)
|
||||
(t : T a a') : apdo 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 apdo_inv g' (e_closure.elim p r) ⬝ IH⁻²ᵒ,
|
||||
exact apdo_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_inv, ap_e_closure_elim_inv, IH, con_inv, change_path_con, ▸*, -inv2_inv,
|
||||
change_path_invo, pathover_of_pathover_ap_invo]},
|
||||
{ rewrite [+elimo_con, ap_e_closure_elim_con, 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, 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, -(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, by rewrite [-(!mul_div_cancel Hc), this])
|
||||
|
||||
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, 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, -(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,707 +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.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}
|
||||
|
||||
/- semigroup -/
|
||||
|
||||
namespace algebra
|
||||
|
||||
structure semigroup [class] (A : Type) extends has_mul A :=
|
||||
(is_set_carrier : is_set A)
|
||||
(mul_assoc : Πa b c, mul (mul a b) c = mul a (mul b c))
|
||||
|
||||
attribute semigroup.is_set_carrier [instance]
|
||||
|
||||
definition mul.assoc [s : semigroup A] (a b c : A) : a * b * c = a * (b * c) :=
|
||||
!semigroup.mul_assoc
|
||||
|
||||
structure comm_semigroup [class] (A : Type) extends semigroup A :=
|
||||
(mul_comm : Πa b, mul a b = mul b a)
|
||||
|
||||
definition mul.comm [s : comm_semigroup A] (a b : A) : a * b = b * a :=
|
||||
!comm_semigroup.mul_comm
|
||||
|
||||
theorem mul.left_comm [s : comm_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_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_semigroup [class] (A : Type) extends semigroup A :=
|
||||
(mul_left_cancel : Πa b c, mul a b = mul a c → b = c)
|
||||
|
||||
theorem mul.left_cancel [s : left_cancel_semigroup A] {a b c : A} :
|
||||
a * b = a * c → b = c :=
|
||||
!left_cancel_semigroup.mul_left_cancel
|
||||
|
||||
abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel
|
||||
|
||||
structure right_cancel_semigroup [class] (A : Type) extends semigroup A :=
|
||||
(mul_right_cancel : Πa b c, mul a b = mul c b → a = c)
|
||||
|
||||
definition mul.right_cancel [s : right_cancel_semigroup A] {a b c : A} :
|
||||
a * b = c * b → a = c :=
|
||||
!right_cancel_semigroup.mul_right_cancel
|
||||
|
||||
abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel
|
||||
|
||||
/- additive semigroup -/
|
||||
|
||||
structure add_semigroup [class] (A : Type) extends has_add A :=
|
||||
(is_set_carrier : is_set A)
|
||||
(add_assoc : Πa b c, add (add a b) c = add a (add b c))
|
||||
|
||||
attribute add_semigroup.is_set_carrier [instance]
|
||||
|
||||
definition add.assoc [s : add_semigroup A] (a b c : A) : a + b + c = a + (b + c) :=
|
||||
!add_semigroup.add_assoc
|
||||
|
||||
structure add_comm_semigroup [class] (A : Type) extends add_semigroup A :=
|
||||
(add_comm : Πa b, add a b = add b a)
|
||||
|
||||
definition add.comm [s : add_comm_semigroup A] (a b : A) : a + b = b + a :=
|
||||
!add_comm_semigroup.add_comm
|
||||
|
||||
theorem add.left_comm [s : add_comm_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_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
|
||||
binary.right_comm (@add.comm A _) (@add.assoc A _) a b c
|
||||
|
||||
structure add_left_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
|
||||
(add_left_cancel : Πa b c, add a b = add a c → b = c)
|
||||
|
||||
definition add.left_cancel [s : add_left_cancel_semigroup A] {a b c : A} :
|
||||
a + b = a + c → b = c :=
|
||||
!add_left_cancel_semigroup.add_left_cancel
|
||||
|
||||
abbreviation eq_of_add_eq_add_left := @add.left_cancel
|
||||
|
||||
structure add_right_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
|
||||
(add_right_cancel : Πa b c, add a b = add c b → a = c)
|
||||
|
||||
definition add.right_cancel [s : add_right_cancel_semigroup A] {a b c : A} :
|
||||
a + b = c + b → a = c :=
|
||||
!add_right_cancel_semigroup.add_right_cancel
|
||||
|
||||
abbreviation eq_of_add_eq_add_right := @add.right_cancel
|
||||
|
||||
/- monoid -/
|
||||
|
||||
structure monoid [class] (A : Type) extends semigroup A, has_one A :=
|
||||
(one_mul : Πa, mul one a = a) (mul_one : Πa, mul a one = a)
|
||||
|
||||
definition one_mul [s : monoid A] (a : A) : 1 * a = a := !monoid.one_mul
|
||||
|
||||
definition mul_one [s : monoid A] (a : A) : a * 1 = a := !monoid.mul_one
|
||||
|
||||
structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A
|
||||
|
||||
/- additive monoid -/
|
||||
|
||||
structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A :=
|
||||
(zero_add : Πa, add zero a = a) (add_zero : Πa, add a zero = a)
|
||||
|
||||
definition zero_add [s : add_monoid A] (a : A) : 0 + a = a := !add_monoid.zero_add
|
||||
|
||||
definition add_zero [s : add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_zero
|
||||
|
||||
structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A
|
||||
|
||||
definition add_monoid.to_monoid {A : Type} [s : add_monoid A] : monoid A :=
|
||||
⦃ monoid,
|
||||
mul := add_monoid.add,
|
||||
mul_assoc := add_monoid.add_assoc,
|
||||
one := add_monoid.zero A,
|
||||
mul_one := add_monoid.add_zero,
|
||||
one_mul := add_monoid.zero_add,
|
||||
is_set_carrier := _
|
||||
⦄
|
||||
|
||||
definition add_comm_monoid.to_comm_monoid {A : Type} [s : add_comm_monoid A] : comm_monoid A :=
|
||||
⦃ comm_monoid,
|
||||
add_monoid.to_monoid,
|
||||
mul_comm := add_comm_monoid.add_comm
|
||||
⦄
|
||||
|
||||
section add_comm_monoid
|
||||
variables [s : add_comm_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_monoid
|
||||
|
||||
/- group -/
|
||||
|
||||
structure group [class] (A : Type) extends 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 group
|
||||
|
||||
variable [s : group A]
|
||||
include s
|
||||
|
||||
definition mul.left_inv (a : A) : a⁻¹ * a = 1 := !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 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 group.to_left_cancel_semigroup [trans_instance] : left_cancel_semigroup A :=
|
||||
⦃ left_cancel_semigroup, s,
|
||||
mul_left_cancel := @mul_left_cancel A s ⦄
|
||||
|
||||
definition group.to_right_cancel_semigroup [trans_instance] : right_cancel_semigroup A :=
|
||||
⦃ right_cancel_semigroup, s,
|
||||
mul_right_cancel := @mul_right_cancel A s ⦄
|
||||
|
||||
end group
|
||||
|
||||
structure comm_group [class] (A : Type) extends group A, comm_monoid A
|
||||
|
||||
/- additive group -/
|
||||
|
||||
structure add_group [class] (A : Type) extends add_monoid A, has_neg A :=
|
||||
(add_left_inv : Πa, add (neg a) a = zero)
|
||||
|
||||
definition add_group.to_group {A : Type} [s : add_group A] : group A :=
|
||||
⦃ group, add_monoid.to_monoid,
|
||||
mul_left_inv := add_group.add_left_inv ⦄
|
||||
|
||||
|
||||
section add_group
|
||||
|
||||
variables [s : add_group A]
|
||||
include s
|
||||
|
||||
theorem add.left_inv (a : A) : -a + a = 0 := !add_group.add_left_inv
|
||||
|
||||
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, -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_group.to_left_cancel_semigroup [trans_instance] : add_left_cancel_semigroup A :=
|
||||
⦃ add_left_cancel_semigroup, s,
|
||||
add_left_cancel := @add_left_cancel A s ⦄
|
||||
|
||||
definition add_group.to_add_right_cancel_semigroup [trans_instance] : add_right_cancel_semigroup A :=
|
||||
⦃ add_right_cancel_semigroup, s,
|
||||
add_right_cancel := @add_right_cancel 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_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_group
|
||||
|
||||
structure add_comm_group [class] (A : Type) extends add_group A, add_comm_monoid A
|
||||
|
||||
section add_comm_group
|
||||
variable [s : add_comm_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_comm_group
|
||||
|
||||
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 := _⦄
|
||||
|
||||
namespace norm_num
|
||||
reveal add.assoc
|
||||
|
||||
definition add1 [s : has_add A] [s' : has_one A] (a : A) : A := add a one
|
||||
|
||||
theorem add_comm_four [s : add_comm_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_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_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
|
||||
!add_comm_four
|
||||
|
||||
theorem bit0_add_bit0_helper [s : add_comm_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_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_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_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_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_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_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_monoid A] (a : A) : a + zero = a := !add_zero
|
||||
|
||||
theorem bin_zero_add [s : add_monoid A] (a : A) : zero + a = a := !zero_add
|
||||
|
||||
theorem one_add_bit0 [s : add_comm_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_semigroup A] [s' : has_one A] (a : A) :
|
||||
one + bit1 a = add1 (bit1 a) := !add.comm
|
||||
|
||||
theorem one_add_bit1_helper [s : add_comm_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_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_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_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_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,137 +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 .hott types.trunc
|
||||
|
||||
open nat eq pointed trunc is_trunc algebra
|
||||
|
||||
namespace eq
|
||||
|
||||
definition phomotopy_group [constructor] (n : ℕ) (A : Type*) : Set* :=
|
||||
ptrunc 0 (Ω[n] A)
|
||||
|
||||
definition homotopy_group [reducible] (n : ℕ) (A : Type*) : Type :=
|
||||
phomotopy_group n A
|
||||
|
||||
notation `π*[`:95 n:0 `] `:0 A:95 := phomotopy_group n A
|
||||
notation `π[`:95 n:0 `] `:0 A:95 := homotopy_group n A
|
||||
|
||||
definition group_homotopy_group [instance] [constructor] (n : ℕ) (A : Type*)
|
||||
: group (π[succ n] A) :=
|
||||
trunc_group concat inverse idp con.assoc idp_con con_idp con.left_inv
|
||||
|
||||
definition comm_group_homotopy_group [constructor] (n : ℕ) (A : Type*)
|
||||
: comm_group (π[succ (succ n)] A) :=
|
||||
trunc_comm_group concat inverse idp con.assoc idp_con con_idp con.left_inv eckmann_hilton
|
||||
|
||||
local attribute comm_group_homotopy_group [instance]
|
||||
|
||||
definition ghomotopy_group [constructor] (n : ℕ) (A : Type*) : Group :=
|
||||
Group.mk (π[succ n] A) _
|
||||
|
||||
definition cghomotopy_group [constructor] (n : ℕ) (A : Type*) : CommGroup :=
|
||||
CommGroup.mk (π[succ (succ n)] A) _
|
||||
|
||||
definition fundamental_group [constructor] (A : Type*) : Group :=
|
||||
ghomotopy_group zero A
|
||||
|
||||
notation `πg[`:95 n:0 ` +1] `:0 A:95 := ghomotopy_group n A
|
||||
notation `πag[`:95 n:0 ` +2] `:0 A:95 := cghomotopy_group n A
|
||||
|
||||
prefix `π₁`:95 := fundamental_group
|
||||
|
||||
definition phomotopy_group_pequiv [constructor] (n : ℕ) {A B : Type*} (H : A ≃* B)
|
||||
: π*[n] A ≃* π*[n] B :=
|
||||
ptrunc_pequiv 0 (iterated_loop_space_pequiv n H)
|
||||
|
||||
set_option pp.coercions true
|
||||
set_option pp.numerals false
|
||||
definition phomotopy_group_pequiv_loop_ptrunc [constructor] (k : ℕ) (A : Type*) :
|
||||
π*[k] A ≃* Ω[k] (ptrunc k A) :=
|
||||
begin
|
||||
refine !iterated_loop_ptrunc_pequiv⁻¹ᵉ* ⬝e* _,
|
||||
rewrite [trunc_index.zero_add]
|
||||
end
|
||||
|
||||
open equiv unit
|
||||
theorem trivial_homotopy_of_is_set (A : Type*) [H : is_set A] (n : ℕ) : πg[n+1] A = 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 phomotopy_group_succ_out (A : Type*) (n : ℕ) : π*[n + 1] A = π₁ Ω[n] A := idp
|
||||
|
||||
definition phomotopy_group_succ_in (A : Type*) (n : ℕ) : π*[n + 1] A = π*[n] Ω A :=
|
||||
ap (ptrunc 0) (loop_space_succ_eq_in A n)
|
||||
|
||||
definition ghomotopy_group_succ_out (A : Type*) (n : ℕ) : πg[n +1] A = π₁ Ω[n] A := idp
|
||||
|
||||
definition ghomotopy_group_succ_in (A : Type*) (n : ℕ) : πg[succ n +1] A = πg[n +1] Ω A :=
|
||||
begin
|
||||
fapply Group_eq,
|
||||
{ apply equiv_of_eq, exact ap (ptrunc 0) (loop_space_succ_eq_in A (succ n))},
|
||||
{ exact abstract [irreducible] begin refine trunc.rec _, intro p, refine trunc.rec _, intro q,
|
||||
rewrite [▸*,-+tr_eq_cast_ap, +trunc_transport], refine !trunc_transport ⬝ _, apply ap tr,
|
||||
apply loop_space_succ_eq_in_concat end end},
|
||||
end
|
||||
|
||||
definition homotopy_group_add (A : Type*) (n m : ℕ) : πg[n+m +1] A = πg[n +1] Ω[m] A :=
|
||||
begin
|
||||
revert A, induction m with m IH: intro A,
|
||||
{ reflexivity},
|
||||
{ esimp [iterated_ploop_space, nat.add], refine !ghomotopy_group_succ_in ⬝ _, refine !IH ⬝ _,
|
||||
exact ap (ghomotopy_group n) !loop_space_succ_eq_in⁻¹}
|
||||
end
|
||||
|
||||
theorem trivial_homotopy_add_of_is_set_loop_space {A : Type*} {n : ℕ} (m : ℕ)
|
||||
(H : is_set (Ω[n] A)) : πg[m+n+1] A = G0 :=
|
||||
!homotopy_group_add ⬝ !trivial_homotopy_of_is_set
|
||||
|
||||
theorem trivial_homotopy_le_of_is_set_loop_space {A : Type*} {n : ℕ} (m : ℕ) (H1 : n ≤ m)
|
||||
(H2 : is_set (Ω[n] A)) : πg[m+1] A = G0 :=
|
||||
obtain (k : ℕ) (p : n + k = m), from le.elim H1,
|
||||
ap (λx, πg[x+1] A) (p⁻¹ ⬝ add.comm n k) ⬝ trivial_homotopy_add_of_is_set_loop_space k H2
|
||||
|
||||
definition phomotopy_group_functor [constructor] (n : ℕ) {A B : Type*} (f : A →* B)
|
||||
: π*[n] A →* π*[n] B :=
|
||||
ptrunc_functor 0 (apn n f)
|
||||
|
||||
definition homotopy_group_functor (n : ℕ) {A B : Type*} (f : A →* B) : π[n] A → π[n] B :=
|
||||
phomotopy_group_functor n f
|
||||
|
||||
notation `π→*[`:95 n:0 `] `:0 f:95 := phomotopy_group_functor n f
|
||||
notation `π→[`:95 n:0 `] `:0 f:95 := homotopy_group_functor n f
|
||||
|
||||
definition tinverse [constructor] {X : Type*} : π*[1] X →* π*[1] X :=
|
||||
ptrunc_functor 0 pinverse
|
||||
|
||||
definition ptrunc_functor_pinverse [constructor] {X : Type*}
|
||||
: ptrunc_functor 0 (@pinverse X) ~* @tinverse X :=
|
||||
begin
|
||||
fapply phomotopy.mk,
|
||||
{ reflexivity},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition phomotopy_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
|
||||
|
||||
|
||||
|
||||
|
||||
end eq
|
||||
|
|
@ -1,87 +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 algebra specific to HoTT
|
||||
-/
|
||||
|
||||
import .group arity types.pi prop_trunc types.unit .bundled
|
||||
|
||||
open equiv eq is_trunc unit
|
||||
|
||||
namespace algebra
|
||||
|
||||
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
|
||||
|
||||
open Group has_mul has_inv
|
||||
-- we prove under which conditions two groups are equal
|
||||
|
||||
-- group and has_mul are classes. So, lean does not automatically generate
|
||||
-- coercions between them anymore.
|
||||
-- So, an application such as (@mul A G g h) in the following definition
|
||||
-- is type incorrect if the coercion is not added (explicitly or implicitly).
|
||||
definition group.to_has_mul {A : Type} (H : group A) : has_mul 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 Gm Gs Gh1 G1 Gh2 Gh3 Gi Gh4,
|
||||
cases H with Hm Hs Hh1 H1 Hh2 Hh3 Hi Hh4,
|
||||
rewrite [↑[semigroup.to_has_mul,group.to_has_inv] at (same_mul',foo)],
|
||||
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 : carrier G = 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 (apo011 mk p),
|
||||
exact group_pathover resp_mul
|
||||
end
|
||||
|
||||
definition Group_eq {G H : Group} (f : carrier G ≃ 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 trivial_group_of_is_contr (G : Group) [H : is_contr G] : G = G0 :=
|
||||
begin
|
||||
fapply Group_eq,
|
||||
{ apply equiv_unit_of_is_contr},
|
||||
{ intros, reflexivity}
|
||||
end
|
||||
|
||||
end algebra
|
||||
|
|
@ -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,434 +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)
|
||||
|
||||
definition le.total [s : linear_weak_order A] (a b : A) : a ≤ b ⊎ b ≤ a :=
|
||||
!linear_weak_order.le_total
|
||||
|
||||
/- 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 : add_sub_cancel
|
||||
... = b + b + a - b : add.right_comm
|
||||
... = (b + b) + (a - b) : 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,824 +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_cancel_comm_monoid [class] (A : Type) extends add_comm_monoid A,
|
||||
add_left_cancel_semigroup A, add_right_cancel_semigroup A, order_pair A :=
|
||||
(add_le_add_left : Πa b, le a b → Πc, le (add c a) (add c b))
|
||||
(le_of_add_le_add_left : Πa b c, le (add a b) (add a c) → le b c)
|
||||
(add_lt_add_left : Πa b, lt a b → Πc, lt (add c a) (add c b))
|
||||
(lt_of_add_lt_add_left : Πa b c, lt (add a b) (add a c) → lt b c)
|
||||
|
||||
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_cancel_comm_monoid.add_lt_add_left 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_cancel_comm_monoid.add_le_add_left 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_cancel_comm_monoid.le_of_add_le_add_left 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_cancel_comm_monoid.lt_of_add_lt_add_left 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_comm_group [class] (A : Type) extends add_comm_group A, order_pair A :=
|
||||
(add_le_add_left : Πa b, le a b → Πc, le (add c a) (add c b))
|
||||
(add_lt_add_left : Πa b, lt a b → Π c, lt (add c a) (add c b))
|
||||
|
||||
theorem ordered_comm_group.le_of_add_le_add_left [s : ordered_comm_group A] {a b c : A}
|
||||
(H : a + b ≤ a + c) : b ≤ c :=
|
||||
have H' : -a + (a + b) ≤ -a + (a + c), from ordered_comm_group.add_le_add_left _ _ H _,
|
||||
by rewrite *neg_add_cancel_left at H'; exact H'
|
||||
|
||||
theorem ordered_comm_group.lt_of_add_lt_add_left [s : ordered_comm_group A] {a b c : A}
|
||||
(H : a + b < a + c) : b < c :=
|
||||
have H' : -a + (a + b) < -a + (a + c), from ordered_comm_group.add_lt_add_left _ _ H _,
|
||||
by rewrite *neg_add_cancel_left at H'; exact H'
|
||||
|
||||
definition ordered_comm_group.to_ordered_cancel_comm_monoid [trans_instance]
|
||||
[s : ordered_comm_group A] : ordered_cancel_comm_monoid A :=
|
||||
⦃ ordered_cancel_comm_monoid, s,
|
||||
add_left_cancel := @add.left_cancel A _,
|
||||
add_right_cancel := @add.right_cancel A _,
|
||||
le_of_add_le_add_left := @ordered_comm_group.le_of_add_le_add_left A _,
|
||||
lt_of_add_lt_add_left := @ordered_comm_group.lt_of_add_lt_add_left A _⦄
|
||||
|
||||
section
|
||||
variables [s : ordered_comm_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_comm_group [class] (A : Type)
|
||||
extends add_comm_group A, decidable_linear_order A :=
|
||||
(add_le_add_left : Π a b, le a b → Π c, le (add c a) (add c b))
|
||||
(add_lt_add_left : Π a b, lt a b → Π c, lt (add c a) (add c b))
|
||||
|
||||
definition decidable_linear_ordered_comm_group.to_ordered_comm_group
|
||||
[trans_instance]
|
||||
(A : Type) [s : decidable_linear_ordered_comm_group A] : ordered_comm_group A :=
|
||||
⦃ ordered_comm_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 _ ⦄
|
||||
|
||||
section
|
||||
variables [s : decidable_linear_ordered_comm_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,738 +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 [class] (A : Type)
|
||||
extends semiring A, ordered_cancel_comm_monoid A :=
|
||||
(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))
|
||||
|
||||
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 [class] (A : Type)
|
||||
extends ring A, ordered_comm_group A, 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))
|
||||
|
||||
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 [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 [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 [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_comm_group A
|
||||
|
||||
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,499 +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 [class] (A : Type) extends add_comm_monoid A, monoid A, distrib A,
|
||||
mul_zero_class A
|
||||
|
||||
section semiring
|
||||
variables [s : semiring A] (a b c : A)
|
||||
include s
|
||||
|
||||
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
|
||||
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 [class] (A : Type) extends add_comm_group A, monoid A, distrib A
|
||||
|
||||
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 [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 : 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 [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_comm_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_comm_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_comm_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_comm_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_comm_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_comm_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_comm_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_comm_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,96 +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.group
|
||||
|
||||
open eq is_trunc trunc
|
||||
|
||||
namespace algebra
|
||||
|
||||
section
|
||||
parameters (A : Type) (mul : A → A → A) (inv : A → A) (one : A)
|
||||
{mul_assoc : ∀a b c, mul (mul a b) c = mul a (mul b c)}
|
||||
{one_mul : ∀a, mul one a = a} {mul_one : ∀a, mul a one = a}
|
||||
{mul_left_inv : ∀a, mul (inv a) a = one}
|
||||
|
||||
local abbreviation G := trunc 0 A
|
||||
|
||||
include mul_assoc one_mul mul_one mul_left_inv
|
||||
definition trunc_mul [unfold 9 10] (g h : G) : G :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
apply trunc.rec_on h, intro q,
|
||||
exact tr (mul p q)
|
||||
end
|
||||
|
||||
definition trunc_inv [unfold 9] (g : G) : G :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
exact tr (inv p)
|
||||
end
|
||||
|
||||
definition trunc_one [constructor] : G :=
|
||||
tr one
|
||||
|
||||
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
|
||||
apply trunc.rec_on g₁, intro p₁,
|
||||
apply trunc.rec_on g₂, intro p₂,
|
||||
apply trunc.rec_on g₃, intro p₃,
|
||||
exact ap tr !mul_assoc,
|
||||
end
|
||||
|
||||
theorem trunc_one_mul (g : G) : 1 * g = g :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
exact ap tr !one_mul
|
||||
end
|
||||
|
||||
theorem trunc_mul_one (g : G) : g * 1 = g :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
exact ap tr !mul_one
|
||||
end
|
||||
|
||||
theorem trunc_mul_left_inv (g : G) : g⁻¹ * g = 1 :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
exact ap tr !mul_left_inv
|
||||
end
|
||||
|
||||
theorem trunc_mul_comm (mul_comm : ∀a b, mul a b = mul b a) (g h : G)
|
||||
: g * h = h * g :=
|
||||
begin
|
||||
apply trunc.rec_on g, intro p,
|
||||
apply trunc.rec_on h, intro q,
|
||||
exact ap tr !mul_comm
|
||||
end
|
||||
|
||||
parameters (mul_assoc) (one_mul) (mul_one) (mul_left_inv) {A}
|
||||
|
||||
definition trunc_group [constructor] : group G :=
|
||||
⦃group,
|
||||
mul := trunc_mul,
|
||||
mul_assoc := trunc_mul_assoc,
|
||||
one := trunc_one,
|
||||
one_mul := trunc_one_mul,
|
||||
mul_one := trunc_mul_one,
|
||||
inv := trunc_inv,
|
||||
mul_left_inv := trunc_mul_left_inv,
|
||||
is_set_carrier := _⦄
|
||||
|
||||
|
||||
definition trunc_comm_group [constructor] (mul_comm : ∀a b, mul a b = mul b a) : comm_group G :=
|
||||
⦃comm_group, trunc_group, mul_comm := trunc_mul_comm mul_comm⦄
|
||||
|
||||
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 apd), 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 apd011 (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 apd0111 (f : Πa b, C a b → Z) (Ha : a = a') (Hb : transport B Ha b = b')
|
||||
(Hc : cast (apd011 C Ha Hb) c = c')
|
||||
: f a b c = f a' b' c' :=
|
||||
by cases Ha; cases Hb; cases Hc; reflexivity
|
||||
|
||||
definition apd01111 (f : Πa b c, D a b c → 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')
|
||||
: f a b c d = f a' b' c' d' :=
|
||||
by cases Ha; cases Hb; cases Hc; cases Hd; reflexivity
|
||||
|
||||
definition apd011111 (f : Πa b c d, E a b c d → 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')
|
||||
: 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 apd0111111 (f : Πa b c d e, F a b c d e → 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')
|
||||
: 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
|
||||
181
hott/book.md
181
hott/book.md
|
|
@ -1,181 +0,0 @@
|
|||
HoTT Book in Lean
|
||||
=================
|
||||
|
||||
This file lists which sections of the [HoTT book](http://homotopytypetheory.org/book/) have been covered in the Lean [HoTT library](hott.md).
|
||||
|
||||
Summary
|
||||
-------
|
||||
|
||||
The rows indicate the chapters, the columns the sections.
|
||||
|
||||
* `+`: completely formalized
|
||||
* `¼`, `½` or `¾`: partly formalized
|
||||
* `-`: not formalized
|
||||
* `.`: no formalizable content
|
||||
|
||||
| | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 |
|
||||
|-------|---|---|---|---|---|---|---|---|---|----|----|----|----|----|----|
|
||||
| Ch 1 | . | . | . | . | + | + | + | + | + | . | + | + | | | |
|
||||
| Ch 2 | + | + | + | + | . | + | + | + | + | + | + | + | + | + | + |
|
||||
| Ch 3 | + | + | + | + | ½ | + | + | + | + | . | + | | | | |
|
||||
| Ch 4 | - | + | + | + | . | + | ½ | + | + | | | | | | |
|
||||
| Ch 5 | - | . | ½ | - | - | . | . | ½ | | | | | | | |
|
||||
| Ch 6 | . | + | + | + | + | ½ | ½ | + | ¾ | ¼ | ¾ | + | . | | |
|
||||
| Ch 7 | + | + | + | - | ¾ | - | - | | | | | | | | |
|
||||
| Ch 8 | + | + | + | - | ¼ | ¼ | - | - | - | - | | | | | |
|
||||
| Ch 9 | ¾ | + | + | ½ | ¾ | ½ | - | - | - | | | | | | |
|
||||
| Ch 10 | - | - | - | - | - | | | | | | | | | | |
|
||||
| Ch 11 | - | - | - | - | - | - | | | | | | | | | |
|
||||
|
||||
Theorems and definitions in the library which are not in the book:
|
||||
|
||||
* A major difference is that in this library we heavily use pathovers [D. Licata, G. Brunerie. A Cubical Approach to Synthetic Homotopy Theory]. This means that we need less theorems about transports, but instead corresponding theorems about pathovers. These are in [init.pathover](init/pathover.hlean). For higher paths there are [squares](cubical/square.hlean), [squareovers](cubical/squareover.hlean), and the rudiments of [cubes](cubical/cube.hlean) and [cubeovers](cubical/cubeover.hlean).
|
||||
|
||||
* The category theory library is more extensive than what is presented in the book. For example, we have [limits](algebra/category/limits/limits.md).
|
||||
|
||||
Chapter 1: Type theory
|
||||
---------
|
||||
|
||||
- 1.1 (Type theory versus set theory): no formalizable content.
|
||||
- 1.2 (Function types): no formalizable content. Related: [init.function](init/function.hlean)
|
||||
- 1.3 (Universes and families): no formalizable content (Lean also has a hierarchy of universes `Type.{i} : Type.{i + 1}`, but they are *not* cumulative).
|
||||
- 1.4 (Dependent function types (Π-types)): no formalizable content. Related: [init.function](init/function.hlean)
|
||||
- 1.5 (Product types): declaration in [init.datatypes](init/datatypes.hlean), notation in [init.types](init/types.hlean)
|
||||
- 1.6 (Dependent pair types (Σ-types)): declaration in [init.datatypes](init/datatypes.hlean), notation in [init.types](init/types.hlean)
|
||||
- 1.7 (Coproduct types): declaration in [init.datatypes](init/datatypes.hlean), notation in [init.types](init/types.hlean)
|
||||
- 1.8 (The type of booleans): declaration in [init.datatypes](init/datatypes.hlean), notation in [init.bool](init/bool.hlean)
|
||||
- 1.9 (The natural numbers): [init.nat](init/nat.hlean) (declaration in [init.datatypes](init/datatypes.hlean))
|
||||
- 1.10 (Pattern matching and recursion): no formalizable content (we can use the "pattern matching" notation using the function definition package, which are reduced to applying recursors).
|
||||
- 1.11 (Propositions as types): some logic is in [init.logic](init/logic.hlean) and [init.types](init/types.hlean).
|
||||
- 1.12 (Identity types): declaration in [init.datatypes](init/datatypes.hlean), more in [init.logic](init/logic.hlean)
|
||||
|
||||
Chapter 2: Homotopy type theory
|
||||
---------
|
||||
|
||||
- 2.1 (Types are higher groupoids): [init.path](init/path.hlean) (pointed types and loop spaces in [types.pointed](types/pointed.hlean))
|
||||
- 2.2 (Functions are functors): [init.path](init/path.hlean)
|
||||
- 2.3 (Type families are fibrations): [init.path](init/path.hlean)
|
||||
- 2.4 (Homotopies and equivalences): homotopies in [init.path](init/path.hlean) and equivalences in [init.equiv](init/equiv.hlean)
|
||||
- 2.5 (The higher groupoid structure of type formers): no formalizable content
|
||||
- 2.6 (Cartesian product types): [types.prod](types/prod.hlean)
|
||||
- 2.7 (Σ-types): [types.sigma](types/sigma.hlean)
|
||||
- 2.8 (The unit type): special case of [init.trunc](init/trunc.hlean)
|
||||
- 2.9 (Π-types and the function extensionality axiom): [init.funext](init/funext.hlean), [types.pi](types/pi.hlean) and [types.arrow](types/arrow.hlean)
|
||||
- 2.10 (Universes and the univalence axiom): [init.ua](init/ua.hlean)
|
||||
- 2.11 (Identity type): [init.equiv](init/equiv.hlean) (ap is an equivalence), [types.eq](types/eq.hlean) and [cubical.square](cubical/square.hlean) (characterization of pathovers in equality types)
|
||||
- 2.12 (Coproducts): [types.sum](types/sum.hlean)
|
||||
- 2.13 (Natural numbers): [types.nat.hott](types/nat/hott.hlean)
|
||||
- 2.14 (Example: equality of structures): algebra formalized in [algebra.group](algebra/group.hlean).
|
||||
- 2.15 (Universal properties): in the corresponding file in the [types](types/types.md) folder.
|
||||
|
||||
Chapter 3: Sets and logic
|
||||
---------
|
||||
|
||||
- 3.1 (Sets and n-types): [init.trunc](init/trunc.hlean). Example 3.1.9 in [types.univ](types/univ.hlean)
|
||||
- 3.2 (Propositions as types?): [types.univ](types/univ.hlean)
|
||||
- 3.3 (Mere propositions): [init.trunc](init/trunc.hlean) and [prop_trunc](prop_trunc.hlean) (Lemma 3.3.5).
|
||||
- 3.4 (Classical vs. intuitionistic logic): decidable is defined in [init.logic](init/logic.hlean)
|
||||
- 3.5 (Subsets and propositional resizing): Lemma 3.5.1 is subtype_eq in [types.sigma](types/sigma.hlean), we don't have propositional resizing as axiom yet.
|
||||
- 3.6 (The logic of mere propositions): in the corresponding file in the [types](types/types.md) folder. (is_trunc_prod is defined in [types.sigma](types/sigma.hlean))
|
||||
- 3.7 (Propositional truncation): [init.hit](init/hit.hlean) and [hit.trunc](hit/trunc.hlean)
|
||||
- 3.8 (The axiom of choice): [choice](choice.hlean)
|
||||
- 3.9 (The principle of unique choice): Lemma 9.3.1 in [hit.trunc](hit/trunc.hlean), Lemma 9.3.2 in [types.trunc](types/trunc.hlean)
|
||||
- 3.10 (When are propositions truncated?): no formalizable content
|
||||
- 3.11 (Contractibility): [init.trunc](init/trunc.hlean) (mostly), [types.pi](types/pi.hlean) (Lemma 3.11.6), [types.trunc](types/trunc.hlean) (Lemma 3.11.7), [types.sigma](types/sigma.hlean) (Lemma 3.11.9)
|
||||
|
||||
Chapter 4: Equivalences
|
||||
---------
|
||||
|
||||
- 4.1 (Quasi-inverses): not formalized
|
||||
- 4.2 (Half adjoint equivalences): [init.equiv](init/equiv.hlean) and [types.equiv](types/equiv.hlean)
|
||||
- 4.3 (Bi-invertible maps): [function](function.hlean) ("biinv f" is "is_retraction f × is_section f")
|
||||
- 4.4 (Contractible fibers): [types.equiv](types/equiv.hlean)
|
||||
- 4.5 (On the definition of equivalences): no formalizable content
|
||||
- 4.6 (Surjections and embeddings): [function](function.hlean)
|
||||
- 4.7 (Closure properties of equivalences): 4.7.1 in [init.equiv](init/equiv.hlean); 4.7.2 in [function](function.hlean); 4.7.5 and 4.7.7 in [types.sigma](types/sigma.hlean) (sigma_functor is a generalization of total(f)); and 4.7.6 in 4.7.6 in [types.fiber](types/fiber.hlean).
|
||||
- 4.8 (The object classifier): 4.8.1 and 4.8.2 in [types.fiber](types/fiber.hlean); 4.8.3 and 4.8.4 in [types.univ](types/univ.hlean)
|
||||
- 4.9 (Univalence implies function extensionality): [init.funext](init/funext.hlean)
|
||||
|
||||
Chapter 5: Induction
|
||||
---------
|
||||
|
||||
- 5.1 (Introduction to inductive types): not formalized
|
||||
- 5.2 (Uniqueness of inductive types): no formalizable content
|
||||
- 5.3 (W-types): [types.W](types/W.hlean) defines W-types.
|
||||
- 5.4 (Inductive types are initial algebras): not formalized
|
||||
- 5.5 (Homotopy-inductive types): not formalized
|
||||
- 5.6 (The general syntax of inductive definitions): no formalizable content
|
||||
- 5.7 (Generalizations of inductive types): no formalizable content. Lean has inductive families and mutual induction, but no induction-induction or induction-recursion
|
||||
- 5.8 (Identity types and identity systems): 5.8.1-5.8.4 not formalized, 5.8.5 in [init.ua](init/ua.hlean) and 5.8.6 in [init.funext](init/funext.hlean)
|
||||
|
||||
Chapter 6: Higher inductive types
|
||||
---------
|
||||
|
||||
- 6.1 (Introduction): no formalizable content
|
||||
- 6.2 (Induction principles and dependent paths): dependent paths in [init.pathover](init/pathover.hlean), circle in [homotopy.circle](homotopy/circle.hlean)
|
||||
- 6.3 (The interval): [homotopy.interval](homotopy/interval.hlean)
|
||||
- 6.4 (Circles and spheres): [homotopy.sphere](homotopy/sphere.hlean) and [homotopy.circle](homotopy/circle.hlean)
|
||||
- 6.5 (Suspensions): [homotopy.suspension](homotopy/susp.hlean) (we define the circle to be the suspension of bool, but Lemma 6.5.1 is similar to proving the ordinary induction principle for the circle in [homotopy.circle](homotopy/circle.hlean)) and a bit in [homotopy.sphere](homotopy/sphere.hlean) and [types.pointed](types/pointed.hlean)
|
||||
- 6.6 (Cell complexes): we define the torus using the quotient, see [hit.two_quotient](hit/two_quotient.hlean) and [homotopy.torus](homotopy/torus.hlean) (no dependent eliminator defined yet)
|
||||
- 6.7 (Hubs and spokes): [hit.two_quotient](hit/two_quotient.hlean) and [homotopy.torus](homotopy/torus.hlean) (no dependent eliminator defined yet)
|
||||
- 6.8 (Pushouts): [hit.pushout](hit/pushout.hlean). Some of the "standard homotopy-theoretic constructions" have separate files, although not all of them have been defined explicitly yet
|
||||
- 6.9 (Truncations): [hit.trunc](hit/trunc.hlean) (except Lemma 6.9.3)
|
||||
- 6.10 (Quotients): [hit.set_quotient](hit/set_quotient.hlean) (up to 6.10.3). We define integers differently, to make them compute, in the folder [types.int](types/int/int.md). 6.10.13 is in [types.int.hott](types/int/hott.hlean)
|
||||
- 6.11 (Algebra): [algebra.group](algebra/group.hlean), [algebra.homotopy_group](algebra/homotopy_group.hlean)
|
||||
- 6.12 (The flattening lemma): [hit.quotient](hit/quotient.hlean) (for quotients instead of homotopy coequalizers, but these are practically the same)
|
||||
- 6.13 (The general syntax of higher inductive definitions): no formalizable content
|
||||
|
||||
Chapter 7: Homotopy n-types
|
||||
---------
|
||||
|
||||
- 7.1 (Definition of n-types): [init.trunc](init/trunc.hlean), [types.trunc](types/trunc.hlean), [types.sigma](types/sigma.hlean) (Theorem 7.1.8), [types.pi](types/pi.hlean) (Theorem 7.1.9), [prop_trunc](prop_trunc.hlean) (Theorem 7.1.10)
|
||||
- 7.2 (Uniqueness of identity proofs and Hedberg’s theorem): [init.hedberg](init/hedberg.hlean) and [types.trunc](types/trunc.hlean)
|
||||
- 7.3 (Truncations): [init.hit](init/hit.hlean), [hit.trunc](hit/trunc.hlean) and [types.trunc](types/trunc.hlean)
|
||||
- 7.4 (Colimits of n-types): not formalized
|
||||
- 7.5 (Connectedness): [homotopy.connectedness](homotopy/connectedness.hlean) (the main "induction principle" Lemma 7.5.7)
|
||||
- 7.6 (Orthogonal factorization): not formalized
|
||||
- 7.7 (Modalities): not formalized, and may be unformalizable in general because it's unclear how to define modalities
|
||||
|
||||
Chapter 8: Homotopy theory
|
||||
---------
|
||||
|
||||
Unless otherwise noted, the files are in the folder [homotopy](homotopy/homotopy.md)
|
||||
|
||||
- 8.1 (π_1(S^1)): [homotopy.circle](homotopy/circle.hlean) (only the encode-decode proof)
|
||||
- 8.2 (Connectedness of suspensions): [homotopy.connectedness](homotopy/connectedness.hlean) (different proof)
|
||||
- 8.3 (πk≤n of an n-connected space and π_{k<n}(S^n)): [homotopy.homotopy_group](homotopy/homotopy_group.hlean)
|
||||
- 8.4 (Fiber sequences and the long exact sequence): not formalized
|
||||
- 8.5 (The Hopf fibration): [homotopy.circle](homotopy/circle.hlean) (H-space structure on the circle, Lemma 8.5.8), [homotopy.join](homotopy/join.hlean) (join is associative, Lemma 8.5.9), the rest is not formalized
|
||||
- 8.6 (The Freudenthal suspension theorem): [homotopy.connectedness](homotopy/connectedness.hlean) (Lemma 8.6.1), [homotopy.wedge](homotopy/wedge.hlean) (Wedge connectivity, Lemma 8.6.2), the rest is not formalized
|
||||
- 8.7 (The van Kampen theorem): not formalized
|
||||
- 8.8 (Whitehead’s theorem and Whitehead’s principle): not formalized
|
||||
- 8.9 (A general statement of the encode-decode method): not formalized
|
||||
- 8.10 (Additional Results): not formalized
|
||||
|
||||
Chapter 9: Category theory
|
||||
---------
|
||||
|
||||
Every file is in the folder [algebra.category](algebra/category/category.md)
|
||||
|
||||
- 9.1 (Categories and precategories): [precategory](algebra/category/precategory.hlean), [iso](algebra/category/iso.hlean), [category](algebra/category/category.hlean), [groupoid](algebra/category/groupoid.hlean) (mostly)
|
||||
- 9.2 (Functors and transformations): [functor.basic](algebra/category/functor/basic.hlean), [nat_trans](algebra/category/nat_trans.hlean), [constructions.functor](algebra/category/constructions/functor.hlean)
|
||||
- 9.3 (Adjunctions): [functor.adjoint](algebra/category/functor/adjoint.hlean)
|
||||
- 9.4 (Equivalences): [functor.equivalence](algebra/category/functor/equivalence.hlean) and [functor.attributes](algebra/category/functor/attributes.hlean) (partially)
|
||||
- 9.5 (The Yoneda lemma): [constructions.opposite](algebra/category/constructions/opposite.hlean), [constructions.product](algebra/category/constructions/product.hlean), [functor.yoneda](algebra/category/functor/yoneda.hlean) (up to Theorem 9.5.9)
|
||||
- 9.6 (Strict categories): [strict](algebra/category/strict.hlean) (only definition)
|
||||
- 9.7 (†-categories): not formalized
|
||||
- 9.8 (The structure identity principle): not formalized
|
||||
- 9.9 (The Rezk completion): not formalized
|
||||
|
||||
Chapter 10: Set theory
|
||||
----------
|
||||
|
||||
Not formalized, and parts may be unformalizable because Lean lacks induction-recursion.
|
||||
|
||||
|
||||
Chapter 11: Real numbers
|
||||
----------
|
||||
|
||||
- 11.1 (The field of rational numbers): To be ported from the standard library.
|
||||
|
||||
The rest is not formalized, and parts may be unformalizable because Lean lacks induction-induction
|
||||
|
|
@ -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,12 +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
|
||||
import cubical
|
||||
import homotopy.circle
|
||||
import algebra.hott
|
||||
|
|
@ -1,304 +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 [unfold 7]
|
||||
{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
|
||||
|
||||
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,128 +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 apo011_eq_apo11_apdo (f : Πa, B a → A') (p : a = a₂) (q : b =[p] b₂)
|
||||
: apo011 f p q = eq_of_pathover (apo11 (apdo 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 apdo_ap {B : A' → Type} (g : Πb, B b) (f : A → A') (p : a = a₂)
|
||||
: apdo g (ap f p) = pathover_ap B f (apdo (λx, g (f x)) p) :=
|
||||
by induction p; reflexivity
|
||||
|
||||
definition apdo_eq_apdo_ap {B : A' → Type} (g : Πb, B b) (f : A → A') (p : a = a₂)
|
||||
: apdo (λx, g (f x)) p = pathover_of_pathover_ap B f (apdo 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 apdo_constant (b : B'' a') (p : a = a) :
|
||||
pathover_ap B'' (λa, a') (apdo (λa, b) p) = change_path (ap_constant p a')⁻¹ idpo :=
|
||||
begin
|
||||
rewrite [apdo_eq_apdo_ap _ _ p],
|
||||
let y := !change_path_of_pathover (apdo (apdo 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 apdo_change_path {B : A → Type} {a a₂ : A} (f : Πa, B a) {p p' : a = a₂} (s : p = p')
|
||||
: apdo f p' = change_path s (apdo 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
|
||||
|
||||
end eq
|
||||
|
|
@ -1,552 +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 cases p; reflexivity
|
||||
|
||||
definition vdeg_square_idp (p : a = a') : vdeg_square (refl p) = vrfl :=
|
||||
by cases p; 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 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 `:75 := hconcat --type using \tr
|
||||
infix ` ⬝v `:75 := vconcat --type using \tr
|
||||
infix ` ⬝hp `:75 := hconcat_eq --type using \tr
|
||||
infix ` ⬝vp `:75 := vconcat_eq --type using \tr
|
||||
infix ` ⬝ph `:75 := eq_hconcat --type using \tr
|
||||
infix ` ⬝pv `:75 := 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] {B : Type} (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
|
||||
|
||||
definition natural_square [unfold 8] {f g : A → B} (p : f ~ g) (q : a = a') :
|
||||
square (ap f q) (ap g q) (p a) (p a') :=
|
||||
eq.rec_on q hrfl
|
||||
|
||||
definition natural_square_tr [unfold 8] {f g : A → B} (p : f ~ g) (q : a = a') :
|
||||
square (p a) (p a') (ap f q) (ap g q) :=
|
||||
eq.rec_on q vrfl
|
||||
|
||||
/- 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 :=
|
||||
by induction p;apply pathover_idp_of_eq;exact eq_of_vdeg_square s
|
||||
|
||||
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
|
||||
|
||||
/- 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 r p₂₁ ⬝ 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 r p₁₂)⁻¹ :=
|
||||
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 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 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 {A B : Type} {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 {A B : Type} {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 {A B : Type} {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
|
||||
|
||||
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_tr 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,280 +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
|
||||
|
||||
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 (apdo f p₁₀) (apdo f p₁₂) (apdo f p₀₁) (apdo 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₁₁
|
||||
|
||||
-- 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)
|
||||
(apdo f p) (apdo 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_tr q p) r r₂
|
||||
(pathover_ap B f (apdo b p)) (pathover_ap B g (apdo 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
|
||||
|
||||
end eq
|
||||
122
hott/eq2.hlean
122
hott/eq2.hlean
|
|
@ -1,122 +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 (apdo 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
|
||||
|
||||
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 (ap_compose g f) r
|
||||
|
||||
theorem whisker_right_eq_of_con_inv_eq_idp {p q : a₁ = a₂} (r : p ⬝ q⁻¹ = idp) :
|
||||
whisker_right (eq_of_con_inv_eq_idp r) q⁻¹ ⬝ 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_apdo_eq {A : Type} {B : A → Type} {a a₂ : A} {f g : Πa, B a}
|
||||
(H : f ~ g) (p : a = a₂)
|
||||
: apdo f p = concato_eq (eq_concato (H a) (apdo 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
|
||||
|
||||
|
||||
end eq
|
||||
|
|
@ -1,264 +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 : Type} (f : A → B) {b : B}
|
||||
|
||||
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), ∥ fiber 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) :=
|
||||
by unfold is_surjective; exact _
|
||||
|
||||
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 B n 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
|
||||
|
||||
/-
|
||||
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 .quotient_functor types.equiv
|
||||
|
||||
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) : apdo (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 [▸*,-apdo_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,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
|
||||
|
||||
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)) : apdo (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 [▸*,-apdo_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)
|
||||
: apdo (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 [▸*,-apdo_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
|
||||
|
||||
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,26 +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
|
||||
|
||||
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
|
||||
|
|
@ -1,55 +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, Floris van Doorn
|
||||
|
||||
Pointed Pushouts
|
||||
-/
|
||||
import .pushout types.pointed2
|
||||
|
||||
open eq pushout
|
||||
|
||||
namespace pointed
|
||||
|
||||
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 pointed
|
||||
|
||||
open pointed pType
|
||||
|
||||
namespace pushout
|
||||
section
|
||||
parameters {TL BL TR : Type*} (f : TL →* BL) (g : TL →* TR)
|
||||
|
||||
definition ppushout [constructor] : Type* :=
|
||||
pointed.mk' (pushout f g)
|
||||
|
||||
parameters {f g}
|
||||
definition pinl [constructor] : BL →* ppushout :=
|
||||
pmap.mk inl idp
|
||||
|
||||
definition pinr [constructor] : TR →* ppushout :=
|
||||
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
|
||||
|
||||
definition prec {P : ppushout → Type} (Pinl : Π x, P (pinl x)) (Pinr : Π x, P (pinr x))
|
||||
(H : Π x, Pinl (f x) =[pglue x] Pinr (g x)) : (Π y, P y) :=
|
||||
pushout.rec Pinl Pinr H
|
||||
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,234 +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 pushout
|
||||
-/
|
||||
|
||||
import .quotient cubical.square types.sigma
|
||||
|
||||
open quotient eq sum equiv is_trunc
|
||||
|
||||
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) : apdo (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 [▸*,-apdo_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)) (y : pushout) : Type :=
|
||||
elim Pinl Pinr (λx, ua (Pglue x)) y
|
||||
|
||||
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 :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑elim_type,elim_glue];apply cast_ua_fn
|
||||
|
||||
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
|
||||
|
||||
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 ⟩
|
||||
|
||||
local abbreviation Pglue' : Π ⦃a a' : A⦄,
|
||||
R a a' → sum.rec Pinl Pinr a ≃ sum.rec Pinl Pinr a' :=
|
||||
@pushout_rel.rec TL BL TR f g
|
||||
(λ ⦃a a' ⦄ (r : R a a'),
|
||||
(sum.rec Pinl Pinr a) ≃ (sum.rec Pinl Pinr a')) Pglue
|
||||
|
||||
protected definition flattening : sigma P ≃ pushout F G :=
|
||||
begin
|
||||
have H : Πz, P z ≃ quotient.elim_type (sum.rec Pinl Pinr) Pglue' z,
|
||||
begin
|
||||
intro z, apply equiv_of_eq,
|
||||
have H1 : pushout.elim_type Pinl Pinr Pglue
|
||||
= quotient.elim_type (sum.rec Pinl Pinr) Pglue',
|
||||
begin
|
||||
change
|
||||
quotient.rec (sum.rec Pinl Pinr)
|
||||
(λa a' r, pushout_rel.cases_on r (λx, pathover_of_eq (ua (Pglue x))))
|
||||
= quotient.rec (sum.rec Pinl Pinr)
|
||||
(λa a' r, pathover_of_eq (ua (pushout_rel.cases_on r Pglue))),
|
||||
have H2 : Π⦃a a'⦄ r : pushout_rel f g a a',
|
||||
pushout_rel.cases_on r (λx, pathover_of_eq (ua (Pglue x)))
|
||||
= pathover_of_eq (ua (pushout_rel.cases_on r Pglue))
|
||||
:> sum.rec Pinl Pinr a =[eq_of_rel (pushout_rel f g) r]
|
||||
sum.rec Pinl Pinr a',
|
||||
begin intros a a' 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 R (sum.rec Pinl Pinr) Pglue'),
|
||||
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 [constructor] : 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
|
||||
|
||||
end pushout
|
||||
|
|
@ -1,200 +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
|
||||
|
||||
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 [▸*,-apdo_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
|
||||
|
||||
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, apdo 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 apd 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 ⬝ _,
|
||||
rewrite [apo011_eq_apo11_apdo, rec_eq_of_rel, ▸*, apo011_arrow_pathover_constant_right,
|
||||
↑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
|
||||
|
||||
end quotient
|
||||
|
|
@ -1,116 +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
|
||||
|
||||
Functoriality of quotients and a condition for when an equivalence is induced.
|
||||
-/
|
||||
|
||||
import types.sigma .quotient
|
||||
open eq is_equiv equiv prod prod.ops sigma sigma.ops
|
||||
|
||||
namespace quotient
|
||||
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
|
||||
|
||||
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 (λ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 (λ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')
|
||||
: apdo (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') : apdo (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 [▸*,-apdo_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 10 11] (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} (A B : Type) (n : trunc_index)
|
||||
|
||||
local attribute is_trunc_eq [instance]
|
||||
|
||||
variables {A n}
|
||||
definition untrunc_of_is_trunc [reducible] [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,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
|
||||
-/
|
||||
|
||||
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 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
|
||||
-/
|
||||
|
||||
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')
|
||||
: apdo (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 [▸*,-apdo_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')
|
||||
: apdo (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 apdo_compose2 (pre_rec P0 _ _) (f q) loop,
|
||||
apply ap (pathover_of_pathover_ap _ _),
|
||||
transitivity _, apply apdo_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, apdo_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')
|
||||
: apdo (rec P0 P1 P2) (incl1 s) = P1 s :=
|
||||
begin
|
||||
unfold [rec, incl1], refine !apdo_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')
|
||||
: apdo (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
|
||||
|
||||
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_apdo_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
|
||||
|
||||
attribute simple_two_quotient.j [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_con (simple_two_quotient.incl1 R Q2) P1,
|
||||
elimo_inv (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') : apdo (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') : apdo (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 :=
|
||||
!elim_inclt
|
||||
|
||||
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]
|
||||
|
|
@ -1,57 +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
|
||||
|
||||
-- this should be in init!
|
||||
namespace nat
|
||||
|
||||
definition cases {M : ℕ → Type} (mz : M zero) (ms : Πn, M (succ n)) : Πn, M n :=
|
||||
nat.rec mz (λn dummy, ms n)
|
||||
|
||||
end nat
|
||||
|
||||
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,315 +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.bool types.int.hott types.equiv
|
||||
import algebra.homotopy_group algebra.hott .connectedness
|
||||
|
||||
open eq susp bool sphere_index is_equiv equiv is_trunc pi algebra homotopy
|
||||
|
||||
definition circle : Type₀ := sphere 1
|
||||
|
||||
namespace circle
|
||||
notation `S¹` := circle
|
||||
definition base1 : circle := !north
|
||||
definition base2 : circle := !south
|
||||
definition seg1 : base1 = base2 := merid !north
|
||||
definition seg2 : base1 = base2 := merid !south
|
||||
|
||||
definition base : circle := base1
|
||||
definition loop : base = base := seg2 ⬝ seg1⁻¹
|
||||
|
||||
definition rec2 {P : circle → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2) (x : circle) : 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 : circle → Type} (x : circle) (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 : circle → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2)
|
||||
: apdo (rec2 Pb1 Pb2 Ps1 Ps2) seg1 = Ps1 :=
|
||||
!rec_merid
|
||||
|
||||
theorem rec2_seg2 {P : circle → Type} (Pb1 : P base1) (Pb2 : P base2)
|
||||
(Ps1 : Pb1 =[seg1] Pb2) (Ps2 : Pb1 =[seg2] Pb2)
|
||||
: apdo (rec2 Pb1 Pb2 Ps1 Ps2) seg2 = Ps2 :=
|
||||
!rec_merid
|
||||
|
||||
definition elim2 {P : Type} (Pb1 Pb2 : P) (Ps1 Ps2 : Pb1 = Pb2) (x : circle) : P :=
|
||||
rec2 Pb1 Pb2 (pathover_of_eq Ps1) (pathover_of_eq Ps2) x
|
||||
|
||||
definition elim2_on [reducible] {P : Type} (x : circle) (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 [▸*,-apdo_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 [▸*,-apdo_eq_pathover_of_eq_ap,↑elim2,rec2_seg2],
|
||||
end
|
||||
|
||||
definition elim2_type (Pb1 Pb2 : Type) (Ps1 Ps2 : Pb1 ≃ Pb2) (x : circle) : Type :=
|
||||
elim2 Pb1 Pb2 (ua Ps1) (ua Ps2) x
|
||||
|
||||
definition elim2_type_on [reducible] (x : circle) (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 : circle → Type} (Pbase : P base) (Ploop : Pbase =[loop] Pbase)
|
||||
(x : circle) : 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 : circle → Type} (x : circle) (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 : circle → Type} (Pbase : P base) (Ploop : Pbase =[loop] Pbase) :
|
||||
apdo (circle.rec Pbase Ploop) loop = Ploop :=
|
||||
begin
|
||||
rewrite [↑loop,apdo_con,↑circle.rec,↑circle.rec2_on,↑base,rec2_seg2,apdo_inv,rec2_seg1],
|
||||
apply rec_loop_helper
|
||||
end
|
||||
|
||||
protected definition elim {P : Type} (Pbase : P) (Ploop : Pbase = Pbase)
|
||||
(x : circle) : P :=
|
||||
circle.rec Pbase (pathover_of_eq Ploop) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : circle) (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 [▸*,-apdo_eq_pathover_of_eq_ap,↑circle.elim,rec_loop],
|
||||
end
|
||||
|
||||
protected definition elim_type (Pbase : Type) (Ploop : Pbase ≃ Pbase)
|
||||
(x : circle) : Type :=
|
||||
circle.elim Pbase (ua Ploop) x
|
||||
|
||||
protected definition elim_type_on [reducible] (x : circle) (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,circle.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
|
||||
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 nonidp (x : circle) : x = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact loop},
|
||||
{ apply concato_eq, apply pathover_eq_lr, rewrite [con.left_inv,idp_con]}
|
||||
end
|
||||
|
||||
definition nonidp_neq_idp : nonidp ≠ (λx, idp) :=
|
||||
assume H : nonidp = λx, idp,
|
||||
have H2 : loop = idp, from apd10 H base,
|
||||
absurd H2 loop_neq_idp
|
||||
|
||||
open int
|
||||
|
||||
protected definition code [unfold 1] (x : circle) : 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 : circle} (p : base = x) : circle.code x :=
|
||||
transport circle.code p (of_num 0)
|
||||
|
||||
protected definition decode [unfold 1] {x : circle} : circle.code x → base = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact power loop},
|
||||
{ apply arrow_pathover_left, intro b, apply concato_eq, apply pathover_eq_r,
|
||||
rewrite [power_con,transport_code_loop]}
|
||||
end
|
||||
|
||||
definition circle_eq_equiv [constructor] (x : circle) : (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 ⬝ circle.decode b = circle.decode (a +[ℤ] 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
|
||||
|
||||
definition fg_carrier_equiv_int : π[1](S¹.) ≃ ℤ :=
|
||||
trunc_equiv_trunc 0 base_eq_base_equiv ⬝e @(trunc_equiv ℤ _) 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¹.) = group_integers :=
|
||||
begin
|
||||
apply (Group_eq 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+1 +1] S¹. = G0 :=
|
||||
begin
|
||||
refine @trivial_homotopy_add_of_is_set_loop_space 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
|
||||
|
||||
definition 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
|
||||
|
||||
definition is_conn_circle [instance] : is_conn 0 S¹ :=
|
||||
begin
|
||||
fapply is_contr.mk,
|
||||
{ exact tr base},
|
||||
{ intro x, induction x with x,
|
||||
induction x,
|
||||
{ reflexivity},
|
||||
{ apply is_prop.elimo}}
|
||||
end
|
||||
|
||||
definition circle_mul [reducible] (x y : S¹) : S¹ :=
|
||||
begin
|
||||
induction x,
|
||||
{ induction y,
|
||||
{ exact base },
|
||||
{ exact loop } },
|
||||
{ induction y,
|
||||
{ exact loop },
|
||||
{ apply eq_pathover, rewrite elim_loop,
|
||||
apply square_of_eq, reflexivity } }
|
||||
end
|
||||
|
||||
definition circle_mul_base (x : S¹) : circle_mul x base = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ reflexivity },
|
||||
{ apply eq_pathover, krewrite [elim_loop,ap_id], apply hrefl }
|
||||
end
|
||||
|
||||
definition circle_base_mul (x : S¹) : circle_mul base x = x :=
|
||||
begin
|
||||
induction x,
|
||||
{ reflexivity },
|
||||
{ apply eq_pathover, krewrite [elim_loop,ap_id], apply hrefl }
|
||||
end
|
||||
|
||||
end circle
|
||||
|
|
@ -1,99 +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.pointed_pushout function .susp
|
||||
|
||||
open eq pushout unit pointed is_trunc is_equiv susp unit
|
||||
|
||||
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 [constructor] : cofiber f := inl ⋆
|
||||
|
||||
protected definition cod [constructor] : B → cofiber f := inr
|
||||
|
||||
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
|
||||
|
||||
protected definition rec {A : Type} {B : Type} {f : A → B} {P : cofiber f → Type}
|
||||
(Pinl : P (inl ⋆)) (Pinr : Π (x : B), P (inr x))
|
||||
(Pglue : Π (x : A), pathover P Pinl (glue x) (Pinr (f x))) :
|
||||
(Π y, P y) :=
|
||||
begin
|
||||
intro y, induction y, induction x, exact Pinl, exact Pinr x, esimp, exact Pglue x,
|
||||
end
|
||||
|
||||
protected definition rec_on {A : Type} {B : Type} {f : A → B} {P : cofiber f → Type}
|
||||
(y : cofiber f) (Pinl : P (inl ⋆)) (Pinr : Π (x : B), P (inr x))
|
||||
(Pglue : Π (x : A), pathover P Pinl (glue x) (Pinr (f x))) : P y :=
|
||||
begin
|
||||
induction y, induction x, exact Pinl, exact Pinr x, esimp, exact Pglue x,
|
||||
end
|
||||
|
||||
end
|
||||
end cofiber
|
||||
|
||||
-- pointed version
|
||||
|
||||
definition pcofiber {A B : Type*} (f : A →* B) : Type* := ppushout (pconst A punit) f
|
||||
|
||||
namespace cofiber
|
||||
|
||||
protected definition prec {A B : Type*} {f : A →* B} {P : pcofiber f → Type}
|
||||
(Pinl : P (inl ⋆)) (Pinr : Π (x : B), P (inr x))
|
||||
(Pglue : Π (x : A), pathover P Pinl (pglue x) (Pinr (f x))) :
|
||||
(Π (y : pcofiber f), P y) :=
|
||||
begin
|
||||
intro y, induction y, induction x, exact Pinl, exact Pinr x, esimp, exact Pglue x
|
||||
end
|
||||
|
||||
protected definition prec_on {A B : Type*} {f : A →* B} {P : pcofiber f → Type}
|
||||
(y : pcofiber f) (Pinl : P (inl ⋆)) (Pinr : Π (x : B), P (inr x))
|
||||
(Pglue : Π (x : A), pathover P Pinl (pglue x) (Pinr (f x))) : P y :=
|
||||
begin
|
||||
induction y, induction x, exact Pinl, exact Pinr x, esimp, exact Pglue x
|
||||
end
|
||||
|
||||
protected definition pelim_on {A B C : Type*} {f : A →* B} (y : pcofiber f)
|
||||
(c : C) (g : B → C) (p : Π x, c = g (f x)) : C :=
|
||||
begin
|
||||
fapply pushout.elim_on y, exact (λ x, c), exact g, exact p
|
||||
end
|
||||
|
||||
--TODO more pointed recursors
|
||||
|
||||
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 [n, s], induction n, reflexivity,
|
||||
induction s, reflexivity, esimp, apply eq_pathover, apply hdeg_square,
|
||||
refine _ ⬝ !ap_id⁻¹, refine !(ap_compose (pushout.elim _ _ _)) ⬝ _,
|
||||
refine ap _ !elim_glue ⬝ _, apply elim_merid },
|
||||
end
|
||||
|
||||
end cofiber
|
||||
|
|
@ -1,286 +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
|
||||
-/
|
||||
import types.trunc types.arrow_2 .sphere
|
||||
|
||||
open eq is_trunc is_equiv nat equiv trunc function fiber funext pi
|
||||
|
||||
namespace homotopy
|
||||
|
||||
definition is_conn [reducible] (n : ℕ₋₂) (A : Type) : Type :=
|
||||
is_contr (trunc n A)
|
||||
|
||||
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
|
||||
|
||||
definition is_conn_map (n : ℕ₋₂) {A B : Type} (f : A → B) : Type :=
|
||||
Πb : B, is_conn n (fiber f b)
|
||||
|
||||
namespace is_conn_map
|
||||
section
|
||||
parameters {n : ℕ₋₂} {A B : Type} {h : A → B}
|
||||
(H : is_conn_map n h) (P : B → n -Type)
|
||||
|
||||
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_map n f) (P : B → (n +2+ k)-Type)
|
||||
|
||||
include H
|
||||
-- Lemma 8.6.1
|
||||
proposition elim_general : is_trunc_fun k (pi_functor_left f P) :=
|
||||
begin
|
||||
intro t,
|
||||
induction k with k IH,
|
||||
{ apply is_contr_fiber_of_is_equiv, apply is_conn_map.rec, exact H },
|
||||
{ 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, trunctype.mk (g b = h b)
|
||||
(@is_trunc_eq (P b) (n +2+ k) (trunctype.struct (P 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_map 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_map
|
||||
|
||||
-- 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_map n (λx : A, unit.star) → is_conn n A :=
|
||||
begin
|
||||
intro H, unfold is_conn_map at H,
|
||||
rewrite [-(ua (fiber.fiber_star_equiv A))],
|
||||
exact (H unit.star)
|
||||
end
|
||||
|
||||
-- now maps from unit
|
||||
definition is_conn_of_map_from_unit (a₀ : A) (H : is_conn_map 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_map_from_unit (a₀ : A) [H : is_conn n .+1 A]
|
||||
: is_conn_map 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 → n-Type)
|
||||
|
||||
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))
|
||||
(λs x, s (Point A)) (λf, f unit.star)
|
||||
(is_conn_map.rec (is_conn_map_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 → (n +2+ k)-Type)
|
||||
|
||||
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 (to_fun (arrow_unit_left (P (Point A))))))
|
||||
(is_conn_map.elim_general (is_conn_map_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_map -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_map -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_map n f] : is_conn_map 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_map n f) : is_conn_map 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 minus_two_conn [instance] (A : Type) : is_conn -2 A :=
|
||||
_
|
||||
|
||||
-- Theorem 8.2.1
|
||||
open susp
|
||||
|
||||
theorem is_conn_susp [instance] (n : ℕ₋₂) (A : Type)
|
||||
[H : is_conn n A] : is_conn (n .+1) (susp A) :=
|
||||
is_contr.mk (tr north)
|
||||
begin
|
||||
apply trunc.rec,
|
||||
fapply susp.rec,
|
||||
{ reflexivity },
|
||||
{ exact (trunc.rec (λa, ap tr (merid a)) (center (trunc n A))) },
|
||||
{ intro a,
|
||||
generalize (center (trunc n A)),
|
||||
apply trunc.rec,
|
||||
intro a',
|
||||
apply pathover_of_tr_eq,
|
||||
rewrite [transport_eq_Fr,idp_con],
|
||||
revert H, induction n with [n, IH],
|
||||
{ intro H, apply is_prop.elim },
|
||||
{ intros H,
|
||||
change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a'),
|
||||
generalize a',
|
||||
apply is_conn_map.elim
|
||||
(is_conn_map_from_unit n A a)
|
||||
(λx : A, trunctype.mk' n (ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid x))),
|
||||
intros,
|
||||
change ap (@tr n .+2 (susp A)) (merid a) = ap tr (merid a),
|
||||
reflexivity
|
||||
}
|
||||
}
|
||||
end
|
||||
|
||||
open trunc_index
|
||||
-- Corollary 8.2.2
|
||||
theorem is_conn_sphere [instance] (n : ℕ₋₁) : is_conn (n..-1) (sphere n) :=
|
||||
begin
|
||||
induction n with n IH,
|
||||
{ apply minus_two_conn},
|
||||
{ rewrite [succ_sub_one, sphere.sphere_succ], apply is_conn_susp}
|
||||
end
|
||||
|
||||
end homotopy
|
||||
|
|
@ -1,95 +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
|
||||
|
||||
open quotient eq sum equiv
|
||||
|
||||
namespace cylinder
|
||||
section
|
||||
|
||||
universe u
|
||||
parameters {A B : Type.{u}} (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
|
||||
|
||||
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) : apdo (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 [▸*,-apdo_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]
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
homotopy
|
||||
========
|
||||
|
||||
Development of Homotopy Theory, including basic hits (higher inductive
|
||||
types; see also [hit](../hit/hit.md)). The following files are in this
|
||||
folder (sorted such that files only import previous files).
|
||||
|
||||
* [cylinder](cylinder.hlean) (Mapping cylinders, defined using quotients)
|
||||
* [susp](susp.hlean) (Suspensions, defined using pushouts)
|
||||
* [red_susp](red_susp.hlean) (Reduced suspensions)
|
||||
* [sphere](sphere.hlean) (Higher spheres, defined recursively using suspensions)
|
||||
* [circle](circle.hlean) (defined as sphere 1)
|
||||
* [torus](torus.hlean) (defined as a two-quotient)
|
||||
* [interval](interval.hlean) (defined as the suspension of unit)
|
||||
* [cellcomplex](cellcomplex.hlean) (general cell complexes)
|
||||
* [connectedness](connectedness.hlean)
|
||||
* [cofiber](cofiber.hlean)
|
||||
* [smash](smash.hlean)
|
||||
* [homotopy_group](homotopy_group.hlean) (theorems about homotopy groups. The definition and basic facts about homotopy groups is in [algebra/homotopy_group](../algebra/homotopy_group.hlean)).
|
||||
|
|
@ -1,51 +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, Clive Newstead
|
||||
|
||||
-/
|
||||
|
||||
import algebra.homotopy_group .connectedness
|
||||
|
||||
open eq is_trunc trunc_index pointed algebra trunc nat homotopy
|
||||
|
||||
namespace is_trunc
|
||||
-- Lemma 8.3.1
|
||||
theorem trivial_homotopy_group_of_is_trunc (A : Type*) (n k : ℕ) [is_trunc n A] (H : n ≤ k)
|
||||
: is_contr (πg[k+1] A) :=
|
||||
begin
|
||||
apply is_trunc_trunc_of_is_trunc,
|
||||
apply is_contr_loop_of_is_trunc,
|
||||
apply @is_trunc_of_le A n _,
|
||||
rewrite [succ_sub_two_succ k],
|
||||
exact of_nat_le_of_nat H,
|
||||
end
|
||||
|
||||
-- Lemma 8.3.2
|
||||
theorem trivial_homotopy_group_of_is_conn (A : Type*) {k n : ℕ} (H : k ≤ n) [is_conn n A]
|
||||
: is_contr (π[k] A) :=
|
||||
begin
|
||||
have H2 : of_nat k ≤ of_nat n, from of_nat_le_of_nat H,
|
||||
have H3 : is_contr (ptrunc k A),
|
||||
begin
|
||||
fapply is_contr_equiv_closed,
|
||||
{ apply trunc_trunc_equiv_left _ k n H2}
|
||||
end,
|
||||
have H4 : is_contr (Ω[k](ptrunc k A)),
|
||||
from !is_trunc_loop_of_is_trunc,
|
||||
apply is_trunc_equiv_closed_rev,
|
||||
{ apply equiv_of_pequiv (phomotopy_group_pequiv_loop_ptrunc k A)}
|
||||
end
|
||||
|
||||
-- Corollary 8.3.3
|
||||
open sphere.ops sphere_index
|
||||
theorem homotopy_group_sphere_le (n k : ℕ) (H : k < n) : is_contr (π[k] (S. n)) :=
|
||||
begin
|
||||
cases n with n,
|
||||
{ exfalso, apply not_lt_zero, exact H},
|
||||
{ have H2 : k ≤ n, from le_of_lt_succ H,
|
||||
apply @(trivial_homotopy_group_of_is_conn _ H2),
|
||||
rewrite [-trunc_index.of_sphere_index_of_nat, -trunc_index.succ_sub_one], apply is_conn_sphere}
|
||||
end
|
||||
|
||||
end is_trunc
|
||||
|
|
@ -1,99 +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 interval
|
||||
-/
|
||||
|
||||
import .susp types.eq types.prod cubical.square
|
||||
open eq susp unit equiv is_trunc nat prod
|
||||
|
||||
definition interval : Type₀ := susp unit
|
||||
|
||||
namespace interval
|
||||
|
||||
definition zero : interval := north
|
||||
definition one : interval := south
|
||||
definition seg : zero = one := merid star
|
||||
|
||||
protected definition rec {P : interval → Type} (P0 : P zero) (P1 : P one)
|
||||
(Ps : P0 =[seg] P1) (x : interval) : P x :=
|
||||
begin
|
||||
fapply susp.rec_on x,
|
||||
{ exact P0},
|
||||
{ exact P1},
|
||||
{ intro x, cases x, exact Ps}
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : interval → Type} (x : interval)
|
||||
(P0 : P zero) (P1 : P one) (Ps : P0 =[seg] P1) : P x :=
|
||||
interval.rec P0 P1 Ps x
|
||||
|
||||
theorem rec_seg {P : interval → Type} (P0 : P zero) (P1 : P one) (Ps : P0 =[seg] P1)
|
||||
: apdo (interval.rec P0 P1 Ps) seg = Ps :=
|
||||
!rec_merid
|
||||
|
||||
protected definition elim {P : Type} (P0 P1 : P) (Ps : P0 = P1) (x : interval) : P :=
|
||||
interval.rec P0 P1 (pathover_of_eq Ps) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : interval) (P0 P1 : P)
|
||||
(Ps : P0 = P1) : P :=
|
||||
interval.elim P0 P1 Ps x
|
||||
|
||||
theorem elim_seg {P : Type} (P0 P1 : P) (Ps : P0 = P1)
|
||||
: ap (interval.elim P0 P1 Ps) seg = Ps :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant seg),
|
||||
rewrite [▸*,-apdo_eq_pathover_of_eq_ap,↑interval.elim,rec_seg],
|
||||
end
|
||||
|
||||
protected definition elim_type (P0 P1 : Type) (Ps : P0 ≃ P1) (x : interval) : Type :=
|
||||
interval.elim P0 P1 (ua Ps) x
|
||||
|
||||
protected definition elim_type_on [reducible] (x : interval) (P0 P1 : Type) (Ps : P0 ≃ P1)
|
||||
: Type :=
|
||||
interval.elim_type P0 P1 Ps x
|
||||
|
||||
theorem elim_type_seg (P0 P1 : Type) (Ps : P0 ≃ P1)
|
||||
: transport (interval.elim_type P0 P1 Ps) seg = Ps :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑interval.elim_type,elim_seg];apply cast_ua_fn
|
||||
|
||||
definition is_contr_interval [instance] [priority 900] : is_contr interval :=
|
||||
is_contr.mk zero (λx, interval.rec_on x idp seg !pathover_eq_r_idp)
|
||||
|
||||
open is_equiv equiv
|
||||
definition naive_funext_of_interval : naive_funext :=
|
||||
λA P f g p, ap (λ(i : interval) (x : A), interval.elim_on i (f x) (g x) (p x)) seg
|
||||
|
||||
end interval open interval
|
||||
|
||||
definition cube : ℕ → Type₀
|
||||
| cube 0 := unit
|
||||
| cube (succ n) := cube n × interval
|
||||
|
||||
abbreviation square := cube (succ (succ nat.zero))
|
||||
|
||||
definition cube_one_equiv_interval : cube 1 ≃ interval :=
|
||||
!prod_comm_equiv ⬝e !prod_unit_equiv
|
||||
|
||||
|
||||
definition prod_square {A B : Type} {a a' : A} {b b' : B} (p : a = a') (q : b = b')
|
||||
: square (pair_eq p idp) (pair_eq p idp) (pair_eq idp q) (pair_eq idp q) :=
|
||||
by cases p; cases q; exact ids
|
||||
|
||||
namespace square
|
||||
|
||||
definition tl : square := (star, zero, zero)
|
||||
definition tr : square := (star, one, zero)
|
||||
definition bl : square := (star, zero, one )
|
||||
definition br : square := (star, one, one )
|
||||
-- s stands for "square" in the following definitions
|
||||
definition st : tl = tr := pair_eq (pair_eq idp seg) idp
|
||||
definition sb : bl = br := pair_eq (pair_eq idp seg) idp
|
||||
definition sl : tl = bl := pair_eq idp seg
|
||||
definition sr : tr = br := pair_eq idp seg
|
||||
definition sfill : square st sb sl sr := !prod_square
|
||||
definition fill : st ⬝ sr = sl ⬝ sb := !square_equiv_eq sfill
|
||||
|
||||
end square
|
||||
|
|
@ -1,305 +0,0 @@
|
|||
/-
|
||||
Copyright (c) 2015 Jakob von Raumer. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Jakob von Raumer
|
||||
|
||||
Declaration of a join as a special case of a pushout
|
||||
-/
|
||||
|
||||
import hit.pushout .susp cubical.cube cubical.squareover
|
||||
|
||||
open eq function prod equiv pushout is_trunc bool sigma.ops function
|
||||
|
||||
namespace join
|
||||
section
|
||||
variables (A B C : Type)
|
||||
|
||||
definition join : Type := @pushout (A × B) A B pr1 pr2
|
||||
|
||||
definition jglue {A B : Type} (a : A) (b : B) := @glue (A × B) A B pr1 pr2 (a, b)
|
||||
|
||||
protected definition is_contr [HA : is_contr A] :
|
||||
is_contr (join A B) :=
|
||||
begin
|
||||
fapply is_contr.mk, exact inl (center A),
|
||||
intro x, induction x with a b, apply ap inl, apply center_eq,
|
||||
apply jglue, induction x with a b, apply pathover_of_tr_eq,
|
||||
apply concat, apply transport_eq_Fr, esimp, rewrite ap_id,
|
||||
generalize center_eq a, intro p, cases p, apply idp_con,
|
||||
end
|
||||
|
||||
protected definition bool : join bool A ≃ susp A :=
|
||||
begin
|
||||
fapply equiv.MK, intro ba, induction ba with b a,
|
||||
induction b, exact susp.south, exact susp.north, exact susp.north,
|
||||
induction x with b a, esimp,
|
||||
induction b, apply inverse, apply susp.merid, exact a, reflexivity,
|
||||
intro s, induction s with m,
|
||||
exact inl tt, exact inl ff, exact (jglue tt m) ⬝ (jglue ff m)⁻¹,
|
||||
intros, induction b with m, do 2 reflexivity, esimp,
|
||||
apply eq_pathover, apply hconcat, apply hdeg_square, apply concat,
|
||||
apply ap_compose' (pushout.elim _ _ _), apply concat,
|
||||
apply ap (ap (pushout.elim _ _ _)), apply susp.elim_merid, apply ap_con,
|
||||
apply hconcat, apply vconcat, apply hdeg_square, apply elim_glue,
|
||||
apply hdeg_square, apply ap_inv, esimp,
|
||||
apply hconcat, apply hdeg_square, apply concat, apply idp_con,
|
||||
apply concat, apply ap inverse, apply elim_glue, apply inv_inv,
|
||||
apply hinverse, apply hdeg_square, apply ap_id,
|
||||
intro x, induction x with b a, induction b, do 2 reflexivity,
|
||||
esimp, apply jglue, induction x with b a, induction b, esimp,
|
||||
apply eq_pathover, rewrite ap_id,
|
||||
apply eq_hconcat, apply concat, apply ap_compose' (susp.elim _ _ _),
|
||||
apply concat, apply ap (ap _) !elim_glue,
|
||||
apply concat, apply ap_inv,
|
||||
apply concat, apply ap inverse !susp.elim_merid,
|
||||
apply concat, apply con_inv, apply ap (λ x, x ⬝ _) !inv_inv,
|
||||
apply square_of_eq_top, apply inverse,
|
||||
apply concat, apply ap (λ x, x ⬝ _) !con.assoc,
|
||||
rewrite [con.left_inv, con_idp], apply con.right_inv,
|
||||
esimp, apply eq_pathover, rewrite ap_id,
|
||||
apply eq_hconcat, apply concat, apply ap_compose' (susp.elim _ _ _),
|
||||
apply concat, apply ap (ap _) !elim_glue, esimp, reflexivity,
|
||||
apply square_of_eq_top, rewrite idp_con, apply !con.right_inv⁻¹,
|
||||
end
|
||||
|
||||
protected definition swap : join A B → join B A :=
|
||||
begin
|
||||
intro x, induction x with a b, exact inr a, exact inl b,
|
||||
apply !jglue⁻¹
|
||||
end
|
||||
|
||||
protected definition swap_involutive (x : join A B) :
|
||||
join.swap B A (join.swap A B x) = x :=
|
||||
begin
|
||||
induction x with a b, do 2 reflexivity,
|
||||
induction x with a b, esimp,
|
||||
apply eq_pathover, rewrite ap_id,
|
||||
apply hdeg_square, esimp[join.swap],
|
||||
apply concat, apply ap_compose' (pushout.elim _ _ _),
|
||||
krewrite [elim_glue, ap_inv, elim_glue], apply inv_inv,
|
||||
end
|
||||
|
||||
protected definition symm : join A B ≃ join B A :=
|
||||
by fapply equiv.MK; do 2 apply join.swap; do 2 apply join.swap_involutive
|
||||
|
||||
end
|
||||
|
||||
/- This proves that the join operator is associative.
|
||||
The proof is more or less ported from Evan Cavallo's agda version:
|
||||
https://github.com/HoTT/HoTT-Agda/blob/master/homotopy/JoinAssocCubical.agda -/
|
||||
|
||||
section join_switch
|
||||
|
||||
private definition massage_sq' {A : Type} {a₀₀ a₂₀ a₀₂ a₂₂ : A}
|
||||
{p₁₀ : a₀₀ = a₂₀} {p₁₂ : a₀₂ = a₂₂} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂}
|
||||
(sq : square p₁₀ p₁₂ p₀₁ p₂₁) : square p₁₀⁻¹ p₀₁⁻¹ (p₂₁ ⬝ p₁₂⁻¹) idp :=
|
||||
by induction sq; exact ids
|
||||
|
||||
private definition massage_sq {A : Type} {a₀₀ a₂₀ a₀₂ : A}
|
||||
{p₁₀ : a₀₀ = a₂₀} {p₁₂ : a₀₂ = a₂₀} {p₀₁ : a₀₀ = a₀₂}
|
||||
(sq : square p₁₀ p₁₂ p₀₁ idp) : square p₁₀⁻¹ p₀₁⁻¹ p₁₂⁻¹ idp :=
|
||||
!idp_con⁻¹ ⬝ph (massage_sq' sq)
|
||||
|
||||
private definition ap_square_massage {A B : Type} (f : A → B) {a₀₀ a₀₂ a₂₀ : A}
|
||||
{p₀₁ : a₀₀ = a₀₂} {p₁₀ : a₀₀ = a₂₀} {p₁₁ : a₂₀ = a₀₂} (sq : square p₀₁ p₁₁ p₁₀ idp) :
|
||||
cube (hdeg_square (ap_inv f p₁₁)) ids
|
||||
(aps f (massage_sq sq)) (massage_sq (aps f sq))
|
||||
(hdeg_square !ap_inv) (hdeg_square !ap_inv) :=
|
||||
by apply rec_on_r sq; apply idc
|
||||
|
||||
private definition massage_cube' {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₂₂₁}
|
||||
(c : cube s₀₁₁ s₂₁₁ s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube (s₂₁₁ ⬝v s₁₁₂⁻¹ᵛ) vrfl (massage_sq' s₁₀₁) (massage_sq' s₁₂₁) s₁₁₀⁻¹ᵛ s₀₁₁⁻¹ᵛ :=
|
||||
by cases c; apply idc
|
||||
|
||||
private definition massage_cube {A : Type} {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₂₂₀}
|
||||
{s₁₁₀ : square p₀₁₀ _ _ _} {s₁₁₂ : square p₀₁₂ p₂₁₀ p₁₀₂ p₁₂₂}
|
||||
{s₀₁₁ : square p₀₁₀ p₀₁₂ p₀₀₁ p₀₂₁} --{s₂₁₁ : square p₂₁₀ p₂₁₀ idp idp}
|
||||
{s₁₀₁ : square p₁₀₀ p₁₀₂ p₀₀₁ idp} {s₁₂₁ : square p₁₂₀ p₁₂₂ p₀₂₁ idp}
|
||||
(c : cube s₀₁₁ vrfl s₁₀₁ s₁₂₁ s₁₁₀ s₁₁₂) :
|
||||
cube s₁₁₂⁻¹ᵛ vrfl (massage_sq s₁₀₁) (massage_sq s₁₂₁) s₁₁₀⁻¹ᵛ s₀₁₁⁻¹ᵛ :=
|
||||
begin
|
||||
cases p₁₀₀, cases p₁₀₂, cases p₁₂₂, note c' := massage_cube' c, esimp[massage_sq],
|
||||
krewrite vdeg_v_eq_ph_pv_hp at c', exact c',
|
||||
end
|
||||
|
||||
private definition massage_massage {A : Type} {a₀₀ a₀₂ a₂₀ : A}
|
||||
{p₀₁ : a₀₀ = a₀₂} {p₁₀ : a₀₀ = a₂₀} {p₁₁ : a₂₀ = a₀₂} (sq : square p₀₁ p₁₁ p₁₀ idp) :
|
||||
cube (hdeg_square !inv_inv) ids (massage_sq (massage_sq sq))
|
||||
sq (hdeg_square !inv_inv) (hdeg_square !inv_inv) :=
|
||||
by apply rec_on_r sq; apply idc
|
||||
|
||||
private definition square_Flr_ap_idp_cube {A B : Type} {b : B} {f : A → B}
|
||||
{p₁ p₂ : Π a, f a = b} (α : Π a, p₁ a = p₂ a) {a₁ a₂ : A} (q : a₁ = a₂) :
|
||||
cube hrfl hrfl (square_Flr_ap_idp p₁ q) (square_Flr_ap_idp p₂ q)
|
||||
(hdeg_square (α _)) (hdeg_square (α _)) :=
|
||||
by cases q; esimp[square_Flr_ap_idp]; apply deg3_cube; esimp
|
||||
|
||||
variables {A B C : Type}
|
||||
|
||||
private definition switch_left [reducible] : join A B → join (join C B) A :=
|
||||
begin
|
||||
intro x, induction x with a b, exact inr a, exact inl (inr b), apply !jglue⁻¹,
|
||||
end
|
||||
|
||||
private definition switch_coh_fill (a : A) (b : B) (c : C) :
|
||||
Σ sq : square (jglue (inl c) a)⁻¹ (ap inl (jglue c b))⁻¹ (ap switch_left (jglue a b)) idp,
|
||||
cube (hdeg_square !elim_glue) ids sq (massage_sq !square_Flr_ap_idp) hrfl hrfl :=
|
||||
by esimp; apply cube_fill101
|
||||
|
||||
private definition switch_coh (ab : join A B) (c : C) : switch_left ab = inl (inl c) :=
|
||||
begin
|
||||
induction ab with a b, apply !jglue⁻¹, apply (ap inl !jglue)⁻¹, induction x with a b,
|
||||
apply eq_pathover, refine _ ⬝hp !ap_constant⁻¹,
|
||||
apply !switch_coh_fill.1,
|
||||
end
|
||||
|
||||
protected definition switch [reducible] : join (join A B) C → join (join C B) A :=
|
||||
begin
|
||||
intro x, induction x with ab c, exact switch_left ab, exact inl (inl c),
|
||||
induction x with ab c, exact switch_coh ab c,
|
||||
end
|
||||
|
||||
private definition switch_inv_left_square (a : A) (b : B) :
|
||||
square idp idp (ap (!(@join.switch C) ∘ switch_left) (jglue a b)) (ap inl (jglue a b)) :=
|
||||
begin
|
||||
refine hdeg_square !ap_compose ⬝h _,
|
||||
refine aps join.switch (hdeg_square !elim_glue) ⬝h _, esimp,
|
||||
refine hdeg_square !(ap_inv join.switch) ⬝h _,
|
||||
refine hrfl⁻¹ʰ⁻¹ᵛ ⬝h _, esimp[join.switch,switch_left,switch_coh],
|
||||
refine (hdeg_square !elim_glue)⁻¹ᵛ ⬝h _, esimp,
|
||||
refine hrfl⁻¹ᵛ ⬝h _, apply hdeg_square !inv_inv,
|
||||
end
|
||||
|
||||
private definition switch_inv_coh_left (c : C) (a : A) :
|
||||
square idp idp (ap !(@join.switch C B) (switch_coh (inl a) c)) (jglue (inl a) c) :=
|
||||
begin
|
||||
refine hrfl ⬝h _,
|
||||
refine aps join.switch hrfl ⬝h _, esimp[switch_coh],
|
||||
refine hdeg_square !ap_inv ⬝h _,
|
||||
refine hrfl⁻¹ʰ⁻¹ᵛ ⬝h _, esimp[join.switch,switch_left],
|
||||
refine (hdeg_square !elim_glue)⁻¹ᵛ ⬝h _,
|
||||
refine hrfl⁻¹ᵛ ⬝h _, apply hdeg_square !inv_inv,
|
||||
end
|
||||
|
||||
private definition switch_inv_coh_right (c : C) (b : B) :
|
||||
square idp idp (ap !(@join.switch _ _ A) (switch_coh (inr b) c)) (jglue (inr b) c) :=
|
||||
begin
|
||||
refine hrfl ⬝h _,
|
||||
refine aps join.switch hrfl ⬝h _, esimp[switch_coh],
|
||||
refine hdeg_square !ap_inv ⬝h _,
|
||||
refine (hdeg_square !ap_compose)⁻¹ʰ⁻¹ᵛ ⬝h _,
|
||||
refine hrfl⁻¹ᵛ ⬝h _, esimp[join.switch,switch_left],
|
||||
refine (hdeg_square !elim_glue)⁻¹ᵛ ⬝h _, apply hdeg_square !inv_inv,
|
||||
end
|
||||
|
||||
private definition switch_inv_left (ab : join A B) :
|
||||
!(@join.switch C) (join.switch (inl ab)) = inl ab :=
|
||||
begin
|
||||
induction ab with a b, do 2 reflexivity,
|
||||
induction x with a b, apply eq_pathover, exact !switch_inv_left_square,
|
||||
end
|
||||
|
||||
section
|
||||
variables (a : A) (b : B) (c : C)
|
||||
|
||||
private definition switch_inv_cube_aux1 {A B C : Type} {b : B} {f : A → B} (h : B → C)
|
||||
(g : Π a, f a = b) {x y : A} (p : x = y) :
|
||||
cube (hdeg_square (ap_compose h f p)) ids (square_Flr_ap_idp (λ a, ap h (g a)) p)
|
||||
(aps h (square_Flr_ap_idp _ _)) hrfl hrfl :=
|
||||
by cases p; esimp[square_Flr_ap_idp]; apply deg2_cube; cases (g x); esimp
|
||||
|
||||
private definition switch_inv_cube_aux2 {A B : Type} {b : B} {f : A → B}
|
||||
(g : Π a, f a = b) {x y : A} (p : x = y) {sq : square (g x) (g y) (ap f p) idp}
|
||||
(q : apdo g p = eq_pathover (sq ⬝hp !ap_constant⁻¹)) : square_Flr_ap_idp _ _ = sq :=
|
||||
begin
|
||||
cases p, esimp at *, apply concat, apply inverse, apply vdeg_square_idp,
|
||||
apply concat, apply ap vdeg_square, exact ap eq_of_pathover_idp q,
|
||||
krewrite (is_equiv.right_inv (equiv.to_fun !pathover_idp)),
|
||||
exact is_equiv.left_inv (equiv.to_fun (vdeg_square_equiv _ _)) sq,
|
||||
end
|
||||
|
||||
private definition switch_inv_cube (a : A) (b : B) (c : C) :
|
||||
cube (switch_inv_left_square a b) ids (square_Flr_ap_idp _ _)
|
||||
(square_Flr_ap_idp _ _) (switch_inv_coh_left c a) (switch_inv_coh_right c b) :=
|
||||
begin
|
||||
esimp [switch_inv_coh_left, switch_inv_coh_right, switch_inv_left_square],
|
||||
apply cube_concat2, apply switch_inv_cube_aux1,
|
||||
apply cube_concat2, apply cube_transport101, apply inverse,
|
||||
apply ap (λ x, aps join.switch x), apply switch_inv_cube_aux2, apply rec_glue,
|
||||
apply apc, apply (switch_coh_fill a b c).2,
|
||||
apply cube_concat2, esimp, apply ap_square_massage,
|
||||
apply cube_concat2, apply massage_cube, apply cube_inverse2, apply switch_inv_cube_aux1,
|
||||
apply cube_concat2, apply massage_cube, apply square_Flr_ap_idp_cube,
|
||||
apply cube_concat2, apply massage_cube, apply cube_transport101,
|
||||
apply inverse, apply switch_inv_cube_aux2,
|
||||
esimp[switch_coh], apply rec_glue, apply (switch_coh_fill c b a).2,
|
||||
apply massage_massage,
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
private definition pathover_of_triangle_cube {A B : Type} {b₀ b₁ : A → B}
|
||||
{b : B} {p₀₁ : Π a, b₀ a = b₁ a} {p₀ : Π a, b₀ a = b} {p₁ : Π a, b₁ a = b}
|
||||
{x y : A} {q : x = y} {sqx : square (p₀₁ x) idp (p₀ x) (p₁ x)}
|
||||
{sqy : square (p₀₁ y) idp (p₀ y) (p₁ y)}
|
||||
(c : cube (natural_square_tr _ _) ids (square_Flr_ap_idp p₀ q) (square_Flr_ap_idp p₁ q)
|
||||
sqx sqy) :
|
||||
sqx =[q] sqy :=
|
||||
by cases q; apply pathover_of_eq_tr; apply eq_of_deg12_cube; exact c
|
||||
|
||||
private definition pathover_of_ap_ap_square {A : Type} {x y : A} {p : x = y}
|
||||
(g : B → A) (f : A → B) {u : g (f x) = x} {v : g (f y) = y}
|
||||
(sq : square (ap g (ap f p)) p u v) : u =[p] v :=
|
||||
by cases p; apply eq_pathover; apply transpose; exact sq
|
||||
|
||||
private definition natural_square_tr_beta {A B : Type} {f₁ f₂ : A → B}
|
||||
(p : Π a, f₁ a = f₂ a) {x y : A} (q : x = y) {sq : square (p x) (p y) (ap f₁ q) (ap f₂ q)}
|
||||
(e : apdo p q = eq_pathover sq) :
|
||||
natural_square_tr p q = sq :=
|
||||
begin
|
||||
cases q, esimp at *, apply concat, apply inverse, apply vdeg_square_idp,
|
||||
apply concat, apply ap vdeg_square, apply ap eq_of_pathover_idp e,
|
||||
krewrite (is_equiv.right_inv (equiv.to_fun !pathover_idp)),
|
||||
exact is_equiv.left_inv (equiv.to_fun (vdeg_square_equiv _ _)) sq,
|
||||
end
|
||||
|
||||
private definition switch_inv_coh (c : C) (k : join A B) :
|
||||
square (switch_inv_left k) idp (ap join.switch (switch_coh k c)) (jglue k c) :=
|
||||
begin
|
||||
induction k, apply switch_inv_coh_left, apply switch_inv_coh_right,
|
||||
refine pathover_of_triangle_cube _,
|
||||
induction x with [a, b], esimp, apply cube_transport011,
|
||||
apply inverse, rotate 1, apply switch_inv_cube,
|
||||
apply natural_square_tr_beta, apply rec_glue,
|
||||
end
|
||||
|
||||
protected definition switch_involutive (x : join (join A B) C) :
|
||||
join.switch (join.switch x) = x :=
|
||||
begin
|
||||
induction x, apply switch_inv_left, reflexivity,
|
||||
apply pathover_of_ap_ap_square join.switch join.switch,
|
||||
induction x with [k, c], krewrite elim_glue, esimp,
|
||||
apply transpose, exact !switch_inv_coh,
|
||||
end
|
||||
|
||||
end join_switch
|
||||
|
||||
protected definition switch_equiv (A B C : Type) : join (join A B) C ≃ join (join C B) A :=
|
||||
by apply equiv.MK; do 2 apply join.switch_involutive
|
||||
|
||||
protected definition assoc (A B C : Type) : join (join A B) C ≃ join A (join B C) :=
|
||||
calc join (join A B) C ≃ join (join C B) A : join.switch_equiv
|
||||
... ≃ join A (join C B) : join.symm
|
||||
... ≃ join A (join B C) : join.symm
|
||||
|
||||
end join
|
||||
|
|
@ -1,87 +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 reduced suspension
|
||||
-/
|
||||
|
||||
import hit.two_quotient types.pointed algebra.e_closure
|
||||
|
||||
open simple_two_quotient eq unit pointed e_closure
|
||||
|
||||
namespace red_susp
|
||||
section
|
||||
|
||||
parameter {A : pType}
|
||||
|
||||
inductive red_susp_R : unit → unit → Type :=
|
||||
| Rmk : Π(a : A), red_susp_R star star
|
||||
open red_susp_R
|
||||
inductive red_susp_Q : Π⦃x : unit⦄, e_closure red_susp_R x x → Type :=
|
||||
| Qmk : red_susp_Q [Rmk pt]
|
||||
open red_susp_Q
|
||||
local abbreviation R := red_susp_R
|
||||
local abbreviation Q := red_susp_Q
|
||||
|
||||
definition red_susp : Type := simple_two_quotient R Q -- TODO: define this in root namespace
|
||||
|
||||
definition base : red_susp :=
|
||||
incl0 R Q star
|
||||
|
||||
definition merid (a : A) : base = base :=
|
||||
incl1 R Q (Rmk a)
|
||||
|
||||
definition merid_pt : merid pt = idp :=
|
||||
incl2 R Q Qmk
|
||||
|
||||
-- protected definition rec {P : red_susp → Type} (Pb : P base) (Pm : Π(a : A), Pb =[merid a] Pb)
|
||||
-- (Pe : Pm pt =[merid_pt] idpo) (x : red_susp) : P x :=
|
||||
-- begin
|
||||
-- induction x,
|
||||
-- end
|
||||
|
||||
-- protected definition rec_on [reducible] {P : red_susp → Type} (x : red_susp) (Pb : P base)
|
||||
-- (Pm : Π(a : A), Pb =[merid a] Pb) (Pe : Pm pt =[merid_pt] idpo) : P x :=
|
||||
-- rec Pb Pm Pe x
|
||||
|
||||
-- definition rec_merid {P : red_susp → Type} (Pb : P base) (Pm : Π(a : A), Pb =[merid a] Pb)
|
||||
-- (Pe : Pm pt =[merid_pt] idpo) (a : A)
|
||||
-- : apdo (rec Pb Pm Pe) (merid a) = Pm a :=
|
||||
-- !rec_incl1
|
||||
|
||||
-- theorem elim_merid_pt {P : red_susp → Type} (Pb : P base) (Pm : Π(a : A), Pb =[merid a] Pb)
|
||||
-- (Pe : Pm pt =[merid_pt] idpo)
|
||||
-- : square (ap02 (rec Pb Pm Pe) merid_pt) Pe (rec_merid Pe pt) idp :=
|
||||
-- !rec_incl2
|
||||
|
||||
protected definition elim {P : Type} (Pb : P) (Pm : Π(a : A), Pb = Pb)
|
||||
(Pe : Pm pt = idp) (x : red_susp) : P :=
|
||||
begin
|
||||
induction x,
|
||||
exact Pb,
|
||||
induction s, exact Pm a,
|
||||
induction q, exact Pe
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : red_susp) (Pb : P)
|
||||
(Pm : Π(a : A), Pb = Pb) (Pe : Pm pt = idp) : P :=
|
||||
elim Pb Pm Pe x
|
||||
|
||||
definition elim_merid {P : Type} {Pb : P} {Pm : Π(a : A), Pb = Pb}
|
||||
(Pe : Pm pt = idp) (a : A)
|
||||
: ap (elim Pb Pm Pe) (merid a) = Pm a :=
|
||||
!elim_incl1
|
||||
|
||||
theorem elim_merid_pt {P : Type} (Pb : P) (Pm : Π(a : A), Pb = Pb)
|
||||
(Pe : Pm pt = idp) : square (ap02 (elim Pb Pm Pe) merid_pt) Pe (elim_merid Pe pt) idp :=
|
||||
!elim_incl2
|
||||
|
||||
end
|
||||
end red_susp
|
||||
|
||||
attribute red_susp.base [constructor]
|
||||
attribute /-red_susp.rec-/ red_susp.elim [unfold 6] [recursor 6]
|
||||
--attribute red_susp.elim_type [unfold 9]
|
||||
attribute /-red_susp.rec_on-/ red_susp.elim_on [unfold 3]
|
||||
--attribute red_susp.elim_type_on [unfold 6]
|
||||
|
|
@ -1,83 +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 Smash Product of Types
|
||||
-/
|
||||
|
||||
import hit.pushout .wedge .cofiber .susp .sphere
|
||||
|
||||
open eq pushout prod pointed is_trunc
|
||||
|
||||
definition product_of_wedge [constructor] (A B : Type*) : pwedge A B →* A ×* B :=
|
||||
begin
|
||||
fconstructor,
|
||||
intro x, induction x with [a, b], exact (a, point B), exact (point A, b),
|
||||
do 2 reflexivity
|
||||
end
|
||||
|
||||
definition psmash (A B : Type*) := pcofiber (product_of_wedge A B)
|
||||
|
||||
open sphere susp unit
|
||||
|
||||
namespace smash
|
||||
|
||||
protected definition prec {X Y : Type*} {P : psmash X Y → Type}
|
||||
(pxy : Π x y, P (inr (x, y))) (ps : P (inl ⋆))
|
||||
(px : Π x, pathover P ps (glue (inl x)) (pxy x (point Y)))
|
||||
(py : Π y, pathover P ps (glue (inr y)) (pxy (point X) y))
|
||||
(pg : pathover (λ x, pathover P ps (glue x) (@prod.rec X Y (λ x, P (inr x)) pxy
|
||||
(pushout.elim (λ a, (a, Point Y)) (pair (Point X)) (λ x, idp) x)))
|
||||
(px (Point X)) (glue ⋆) (py (Point Y))) : Π s, P s :=
|
||||
begin
|
||||
intro s, induction s, induction x, exact ps,
|
||||
induction x with [x, y], exact pxy x y,
|
||||
induction x with [x, y, u], exact px x, exact py y,
|
||||
induction u, exact pg,
|
||||
end
|
||||
|
||||
protected definition prec_on {X Y : Type*} {P : psmash X Y → Type} (s : psmash X Y)
|
||||
(pxy : Π x y, P (inr (x, y))) (ps : P (inl ⋆))
|
||||
(px : Π x, pathover P ps (glue (inl x)) (pxy x (point Y)))
|
||||
(py : Π y, pathover P ps (glue (inr y)) (pxy (point X) y))
|
||||
(pg : pathover (λ x, pathover P ps (glue x) (@prod.rec X Y (λ x, P (inr x)) pxy
|
||||
(pushout.elim (λ a, (a, Point Y)) (pair (Point X)) (λ x, idp) x)))
|
||||
(px (Point X)) (glue ⋆) (py (Point Y))) : P s :=
|
||||
smash.prec pxy ps px py pg s
|
||||
|
||||
/- definition smash_bool (X : Type*) : psmash X pbool ≃* X :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ fconstructor,
|
||||
{ intro x, fapply cofiber.pelim_on x, clear x, exact point X, intro p,
|
||||
cases p with [x', b], cases b with [x, x'], exact point X, exact x',
|
||||
clear x, intro w, induction w with [y, b], reflexivity,
|
||||
cases b, reflexivity, reflexivity, esimp,
|
||||
apply eq_pathover, refine !ap_constant ⬝ph _, cases x, esimp, apply hdeg_square,
|
||||
apply inverse, apply concat, apply ap_compose (λ a, prod.cases_on a _),
|
||||
apply concat, apply ap _ !elim_glue, reflexivity },
|
||||
reflexivity },
|
||||
{ fapply is_equiv.adjointify,
|
||||
{ intro x, apply inr, exact pair x bool.tt },
|
||||
{ intro x, reflexivity },
|
||||
{ intro s, esimp, induction s,
|
||||
{ cases x, apply (glue (inr bool.tt))⁻¹ },
|
||||
{ cases x with [x, b], cases b,
|
||||
apply inverse, apply concat, apply (glue (inl x))⁻¹, apply (glue (inr bool.tt)),
|
||||
reflexivity },
|
||||
{ esimp, apply eq_pathover, induction x,
|
||||
esimp, apply hinverse, krewrite ap_id, apply move_bot_of_left,
|
||||
krewrite con.right_inv,
|
||||
refine _ ⬝hp !(ap_compose (λ a, inr (pair a _)))⁻¹,
|
||||
apply transpose, apply square_of_eq_bot, rewrite [con_idp, con.left_inv],
|
||||
apply inverse, apply concat, apply ap (ap _),
|
||||
} } }
|
||||
|
||||
definition susp_equiv_circle_smash (X : Type*) : psusp X ≃* psmash (psphere 1) X :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ fconstructor, intro x, induction x, },
|
||||
end-/
|
||||
|
||||
end smash
|
||||
|
|
@ -1,302 +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 n-spheres
|
||||
-/
|
||||
|
||||
import .susp types.trunc
|
||||
|
||||
open eq nat susp bool is_trunc unit pointed algebra
|
||||
|
||||
/-
|
||||
We can define spheres with the following possible indices:
|
||||
- trunc_index (defining S^-2 = S^-1 = empty)
|
||||
- nat (forgetting that S^-1 = empty)
|
||||
- nat, but counting wrong (S^0 = empty, S^1 = bool, ...)
|
||||
- some new type "integers >= -1"
|
||||
We choose the last option here.
|
||||
-/
|
||||
|
||||
/- Sphere levels -/
|
||||
|
||||
inductive sphere_index : Type₀ :=
|
||||
| minus_one : sphere_index
|
||||
| succ : sphere_index → sphere_index
|
||||
|
||||
notation `ℕ₋₁` := sphere_index
|
||||
|
||||
namespace trunc_index
|
||||
definition sub_one [reducible] (n : ℕ₋₁) : ℕ₋₂ :=
|
||||
sphere_index.rec_on n -2 (λ n k, k.+1)
|
||||
postfix `..-1`:(max+1) := sub_one
|
||||
|
||||
definition of_sphere_index [reducible] (n : ℕ₋₁) : ℕ₋₂ :=
|
||||
n..-1.+1
|
||||
|
||||
-- we use a double dot to distinguish with the notation .-1 in trunc_index (of type ℕ → ℕ₋₂)
|
||||
end trunc_index
|
||||
|
||||
namespace sphere_index
|
||||
/-
|
||||
notation for sphere_index is -1, 0, 1, ...
|
||||
from 0 and up this comes from a coercion from num to sphere_index (via nat)
|
||||
-/
|
||||
|
||||
postfix `.+1`:(max+1) := sphere_index.succ
|
||||
postfix `.+2`:(max+1) := λ(n : sphere_index), (n .+1 .+1)
|
||||
notation `-1` := minus_one
|
||||
|
||||
definition has_zero_sphere_index [instance] : has_zero ℕ₋₁ :=
|
||||
has_zero.mk (succ minus_one)
|
||||
|
||||
definition has_one_sphere_index [instance] : has_one ℕ₋₁ :=
|
||||
has_one.mk (succ (succ minus_one))
|
||||
|
||||
definition add_plus_one (n m : ℕ₋₁) : ℕ₋₁ :=
|
||||
sphere_index.rec_on m n (λ k l, l .+1)
|
||||
|
||||
-- addition of sphere_indices, where (-1 + -1) is defined to be -1.
|
||||
protected definition add (n m : ℕ₋₁) : ℕ₋₁ :=
|
||||
sphere_index.cases_on m
|
||||
(sphere_index.cases_on n -1 id)
|
||||
(sphere_index.rec n (λn' r, succ r))
|
||||
|
||||
inductive le (a : ℕ₋₁) : ℕ₋₁ → Type :=
|
||||
| sp_refl : le a a
|
||||
| step : Π {b}, le a b → le a (b.+1)
|
||||
|
||||
infix `+1+`:65 := sphere_index.add_plus_one
|
||||
|
||||
definition has_add_sphere_index [instance] [priority 2000] [reducible] : has_add ℕ₋₁ :=
|
||||
has_add.mk sphere_index.add
|
||||
|
||||
definition has_le_sphere_index [instance] : has_le ℕ₋₁ :=
|
||||
has_le.mk sphere_index.le
|
||||
|
||||
definition of_nat [coercion] [reducible] (n : nat) : ℕ₋₁ :=
|
||||
(nat.rec_on n -1 (λ n k, k.+1)).+1
|
||||
|
||||
definition sub_one [reducible] (n : ℕ) : ℕ₋₁ :=
|
||||
nat.rec_on n -1 (λ n k, k.+1)
|
||||
|
||||
postfix `..-1`:(max+1) := sub_one
|
||||
-- we use a double dot to distinguish with the notation .-1 in trunc_index (of type ℕ → ℕ₋₂)
|
||||
|
||||
definition succ_sub_one (n : ℕ) : (nat.succ n)..-1 = n :> ℕ₋₁ :=
|
||||
idp
|
||||
|
||||
definition succ_le_succ {n m : ℕ₋₁} (H : n ≤ m) : n.+1 ≤[ℕ₋₁] m.+1 :=
|
||||
by induction H with m H IH; apply le.sp_refl; exact le.step IH
|
||||
|
||||
definition minus_one_le (n : ℕ₋₁) : -1 ≤[ℕ₋₁] n :=
|
||||
by induction n with n IH; apply le.sp_refl; exact le.step IH
|
||||
|
||||
open decidable
|
||||
protected definition has_decidable_eq [instance] : Π(n m : ℕ₋₁), decidable (n = m)
|
||||
| has_decidable_eq -1 -1 := inl rfl
|
||||
| has_decidable_eq (n.+1) -1 := inr (by contradiction)
|
||||
| has_decidable_eq -1 (m.+1) := inr (by contradiction)
|
||||
| has_decidable_eq (n.+1) (m.+1) :=
|
||||
match has_decidable_eq n m with
|
||||
| inl xeqy := inl (by rewrite xeqy)
|
||||
| inr xney := inr (λ h : succ n = succ m, by injection h with xeqy; exact absurd xeqy xney)
|
||||
end
|
||||
|
||||
definition not_succ_le_minus_two {n : sphere_index} (H : n .+1 ≤[ℕ₋₁] -1) : empty :=
|
||||
by cases H
|
||||
|
||||
protected definition le_trans {n m k : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m) (H2 : m ≤[ℕ₋₁] k) : n ≤[ℕ₋₁] k :=
|
||||
begin
|
||||
induction H2 with k H2 IH,
|
||||
{ exact H1},
|
||||
{ exact le.step IH}
|
||||
end
|
||||
|
||||
definition le_of_succ_le_succ {n m : ℕ₋₁} (H : n.+1 ≤[ℕ₋₁] m.+1) : n ≤[ℕ₋₁] m :=
|
||||
begin
|
||||
cases H with m H',
|
||||
{ apply le.sp_refl},
|
||||
{ exact sphere_index.le_trans (le.step !le.sp_refl) H'}
|
||||
end
|
||||
|
||||
theorem not_succ_le_self {n : ℕ₋₁} : ¬n.+1 ≤[ℕ₋₁] n :=
|
||||
begin
|
||||
induction n with n IH: intro H,
|
||||
{ exact not_succ_le_minus_two H},
|
||||
{ exact IH (le_of_succ_le_succ H)}
|
||||
end
|
||||
|
||||
protected definition le_antisymm {n m : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m) (H2 : m ≤[ℕ₋₁] n) : n = m :=
|
||||
begin
|
||||
induction H2 with n H2 IH,
|
||||
{ reflexivity},
|
||||
{ exfalso, apply @not_succ_le_self n, exact sphere_index.le_trans H1 H2}
|
||||
end
|
||||
|
||||
protected definition le_succ {n m : ℕ₋₁} (H1 : n ≤[ℕ₋₁] m): n ≤[ℕ₋₁] m.+1 :=
|
||||
le.step H1
|
||||
|
||||
/-
|
||||
warning: if this coercion is available, the coercion ℕ → ℕ₋₂ is the composition of the coercions
|
||||
ℕ → ℕ₋₁ → ℕ₋₂. We don't want this composition as coercion, because it has worse computational
|
||||
properties. You can rewrite it with trans_to_of_sphere_index_eq defined below.
|
||||
-/
|
||||
attribute trunc_index.of_sphere_index [coercion]
|
||||
|
||||
|
||||
end sphere_index open sphere_index
|
||||
|
||||
definition weak_order_sphere_index [trans_instance] [reducible] : weak_order sphere_index :=
|
||||
weak_order.mk le sphere_index.le.sp_refl @sphere_index.le_trans @sphere_index.le_antisymm
|
||||
|
||||
namespace trunc_index
|
||||
definition sub_two_eq_sub_one_sub_one (n : ℕ) : n.-2 = n..-1..-1 :=
|
||||
nat.rec_on n idp (λn p, ap trunc_index.succ p)
|
||||
|
||||
definition succ_sub_one (n : ℕ₋₁) : n.+1..-1 = n :> ℕ₋₂ :=
|
||||
idp
|
||||
|
||||
definition of_sphere_index_of_nat (n : ℕ)
|
||||
: of_sphere_index (sphere_index.of_nat n) = of_nat n :> ℕ₋₂ :=
|
||||
begin
|
||||
induction n with n IH,
|
||||
{ reflexivity},
|
||||
{ exact ap trunc_index.succ IH}
|
||||
end
|
||||
|
||||
definition trans_to_of_sphere_index_eq (n : ℕ)
|
||||
: trunc_index._trans_to_of_sphere_index n = of_nat n :> ℕ₋₂ :=
|
||||
of_sphere_index_of_nat n
|
||||
|
||||
end trunc_index
|
||||
|
||||
open sphere_index equiv
|
||||
|
||||
definition sphere : ℕ₋₁ → Type₀
|
||||
| -1 := empty
|
||||
| n.+1 := susp (sphere n)
|
||||
|
||||
namespace sphere
|
||||
|
||||
export [notation] [coercion] sphere_index
|
||||
|
||||
definition base {n : ℕ} : sphere n := north
|
||||
definition pointed_sphere [instance] [constructor] (n : ℕ) : pointed (sphere n) :=
|
||||
pointed.mk base
|
||||
definition psphere [constructor] (n : ℕ) : Type* := pointed.mk' (sphere n)
|
||||
|
||||
namespace ops
|
||||
abbreviation S := sphere
|
||||
notation `S.` := psphere
|
||||
end ops
|
||||
open sphere.ops
|
||||
|
||||
definition sphere_minus_one : S -1 = empty := idp
|
||||
definition sphere_succ (n : ℕ₋₁) : S n.+1 = susp (S n) := idp
|
||||
|
||||
definition equator (n : ℕ) : map₊ (S. n) (Ω (S. (succ n))) :=
|
||||
pmap.mk (λa, merid a ⬝ (merid base)⁻¹) !con.right_inv
|
||||
|
||||
definition surf {n : ℕ} : Ω[n] S. n :=
|
||||
nat.rec_on n (proof base qed)
|
||||
(begin intro m s, refine cast _ (apn m (equator m) s),
|
||||
exact ap carrier !loop_space_succ_eq_in⁻¹ end)
|
||||
|
||||
|
||||
definition bool_of_sphere : S 0 → bool :=
|
||||
proof susp.rec ff tt (λx, empty.elim x) qed
|
||||
|
||||
definition sphere_of_bool : bool → S 0
|
||||
| ff := proof north qed
|
||||
| tt := proof south qed
|
||||
|
||||
definition sphere_equiv_bool : S 0 ≃ bool :=
|
||||
equiv.MK bool_of_sphere
|
||||
sphere_of_bool
|
||||
(λb, match b with | tt := idp | ff := idp end)
|
||||
(λx, proof susp.rec_on x idp idp (empty.rec _) qed)
|
||||
|
||||
definition sphere_eq_bool : S 0 = bool :=
|
||||
ua sphere_equiv_bool
|
||||
|
||||
definition sphere_eq_pbool : S. 0 = pbool :=
|
||||
pType_eq sphere_equiv_bool idp
|
||||
|
||||
-- TODO1: the commented-out part makes the forward function below "apn _ surf"
|
||||
-- TODO2: we could make this a pointed equivalence
|
||||
definition pmap_sphere (A : Type*) (n : ℕ) : map₊ (S. n) A ≃ Ω[n] A :=
|
||||
begin
|
||||
-- fapply equiv_change_fun,
|
||||
-- {
|
||||
revert A, induction n with n IH: intro A,
|
||||
{ apply tr_rev (λx, x →* _ ≃ _) sphere_eq_pbool, apply pmap_bool_equiv},
|
||||
{ refine susp_adjoint_loop (S. n) A ⬝e !IH ⬝e _, rewrite [loop_space_succ_eq_in]}
|
||||
-- },
|
||||
-- { intro f, exact apn n f surf},
|
||||
-- { revert A, induction n with n IH: intro A f,
|
||||
-- { exact sorry},
|
||||
-- { exact sorry}}
|
||||
end
|
||||
|
||||
protected definition elim {n : ℕ} {P : Type*} (p : Ω[n] P) : map₊ (S. n) P :=
|
||||
to_inv !pmap_sphere p
|
||||
|
||||
-- definition elim_surf {n : ℕ} {P : Type*} (p : Ω[n] P) : apn n (sphere.elim p) surf = p :=
|
||||
-- begin
|
||||
-- induction n with n IH,
|
||||
-- { esimp [apn,surf,sphere.elim,pmap_sphere], apply sorry},
|
||||
-- { apply sorry}
|
||||
-- end
|
||||
|
||||
end sphere
|
||||
|
||||
open sphere sphere.ops
|
||||
|
||||
namespace is_trunc
|
||||
open trunc_index
|
||||
variables {n : ℕ} {A : Type}
|
||||
definition is_trunc_of_pmap_sphere_constant
|
||||
(H : Π(a : A) (f : map₊ (S. n) (pointed.Mk a)) (x : S n), f x = f base) : is_trunc (n.-2.+1) A :=
|
||||
begin
|
||||
apply iff.elim_right !is_trunc_iff_is_contr_loop,
|
||||
intro a,
|
||||
apply is_trunc_equiv_closed, apply pmap_sphere,
|
||||
fapply is_contr.mk,
|
||||
{ exact pmap.mk (λx, a) idp},
|
||||
{ intro f, fapply pmap_eq,
|
||||
{ intro x, esimp, refine !respect_pt⁻¹ ⬝ (!H ⬝ !H⁻¹)},
|
||||
{ rewrite [▸*,con.right_inv,▸*,con.left_inv]}}
|
||||
end
|
||||
|
||||
definition is_trunc_iff_map_sphere_constant
|
||||
(H : Π(f : S n → A) (x : S n), f x = f base) : is_trunc (n.-2.+1) A :=
|
||||
begin
|
||||
apply is_trunc_of_pmap_sphere_constant,
|
||||
intros, cases f with f p, esimp at *, apply H
|
||||
end
|
||||
|
||||
definition pmap_sphere_constant_of_is_trunc' [H : is_trunc (n.-2.+1) A]
|
||||
(a : A) (f : map₊ (S. n) (pointed.Mk a)) (x : S n) : f x = f base :=
|
||||
begin
|
||||
let H' := iff.elim_left (is_trunc_iff_is_contr_loop n A) H a,
|
||||
note H'' := @is_trunc_equiv_closed_rev _ _ _ !pmap_sphere H',
|
||||
have p : (f = pmap.mk (λx, f base) (respect_pt f)),
|
||||
by apply is_prop.elim,
|
||||
exact ap10 (ap pmap.to_fun p) x
|
||||
end
|
||||
|
||||
definition pmap_sphere_constant_of_is_trunc [H : is_trunc (n.-2.+1) A]
|
||||
(a : A) (f : map₊ (S. n) (pointed.Mk a)) (x y : S n) : f x = f y :=
|
||||
let H := pmap_sphere_constant_of_is_trunc' a f in !H ⬝ !H⁻¹
|
||||
|
||||
definition map_sphere_constant_of_is_trunc [H : is_trunc (n.-2.+1) A]
|
||||
(f : S n → A) (x y : S n) : f x = f y :=
|
||||
pmap_sphere_constant_of_is_trunc (f base) (pmap.mk f idp) x y
|
||||
|
||||
definition map_sphere_constant_of_is_trunc_self [H : is_trunc (n.-2.+1) A]
|
||||
(f : S n → A) (x : S n) : map_sphere_constant_of_is_trunc f x x = idp :=
|
||||
!con.right_inv
|
||||
|
||||
end is_trunc
|
||||
|
|
@ -1,231 +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 suspension
|
||||
-/
|
||||
|
||||
import hit.pushout types.pointed cubical.square
|
||||
|
||||
open pushout unit eq equiv
|
||||
|
||||
definition susp (A : Type) : Type := pushout (λ(a : A), star) (λ(a : A), star)
|
||||
|
||||
namespace susp
|
||||
variable {A : Type}
|
||||
|
||||
definition north {A : Type} : susp A :=
|
||||
inl star
|
||||
|
||||
definition south {A : Type} : susp A :=
|
||||
inr star
|
||||
|
||||
definition merid (a : A) : @north A = @south A :=
|
||||
glue a
|
||||
|
||||
protected definition rec {P : susp A → Type} (PN : P north) (PS : P south)
|
||||
(Pm : Π(a : A), PN =[merid a] PS) (x : susp A) : P x :=
|
||||
begin
|
||||
induction x with u u,
|
||||
{ cases u, exact PN},
|
||||
{ cases u, exact PS},
|
||||
{ apply Pm},
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : susp A → Type} (y : susp A)
|
||||
(PN : P north) (PS : P south) (Pm : Π(a : A), PN =[merid a] PS) : P y :=
|
||||
susp.rec PN PS Pm y
|
||||
|
||||
theorem rec_merid {P : susp A → Type} (PN : P north) (PS : P south)
|
||||
(Pm : Π(a : A), PN =[merid a] PS) (a : A)
|
||||
: apdo (susp.rec PN PS Pm) (merid a) = Pm a :=
|
||||
!rec_glue
|
||||
|
||||
protected definition elim {P : Type} (PN : P) (PS : P) (Pm : A → PN = PS)
|
||||
(x : susp A) : P :=
|
||||
susp.rec PN PS (λa, pathover_of_eq (Pm a)) x
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : susp A)
|
||||
(PN : P) (PS : P) (Pm : A → PN = PS) : P :=
|
||||
susp.elim PN PS Pm x
|
||||
|
||||
theorem elim_merid {P : Type} {PN PS : P} (Pm : A → PN = PS) (a : A)
|
||||
: ap (susp.elim PN PS Pm) (merid a) = Pm a :=
|
||||
begin
|
||||
apply eq_of_fn_eq_fn_inv !(pathover_constant (merid a)),
|
||||
rewrite [▸*,-apdo_eq_pathover_of_eq_ap,↑susp.elim,rec_merid],
|
||||
end
|
||||
|
||||
protected definition elim_type (PN : Type) (PS : Type) (Pm : A → PN ≃ PS)
|
||||
(x : susp A) : Type :=
|
||||
susp.elim PN PS (λa, ua (Pm a)) x
|
||||
|
||||
protected definition elim_type_on [reducible] (x : susp A)
|
||||
(PN : Type) (PS : Type) (Pm : A → PN ≃ PS) : Type :=
|
||||
susp.elim_type PN PS Pm x
|
||||
|
||||
theorem elim_type_merid (PN : Type) (PS : Type) (Pm : A → PN ≃ PS)
|
||||
(a : A) : transport (susp.elim_type PN PS Pm) (merid a) = Pm a :=
|
||||
by rewrite [tr_eq_cast_ap_fn,↑susp.elim_type,elim_merid];apply cast_ua_fn
|
||||
|
||||
end susp
|
||||
|
||||
attribute susp.north susp.south [constructor]
|
||||
attribute susp.rec susp.elim [unfold 6] [recursor 6]
|
||||
attribute susp.elim_type [unfold 5]
|
||||
attribute susp.rec_on susp.elim_on [unfold 3]
|
||||
attribute susp.elim_type_on [unfold 2]
|
||||
|
||||
namespace susp
|
||||
open pointed
|
||||
|
||||
variables {X Y Z : pType}
|
||||
|
||||
definition pointed_susp [instance] [constructor] (X : Type) : pointed (susp X) :=
|
||||
pointed.mk north
|
||||
|
||||
definition psusp [constructor] (X : Type) : pType :=
|
||||
pointed.mk' (susp X)
|
||||
|
||||
definition psusp_functor (f : X →* Y) : psusp X →* psusp Y :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro x, induction x,
|
||||
apply north,
|
||||
apply south,
|
||||
exact merid (f a)},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition psusp_functor_compose (g : Y →* Z) (f : X →* Y)
|
||||
: psusp_functor (g ∘* f) ~* psusp_functor g ∘* psusp_functor f :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro a, induction a,
|
||||
{ reflexivity},
|
||||
{ reflexivity},
|
||||
{ apply eq_pathover, apply hdeg_square,
|
||||
rewrite [▸*,ap_compose' _ (psusp_functor f),↑psusp_functor,+elim_merid]}},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
-- adjunction from Coq-HoTT
|
||||
|
||||
definition loop_susp_unit [constructor] (X : pType) : X →* Ω(psusp X) :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro x, exact merid x ⬝ (merid pt)⁻¹},
|
||||
{ apply con.right_inv},
|
||||
end
|
||||
|
||||
definition loop_susp_unit_natural (f : X →* Y)
|
||||
: loop_susp_unit Y ∘* f ~* ap1 (psusp_functor f) ∘* loop_susp_unit X :=
|
||||
begin
|
||||
induction X with X x, induction Y with Y y, induction f with f pf, esimp at *, induction pf,
|
||||
fconstructor,
|
||||
{ intro x', esimp [psusp_functor], symmetry,
|
||||
exact
|
||||
!idp_con ⬝
|
||||
(!ap_con ⬝
|
||||
whisker_left _ !ap_inv) ⬝
|
||||
(!elim_merid ◾ (inverse2 !elim_merid))
|
||||
},
|
||||
{ rewrite [▸*,idp_con (con.right_inv _)],
|
||||
apply inv_con_eq_of_eq_con,
|
||||
refine _ ⬝ !con.assoc',
|
||||
rewrite inverse2_right_inv,
|
||||
refine _ ⬝ !con.assoc',
|
||||
rewrite [ap_con_right_inv],
|
||||
unfold psusp_functor,
|
||||
xrewrite [idp_con_idp, -ap_compose (concat idp)]},
|
||||
end
|
||||
|
||||
definition loop_susp_counit [constructor] (X : pType) : psusp (Ω X) →* X :=
|
||||
begin
|
||||
fconstructor,
|
||||
{ intro x, induction x, exact pt, exact pt, exact a},
|
||||
{ reflexivity},
|
||||
end
|
||||
|
||||
definition loop_susp_counit_natural (f : X →* Y)
|
||||
: f ∘* loop_susp_counit X ~* loop_susp_counit Y ∘* (psusp_functor (ap1 f)) :=
|
||||
begin
|
||||
induction X with X x, induction Y with Y y, induction f with f pf, esimp at *, induction pf,
|
||||
fconstructor,
|
||||
{ intro x', induction x' with p,
|
||||
{ reflexivity},
|
||||
{ reflexivity},
|
||||
{ esimp, apply eq_pathover, apply hdeg_square,
|
||||
xrewrite [ap_compose' f, ap_compose' (susp.elim (f x) (f x) (λ (a : f x = f x), a)),▸*],
|
||||
xrewrite [+elim_merid,▸*,idp_con]}},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition loop_susp_counit_unit (X : pType)
|
||||
: ap1 (loop_susp_counit X) ∘* loop_susp_unit (Ω X) ~* pid (Ω X) :=
|
||||
begin
|
||||
induction X with X x, fconstructor,
|
||||
{ intro p, esimp,
|
||||
refine !idp_con ⬝
|
||||
(!ap_con ⬝
|
||||
whisker_left _ !ap_inv) ⬝
|
||||
(!elim_merid ◾ inverse2 !elim_merid)},
|
||||
{ rewrite [▸*,inverse2_right_inv (elim_merid id idp)],
|
||||
refine !con.assoc ⬝ _,
|
||||
xrewrite [ap_con_right_inv (susp.elim x x (λa, a)) (merid idp),idp_con_idp,-ap_compose]}
|
||||
end
|
||||
|
||||
definition loop_susp_unit_counit (X : pType)
|
||||
: loop_susp_counit (psusp X) ∘* psusp_functor (loop_susp_unit X) ~* pid (psusp X) :=
|
||||
begin
|
||||
induction X with X x, fconstructor,
|
||||
{ intro x', induction x',
|
||||
{ reflexivity},
|
||||
{ exact merid pt},
|
||||
{ apply eq_pathover,
|
||||
xrewrite [▸*, ap_id, ap_compose' (susp.elim north north (λa, a)), +elim_merid,▸*],
|
||||
apply square_of_eq, exact !idp_con ⬝ !inv_con_cancel_right⁻¹}},
|
||||
{ reflexivity}
|
||||
end
|
||||
|
||||
definition susp_adjoint_loop (X Y : pType) : map₊ (pointed.mk' (susp X)) Y ≃ map₊ X (Ω Y) :=
|
||||
begin
|
||||
fapply equiv.MK,
|
||||
{ intro f, exact ap1 f ∘* loop_susp_unit X},
|
||||
{ intro g, exact loop_susp_counit Y ∘* psusp_functor g},
|
||||
{ intro g, apply eq_of_phomotopy, esimp,
|
||||
refine !pwhisker_right !ap1_compose ⬝* _,
|
||||
refine !passoc ⬝* _,
|
||||
refine !pwhisker_left !loop_susp_unit_natural⁻¹* ⬝* _,
|
||||
refine !passoc⁻¹* ⬝* _,
|
||||
refine !pwhisker_right !loop_susp_counit_unit ⬝* _,
|
||||
apply pid_comp},
|
||||
{ intro f, apply eq_of_phomotopy, esimp,
|
||||
refine !pwhisker_left !psusp_functor_compose ⬝* _,
|
||||
refine !passoc⁻¹* ⬝* _,
|
||||
refine !pwhisker_right !loop_susp_counit_natural⁻¹* ⬝* _,
|
||||
refine !passoc ⬝* _,
|
||||
refine !pwhisker_left !loop_susp_unit_counit ⬝* _,
|
||||
apply comp_pid},
|
||||
end
|
||||
|
||||
definition susp_adjoint_loop_nat_right (f : psusp X →* Y) (g : Y →* Z)
|
||||
: susp_adjoint_loop X Z (g ∘* f) ~* ap1 g ∘* susp_adjoint_loop X Y f :=
|
||||
begin
|
||||
esimp [susp_adjoint_loop],
|
||||
refine _ ⬝* !passoc,
|
||||
apply pwhisker_right,
|
||||
apply ap1_compose
|
||||
end
|
||||
|
||||
definition susp_adjoint_loop_nat_left (f : Y →* Ω Z) (g : X →* Y)
|
||||
: (susp_adjoint_loop X Z)⁻¹ᵉ (f ∘* g) ~* (susp_adjoint_loop Y Z)⁻¹ᵉ f ∘* psusp_functor g :=
|
||||
begin
|
||||
esimp [susp_adjoint_loop],
|
||||
refine _ ⬝* !passoc⁻¹*,
|
||||
apply pwhisker_left,
|
||||
apply psusp_functor_compose
|
||||
end
|
||||
|
||||
end susp
|
||||
|
|
@ -1,100 +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 torus
|
||||
-/
|
||||
|
||||
import hit.two_quotient
|
||||
|
||||
open two_quotient eq bool unit equiv
|
||||
|
||||
namespace torus
|
||||
|
||||
open e_closure relation
|
||||
definition torus_R (x y : unit) := bool
|
||||
local infix `⬝r`:75 := @e_closure.trans unit torus_R star star star
|
||||
local postfix `⁻¹ʳ`:(max+10) := @e_closure.symm unit torus_R star star
|
||||
local notation `[`:max a `]`:0 := @e_closure.of_rel unit torus_R star star a
|
||||
|
||||
inductive torus_Q : Π⦃x y : unit⦄, e_closure torus_R x y → e_closure torus_R x y → Type :=
|
||||
| Qmk : torus_Q ([ff] ⬝r [tt]) ([tt] ⬝r [ff])
|
||||
|
||||
open torus_Q
|
||||
|
||||
definition torus := two_quotient torus_R torus_Q
|
||||
notation `T²` := torus
|
||||
definition base : torus := incl0 _ _ star
|
||||
definition loop1 : base = base := incl1 _ _ ff
|
||||
definition loop2 : base = base := incl1 _ _ tt
|
||||
definition surf' : loop1 ⬝ loop2 = loop2 ⬝ loop1 :=
|
||||
incl2 _ _ Qmk
|
||||
definition surf : square loop1 loop1 loop2 loop2 :=
|
||||
square_of_eq (incl2 _ _ Qmk)
|
||||
|
||||
protected definition rec {P : torus → Type} (Pb : P base) (Pl1 : Pb =[loop1] Pb)
|
||||
(Pl2 : Pb =[loop2] Pb) (Ps : squareover P surf Pl1 Pl1 Pl2 Pl2) (x : torus) : P x :=
|
||||
begin
|
||||
induction x,
|
||||
{ induction a, exact Pb},
|
||||
{ induction s: induction a; induction a',
|
||||
{ exact Pl1},
|
||||
{ exact Pl2}},
|
||||
{ induction q, esimp, apply change_path_of_pathover, apply pathover_of_squareover, exact Ps},
|
||||
end
|
||||
|
||||
protected definition rec_on [reducible] {P : torus → Type} (x : torus) (Pb : P base)
|
||||
(Pl1 : Pb =[loop1] Pb) (Pl2 : Pb =[loop2] Pb) (Ps : squareover P surf Pl1 Pl1 Pl2 Pl2) : P x :=
|
||||
torus.rec Pb Pl1 Pl2 Ps x
|
||||
|
||||
theorem rec_loop1 {P : torus → Type} (Pb : P base) (Pl1 : Pb =[loop1] Pb)
|
||||
(Pl2 : Pb =[loop2] Pb) (Ps : squareover P surf Pl1 Pl1 Pl2 Pl2)
|
||||
: apdo (torus.rec Pb Pl1 Pl2 Ps) loop1 = Pl1 :=
|
||||
!rec_incl1
|
||||
|
||||
theorem rec_loop2 {P : torus → Type} (Pb : P base) (Pl1 : Pb =[loop1] Pb)
|
||||
(Pl2 : Pb =[loop2] Pb) (Ps : squareover P surf Pl1 Pl1 Pl2 Pl2)
|
||||
: apdo (torus.rec Pb Pl1 Pl2 Ps) loop2 = Pl2 :=
|
||||
!rec_incl1
|
||||
|
||||
protected definition elim {P : Type} (Pb : P) (Pl1 : Pb = Pb) (Pl2 : Pb = Pb)
|
||||
(Ps : square Pl1 Pl1 Pl2 Pl2) (x : torus) : P :=
|
||||
begin
|
||||
induction x,
|
||||
{ exact Pb},
|
||||
{ induction s,
|
||||
{ exact Pl1},
|
||||
{ exact Pl2}},
|
||||
{ induction q, apply eq_of_square, exact Ps},
|
||||
end
|
||||
|
||||
protected definition elim_on [reducible] {P : Type} (x : torus) (Pb : P)
|
||||
(Pl1 : Pb = Pb) (Pl2 : Pb = Pb) (Ps : square Pl1 Pl1 Pl2 Pl2) : P :=
|
||||
torus.elim Pb Pl1 Pl2 Ps x
|
||||
|
||||
definition elim_loop1 {P : Type} {Pb : P} {Pl1 : Pb = Pb} {Pl2 : Pb = Pb}
|
||||
(Ps : square Pl1 Pl1 Pl2 Pl2) : ap (torus.elim Pb Pl1 Pl2 Ps) loop1 = Pl1 :=
|
||||
!elim_incl1
|
||||
|
||||
definition elim_loop2 {P : Type} {Pb : P} {Pl1 : Pb = Pb} {Pl2 : Pb = Pb}
|
||||
(Ps : square Pl1 Pl1 Pl2 Pl2) : ap (torus.elim Pb Pl1 Pl2 Ps) loop2 = Pl2 :=
|
||||
!elim_incl1
|
||||
|
||||
theorem elim_surf {P : Type} {Pb : P} {Pl1 : Pb = Pb} {Pl2 : Pb = Pb}
|
||||
(Ps : square Pl1 Pl1 Pl2 Pl2)
|
||||
: whisker_square (elim_loop1 Ps) (elim_loop1 Ps) (elim_loop2 Ps) (elim_loop2 Ps)
|
||||
(aps (torus.elim Pb Pl1 Pl2 Ps) surf) = Ps :=
|
||||
begin
|
||||
apply whisker_square_aps_eq,
|
||||
apply elim_incl2
|
||||
end
|
||||
|
||||
end torus
|
||||
|
||||
attribute torus.base [constructor]
|
||||
attribute torus.rec torus.elim [unfold 6] [recursor 6]
|
||||
--attribute torus.elim_type [unfold 5]
|
||||
attribute torus.rec_on torus.elim_on [unfold 2]
|
||||
--attribute torus.elim_type_on [unfold 1]
|
||||
|
|
@ -1,82 +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, Ulrik Buchholtz
|
||||
|
||||
The Wedge Sum of Two pType Types
|
||||
-/
|
||||
import hit.pointed_pushout .connectedness
|
||||
|
||||
open eq pushout pointed unit trunc_index
|
||||
|
||||
definition pwedge (A B : Type*) : Type* := ppushout (pconst punit A) (pconst punit B)
|
||||
|
||||
namespace wedge
|
||||
|
||||
-- TODO maybe find a cleaner proof
|
||||
protected definition unit (A : Type*) : A ≃* pwedge punit A :=
|
||||
begin
|
||||
fapply pequiv_of_pmap,
|
||||
{ fapply pmap.mk, intro a, apply pinr a, apply respect_pt },
|
||||
{ fapply is_equiv.adjointify, intro x, fapply pushout.elim_on x,
|
||||
exact λ x, Point A, exact id, intro u, reflexivity,
|
||||
intro x, fapply pushout.rec_on x, intro u, cases u, esimp, apply (glue unit.star)⁻¹,
|
||||
intro a, reflexivity,
|
||||
intro u, cases u, esimp, apply eq_pathover,
|
||||
refine _ ⬝hp !ap_id⁻¹, fapply eq_hconcat, apply ap_compose inr,
|
||||
krewrite elim_glue, fapply eq_hconcat, apply ap_idp, apply square_of_eq,
|
||||
apply con.left_inv,
|
||||
intro a, reflexivity},
|
||||
end
|
||||
end wedge
|
||||
|
||||
open trunc is_trunc function homotopy
|
||||
namespace wedge_extension
|
||||
section
|
||||
-- The wedge connectivity lemma (Lemma 8.6.2)
|
||||
parameters {A B : Type*} (n m : ℕ)
|
||||
[cA : is_conn n A] [cB : is_conn m B]
|
||||
(P : A → B → (m + n)-Type)
|
||||
(f : Πa : A, P a pt)
|
||||
(g : Πb : B, P pt b)
|
||||
(p : f pt = g pt)
|
||||
|
||||
include cA cB
|
||||
private definition Q (a : A) : (n.-1)-Type :=
|
||||
trunctype.mk
|
||||
(fiber (λs : (Πb : B, P a b), s (Point B)) (f a))
|
||||
abstract begin
|
||||
refine @is_conn.elim_general (m.-1) _ _ _ (λb, trunctype.mk (P a b) _) (f a),
|
||||
rewrite [-succ_add_succ, of_nat_add_of_nat], intro b, apply trunctype.struct
|
||||
end end
|
||||
|
||||
private definition Q_sec : Πa : A, Q a :=
|
||||
is_conn.elim Q (fiber.mk g p⁻¹)
|
||||
|
||||
protected definition ext : Π(a : A)(b : B), P a b :=
|
||||
λa, fiber.point (Q_sec a)
|
||||
|
||||
protected definition β_left (a : A) : ext a (Point B) = f a :=
|
||||
fiber.point_eq (Q_sec a)
|
||||
|
||||
private definition coh_aux : Σq : ext (Point A) = g,
|
||||
β_left (Point A) = ap (λs : (Πb : B, P (Point A) b), s (Point B)) q ⬝ p⁻¹ :=
|
||||
equiv.to_fun (fiber.fiber_eq_equiv (Q_sec (Point A)) (fiber.mk g p⁻¹))
|
||||
(is_conn.elim_β Q (fiber.mk g p⁻¹))
|
||||
|
||||
protected definition β_right (b : B) : ext (Point A) b = g b :=
|
||||
apd10 (sigma.pr1 coh_aux) b
|
||||
|
||||
private definition lem : β_left (Point A) = β_right (Point B) ⬝ p⁻¹ :=
|
||||
begin
|
||||
unfold β_right, unfold β_left,
|
||||
krewrite (apd10_eq_ap_eval (sigma.pr1 coh_aux) (Point B)),
|
||||
exact sigma.pr2 coh_aux,
|
||||
end
|
||||
|
||||
protected definition coh
|
||||
: (β_left (Point A))⁻¹ ⬝ β_right (Point B) = p :=
|
||||
by rewrite [lem,con_inv,inv_inv,con.assoc,con.left_inv]
|
||||
|
||||
end
|
||||
end wedge_extension
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Reference in a new issue