diff --git a/hott/.gitignore b/hott/.gitignore deleted file mode 100644 index de9e6a3dd3..0000000000 --- a/hott/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -.ninja_deps -.ninja_log -TAGS -build.ninja diff --git a/hott/.project b/hott/.project deleted file mode 100644 index 01cefdf13b..0000000000 --- a/hott/.project +++ /dev/null @@ -1,4 +0,0 @@ -+ *.hlean -- flycheck*.lean -- flycheck*.hlean -- .#*.hlean \ No newline at end of file diff --git a/hott/algebra/algebra.md b/hott/algebra/algebra.md deleted file mode 100644 index 03d2a88b9d..0000000000 --- a/hott/algebra/algebra.md +++ /dev/null @@ -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 diff --git a/hott/algebra/binary.hlean b/hott/algebra/binary.hlean deleted file mode 100644 index 18a5525cd4..0000000000 --- a/hott/algebra/binary.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/bundled.hlean b/hott/algebra/bundled.hlean deleted file mode 100644 index 1202621354..0000000000 --- a/hott/algebra/bundled.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/category.hlean b/hott/algebra/category/category.hlean deleted file mode 100644 index 8200b84e19..0000000000 --- a/hott/algebra/category/category.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/category.md b/hott/algebra/category/category.md deleted file mode 100644 index 39d311a540..0000000000 --- a/hott/algebra/category/category.md +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/comma.hlean b/hott/algebra/category/constructions/comma.hlean deleted file mode 100644 index 5f51b89d12..0000000000 --- a/hott/algebra/category/constructions/comma.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/cone.hlean b/hott/algebra/category/constructions/cone.hlean deleted file mode 100644 index 1eaf4b82f3..0000000000 --- a/hott/algebra/category/constructions/cone.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/constructions.md b/hott/algebra/category/constructions/constructions.md deleted file mode 100644 index 56c067e6d1..0000000000 --- a/hott/algebra/category/constructions/constructions.md +++ /dev/null @@ -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) diff --git a/hott/algebra/category/constructions/default.hlean b/hott/algebra/category/constructions/default.hlean deleted file mode 100644 index c8d65bd74d..0000000000 --- a/hott/algebra/category/constructions/default.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/discrete.hlean b/hott/algebra/category/constructions/discrete.hlean deleted file mode 100644 index c2e6b9da09..0000000000 --- a/hott/algebra/category/constructions/discrete.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/finite_cats.hlean b/hott/algebra/category/constructions/finite_cats.hlean deleted file mode 100644 index 1e812dec97..0000000000 --- a/hott/algebra/category/constructions/finite_cats.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/functor.hlean b/hott/algebra/category/constructions/functor.hlean deleted file mode 100644 index 866e72be7a..0000000000 --- a/hott/algebra/category/constructions/functor.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/indiscrete.hlean b/hott/algebra/category/constructions/indiscrete.hlean deleted file mode 100644 index 4d1bcdbcad..0000000000 --- a/hott/algebra/category/constructions/indiscrete.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/initial.hlean b/hott/algebra/category/constructions/initial.hlean deleted file mode 100644 index e73038823e..0000000000 --- a/hott/algebra/category/constructions/initial.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/opposite.hlean b/hott/algebra/category/constructions/opposite.hlean deleted file mode 100644 index 1af224bc62..0000000000 --- a/hott/algebra/category/constructions/opposite.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/order.hlean b/hott/algebra/category/constructions/order.hlean deleted file mode 100644 index 3e4ca2bf98..0000000000 --- a/hott/algebra/category/constructions/order.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/product.hlean b/hott/algebra/category/constructions/product.hlean deleted file mode 100644 index 777488013d..0000000000 --- a/hott/algebra/category/constructions/product.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/set.hlean b/hott/algebra/category/constructions/set.hlean deleted file mode 100644 index 826bee75fa..0000000000 --- a/hott/algebra/category/constructions/set.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/sum.hlean b/hott/algebra/category/constructions/sum.hlean deleted file mode 100644 index 0460a0d0ac..0000000000 --- a/hott/algebra/category/constructions/sum.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/constructions/terminal.hlean b/hott/algebra/category/constructions/terminal.hlean deleted file mode 100644 index 4441079034..0000000000 --- a/hott/algebra/category/constructions/terminal.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/default.hlean b/hott/algebra/category/default.hlean deleted file mode 100644 index 6fdf85f8c0..0000000000 --- a/hott/algebra/category/default.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/adjoint.hlean b/hott/algebra/category/functor/adjoint.hlean deleted file mode 100644 index 7ea163a637..0000000000 --- a/hott/algebra/category/functor/adjoint.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/adjoint2.hlean b/hott/algebra/category/functor/adjoint2.hlean deleted file mode 100644 index aadcb31001..0000000000 --- a/hott/algebra/category/functor/adjoint2.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/attributes.hlean b/hott/algebra/category/functor/attributes.hlean deleted file mode 100644 index a97ba8b275..0000000000 --- a/hott/algebra/category/functor/attributes.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/basic.hlean b/hott/algebra/category/functor/basic.hlean deleted file mode 100644 index 9a7f6007f7..0000000000 --- a/hott/algebra/category/functor/basic.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/default.hlean b/hott/algebra/category/functor/default.hlean deleted file mode 100644 index 8274c00c1c..0000000000 --- a/hott/algebra/category/functor/default.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/equivalence.hlean b/hott/algebra/category/functor/equivalence.hlean deleted file mode 100644 index 6b303a7e88..0000000000 --- a/hott/algebra/category/functor/equivalence.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/examples.hlean b/hott/algebra/category/functor/examples.hlean deleted file mode 100644 index 28e698c7ed..0000000000 --- a/hott/algebra/category/functor/examples.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/exponential_laws.hlean b/hott/algebra/category/functor/exponential_laws.hlean deleted file mode 100644 index 28fd2f7bd5..0000000000 --- a/hott/algebra/category/functor/exponential_laws.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/functor/functor.md b/hott/algebra/category/functor/functor.md deleted file mode 100644 index 7297fcd754..0000000000 --- a/hott/algebra/category/functor/functor.md +++ /dev/null @@ -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). \ No newline at end of file diff --git a/hott/algebra/category/functor/yoneda.hlean b/hott/algebra/category/functor/yoneda.hlean deleted file mode 100644 index 3a5c79bbcd..0000000000 --- a/hott/algebra/category/functor/yoneda.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/groupoid.hlean b/hott/algebra/category/groupoid.hlean deleted file mode 100644 index 4642a7d9a0..0000000000 --- a/hott/algebra/category/groupoid.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/iso.hlean b/hott/algebra/category/iso.hlean deleted file mode 100644 index 338a787e76..0000000000 --- a/hott/algebra/category/iso.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/adjoint.hlean b/hott/algebra/category/limits/adjoint.hlean deleted file mode 100644 index 1e4916d30b..0000000000 --- a/hott/algebra/category/limits/adjoint.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/colimits.hlean b/hott/algebra/category/limits/colimits.hlean deleted file mode 100644 index 5625db6bd1..0000000000 --- a/hott/algebra/category/limits/colimits.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/default.hlean b/hott/algebra/category/limits/default.hlean deleted file mode 100644 index e936fa68fb..0000000000 --- a/hott/algebra/category/limits/default.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/functor.hlean b/hott/algebra/category/limits/functor.hlean deleted file mode 100644 index aadd4e3a43..0000000000 --- a/hott/algebra/category/limits/functor.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/functor_preserve.hlean b/hott/algebra/category/limits/functor_preserve.hlean deleted file mode 100644 index 7d84db9d8b..0000000000 --- a/hott/algebra/category/limits/functor_preserve.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/limits.hlean b/hott/algebra/category/limits/limits.hlean deleted file mode 100644 index 292963530c..0000000000 --- a/hott/algebra/category/limits/limits.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/limits/limits.md b/hott/algebra/category/limits/limits.md deleted file mode 100644 index c97db4c234..0000000000 --- a/hott/algebra/category/limits/limits.md +++ /dev/null @@ -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` diff --git a/hott/algebra/category/limits/set.hlean b/hott/algebra/category/limits/set.hlean deleted file mode 100644 index d99d533cd0..0000000000 --- a/hott/algebra/category/limits/set.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/nat_trans.hlean b/hott/algebra/category/nat_trans.hlean deleted file mode 100644 index b7421ff7e0..0000000000 --- a/hott/algebra/category/nat_trans.hlean +++ /dev/null @@ -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] diff --git a/hott/algebra/category/precategory.hlean b/hott/algebra/category/precategory.hlean deleted file mode 100644 index b3a88b12c1..0000000000 --- a/hott/algebra/category/precategory.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/category/strict.hlean b/hott/algebra/category/strict.hlean deleted file mode 100644 index 241fe32d6d..0000000000 --- a/hott/algebra/category/strict.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/e_closure.hlean b/hott/algebra/e_closure.hlean deleted file mode 100644 index 5a01c4ba78..0000000000 --- a/hott/algebra/e_closure.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/field.hlean b/hott/algebra/field.hlean deleted file mode 100644 index 094f3925ef..0000000000 --- a/hott/algebra/field.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/group.hlean b/hott/algebra/group.hlean deleted file mode 100644 index 1021211e73..0000000000 --- a/hott/algebra/group.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/homotopy_group.hlean b/hott/algebra/homotopy_group.hlean deleted file mode 100644 index 8844ba18c0..0000000000 --- a/hott/algebra/homotopy_group.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/hott.hlean b/hott/algebra/hott.hlean deleted file mode 100644 index a4b81d20eb..0000000000 --- a/hott/algebra/hott.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/lattice.hlean b/hott/algebra/lattice.hlean deleted file mode 100644 index 70b289766b..0000000000 --- a/hott/algebra/lattice.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/order.hlean b/hott/algebra/order.hlean deleted file mode 100644 index 47acbf3a72..0000000000 --- a/hott/algebra/order.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/ordered_field.hlean b/hott/algebra/ordered_field.hlean deleted file mode 100644 index b4e226390b..0000000000 --- a/hott/algebra/ordered_field.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/ordered_group.hlean b/hott/algebra/ordered_group.hlean deleted file mode 100644 index 6edcaf5436..0000000000 --- a/hott/algebra/ordered_group.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/ordered_ring.hlean b/hott/algebra/ordered_ring.hlean deleted file mode 100644 index da876703be..0000000000 --- a/hott/algebra/ordered_ring.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/priority.hlean b/hott/algebra/priority.hlean deleted file mode 100644 index aa2ac4c5c8..0000000000 --- a/hott/algebra/priority.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/relation.hlean b/hott/algebra/relation.hlean deleted file mode 100644 index 0b058c5d24..0000000000 --- a/hott/algebra/relation.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/ring.hlean b/hott/algebra/ring.hlean deleted file mode 100644 index ce8105cebe..0000000000 --- a/hott/algebra/ring.hlean +++ /dev/null @@ -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 diff --git a/hott/algebra/trunc_group.hlean b/hott/algebra/trunc_group.hlean deleted file mode 100644 index a3911246d5..0000000000 --- a/hott/algebra/trunc_group.hlean +++ /dev/null @@ -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 diff --git a/hott/arity.hlean b/hott/arity.hlean deleted file mode 100644 index 8444a40b6f..0000000000 --- a/hott/arity.hlean +++ /dev/null @@ -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 diff --git a/hott/book.md b/hott/book.md deleted file mode 100644 index 7d9f8a9ae4..0000000000 --- a/hott/book.md +++ /dev/null @@ -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 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 diff --git a/hott/core.hlean b/hott/core.hlean deleted file mode 100644 index 0c35225dfa..0000000000 --- a/hott/core.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/cube.hlean b/hott/cubical/cube.hlean deleted file mode 100644 index 51af5b37cb..0000000000 --- a/hott/cubical/cube.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/cubeover.hlean b/hott/cubical/cubeover.hlean deleted file mode 100644 index 87727cfed1..0000000000 --- a/hott/cubical/cubeover.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/cubical.md b/hott/cubical/cubical.md deleted file mode 100644 index 62fce5fa58..0000000000 --- a/hott/cubical/cubical.md +++ /dev/null @@ -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) diff --git a/hott/cubical/default.hlean b/hott/cubical/default.hlean deleted file mode 100644 index fbf7c846e4..0000000000 --- a/hott/cubical/default.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/pathover2.hlean b/hott/cubical/pathover2.hlean deleted file mode 100644 index 193ac69c78..0000000000 --- a/hott/cubical/pathover2.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/square.hlean b/hott/cubical/square.hlean deleted file mode 100644 index 99635fe454..0000000000 --- a/hott/cubical/square.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/square2.hlean b/hott/cubical/square2.hlean deleted file mode 100644 index 96e4356a68..0000000000 --- a/hott/cubical/square2.hlean +++ /dev/null @@ -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 diff --git a/hott/cubical/squareover.hlean b/hott/cubical/squareover.hlean deleted file mode 100644 index e3d0484877..0000000000 --- a/hott/cubical/squareover.hlean +++ /dev/null @@ -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 diff --git a/hott/eq2.hlean b/hott/eq2.hlean deleted file mode 100644 index 493ab7d797..0000000000 --- a/hott/eq2.hlean +++ /dev/null @@ -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 diff --git a/hott/function.hlean b/hott/function.hlean deleted file mode 100644 index 25c569ca81..0000000000 --- a/hott/function.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/coeq.hlean b/hott/hit/coeq.hlean deleted file mode 100644 index d10da154c7..0000000000 --- a/hott/hit/coeq.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/colimit.hlean b/hott/hit/colimit.hlean deleted file mode 100644 index f877f4a966..0000000000 --- a/hott/hit/colimit.hlean +++ /dev/null @@ -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] diff --git a/hott/hit/hit.md b/hott/hit/hit.md deleted file mode 100644 index c73e0dbd54..0000000000 --- a/hott/hit/hit.md +++ /dev/null @@ -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 \ No newline at end of file diff --git a/hott/hit/pointed_pushout.hlean b/hott/hit/pointed_pushout.hlean deleted file mode 100644 index 2431ae8a01..0000000000 --- a/hott/hit/pointed_pushout.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/pushout.hlean b/hott/hit/pushout.hlean deleted file mode 100644 index 9eef15b8be..0000000000 --- a/hott/hit/pushout.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/quotient.hlean b/hott/hit/quotient.hlean deleted file mode 100644 index 88f320cd53..0000000000 --- a/hott/hit/quotient.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/quotient_functor.hlean b/hott/hit/quotient_functor.hlean deleted file mode 100644 index 36d09b0ae7..0000000000 --- a/hott/hit/quotient_functor.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/refl_quotient.hlean b/hott/hit/refl_quotient.hlean deleted file mode 100644 index 3f5cc05e1e..0000000000 --- a/hott/hit/refl_quotient.hlean +++ /dev/null @@ -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] diff --git a/hott/hit/set_quotient.hlean b/hott/hit/set_quotient.hlean deleted file mode 100644 index 9b75b648ef..0000000000 --- a/hott/hit/set_quotient.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/trunc.hlean b/hott/hit/trunc.hlean deleted file mode 100644 index 1501b2e2ae..0000000000 --- a/hott/hit/trunc.hlean +++ /dev/null @@ -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 diff --git a/hott/hit/two_quotient.hlean b/hott/hit/two_quotient.hlean deleted file mode 100644 index 25111b9b6a..0000000000 --- a/hott/hit/two_quotient.hlean +++ /dev/null @@ -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] diff --git a/hott/homotopy/cellcomplex.hlean b/hott/homotopy/cellcomplex.hlean deleted file mode 100644 index ad21d442bc..0000000000 --- a/hott/homotopy/cellcomplex.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/circle.hlean b/hott/homotopy/circle.hlean deleted file mode 100644 index ff32cc7814..0000000000 --- a/hott/homotopy/circle.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/cofiber.hlean b/hott/homotopy/cofiber.hlean deleted file mode 100644 index 7ff1801e0d..0000000000 --- a/hott/homotopy/cofiber.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/connectedness.hlean b/hott/homotopy/connectedness.hlean deleted file mode 100644 index f30d809b8a..0000000000 --- a/hott/homotopy/connectedness.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/cylinder.hlean b/hott/homotopy/cylinder.hlean deleted file mode 100644 index 62f661c673..0000000000 --- a/hott/homotopy/cylinder.hlean +++ /dev/null @@ -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] diff --git a/hott/homotopy/homotopy.md b/hott/homotopy/homotopy.md deleted file mode 100644 index 41ca982423..0000000000 --- a/hott/homotopy/homotopy.md +++ /dev/null @@ -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)). \ No newline at end of file diff --git a/hott/homotopy/homotopy_group.hlean b/hott/homotopy/homotopy_group.hlean deleted file mode 100644 index 96276401aa..0000000000 --- a/hott/homotopy/homotopy_group.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/interval.hlean b/hott/homotopy/interval.hlean deleted file mode 100644 index 154511c4ea..0000000000 --- a/hott/homotopy/interval.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/join.hlean b/hott/homotopy/join.hlean deleted file mode 100644 index f1dc334ee7..0000000000 --- a/hott/homotopy/join.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/red_susp.hlean b/hott/homotopy/red_susp.hlean deleted file mode 100644 index a71996e89d..0000000000 --- a/hott/homotopy/red_susp.hlean +++ /dev/null @@ -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] diff --git a/hott/homotopy/smash.hlean b/hott/homotopy/smash.hlean deleted file mode 100644 index 513942f03d..0000000000 --- a/hott/homotopy/smash.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/sphere.hlean b/hott/homotopy/sphere.hlean deleted file mode 100644 index 9f44cf7b32..0000000000 --- a/hott/homotopy/sphere.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/susp.hlean b/hott/homotopy/susp.hlean deleted file mode 100644 index 3d6cadefee..0000000000 --- a/hott/homotopy/susp.hlean +++ /dev/null @@ -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 diff --git a/hott/homotopy/torus.hlean b/hott/homotopy/torus.hlean deleted file mode 100644 index 3a1f55cd99..0000000000 --- a/hott/homotopy/torus.hlean +++ /dev/null @@ -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] diff --git a/hott/homotopy/wedge.hlean b/hott/homotopy/wedge.hlean deleted file mode 100644 index fc33ce52ca..0000000000 --- a/hott/homotopy/wedge.hlean +++ /dev/null @@ -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 diff --git a/hott/hott.md b/hott/hott.md deleted file mode 100644 index 4df47054cf..0000000000 --- a/hott/hott.md +++ /dev/null @@ -1,35 +0,0 @@ -The Lean Homotopy Type Theory Library -===================================== - -The Lean Homotopy Type Theory library consists of the following directories: - -* [init](init/init.md) : constants and theorems needed for low-level system operations -* [types](types/types.md) : concrete datatypes and type constructors -* [hit](hit/hit.md): higher inductive types -* [algebra](algebra/algebra.md) : algebraic structures -* [cubical](cubical/cubical.md): cubical types - -The following files don't fit in any of the subfolders: -* [prop_trunc](prop_trunc.hlean): in this file we prove that `is_trunc n A` is a mere proposition. We separate this from [types.trunc](types/trunc.hlean) to avoid circularity in imports. -* [eq2](eq2.hlean): coherence rules for the higher dimensional structure of equality -* [function](function.hlean): embeddings, (split) surjections, retractions -* [arity](arity.hlean) : equality theorems about functions with arity 2 or higher -* [choice](choice.hlean) : theorems about the axiom of choice. -* [logic](logic.hlean) - -You can import the core part of the library by writing [`import core`](core.hlean) - -See [book.md](book.md) for an overview of the sections of the [HoTT book](http://homotopytypetheory.org/book/) which have been covered. - -Lean's homotopy type theory kernel is a version of Martin-Löf Type Theory with: - -* universe polymorphism -* a non-cumulative hierarchy of universes, `Type 0`, `Type 1`, ... -* inductively defined types -* [Two HITs](init/hit.hlean): `n`-truncation and quotients. - -Note that there is no proof-irrelevant or impredicative universe. - -By default, the univalence axiom is declared on initialization. - -See also the [standard library](../library/library.md). We [port](port.md) some files from the standard library to the HoTT library. diff --git a/hott/init/bool.hlean b/hott/init/bool.hlean deleted file mode 100644 index 462f10f998..0000000000 --- a/hott/init/bool.hlean +++ /dev/null @@ -1,28 +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 --/ - -prelude -import init.reserved_notation - --- this is not in init.types, because that file depends on init.num, --- which depends on these definitions -namespace bool - definition cond {A : Type} (b : bool) (t e : A) := - bool.rec_on b e t - - definition bor (a b : bool) := - bool.rec_on a (bool.rec_on b ff tt) tt - - infix || := bor - - definition band (a b : bool) := - bool.rec_on a ff (bool.rec_on b ff tt) - - infix && := band - - definition bnot (a : bool) := - bool.rec_on a tt ff -end bool diff --git a/hott/init/connectives.hlean b/hott/init/connectives.hlean deleted file mode 100644 index 8321d5ca19..0000000000 --- a/hott/init/connectives.hlean +++ /dev/null @@ -1,155 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Jeremy Avigad, Leonardo de Moura, Haitao Zhang - -The propositional connectives. --/ -prelude - -import .types -open unit - -variables {a b c d : Type} - -/- implies -/ - -definition imp (a b : Type) : Type := a → b - -definition imp.id (H : a) : a := H - -definition imp.intro (H : a) (H₂ : b) : a := H - -definition imp.mp (H : a) (H₂ : a → b) : b := -H₂ H - -definition imp.syl (H : a → b) (H₂ : c → a) (Hc : c) : b := -H (H₂ Hc) - -definition imp.left (H : a → b) (H₂ : b → c) (Ha : a) : c := -H₂ (H Ha) - -definition imp_unit (a : Type) : (a → unit) ↔ unit := -iff_unit_intro (imp.intro star) - -definition unit_imp (a : Type) : (unit → a) ↔ a := -iff.intro (assume H, H star) imp.intro - -definition imp_empty (a : Type) : (a → empty) ↔ ¬ a := iff.rfl - -definition empty_imp (a : Type) : (empty → a) ↔ unit := -iff_unit_intro empty.elim - -/- not -/ - -definition not.elim {A : Type} (H1 : ¬a) (H2 : a) : A := absurd H2 H1 - -definition not.mto {a b : Type} : (a → b) → ¬b → ¬a := imp.left - -definition not_imp_not_of_imp {a b : Type} : (a → b) → ¬b → ¬a := not.mto - -definition not_not_of_not_implies : ¬(a → b) → ¬¬a := -not.mto not.elim - -definition not_of_not_implies : ¬(a → b) → ¬b := -not.mto imp.intro - -definition not_not_em : ¬¬(a ⊎ ¬a) := -assume not_em : ¬(a ⊎ ¬a), -not_em (sum.inr (not.mto sum.inl not_em)) - -definition not_iff_not (H : a ↔ b) : ¬a ↔ ¬b := -iff.intro (not.mto (iff.mpr H)) (not.mto (iff.mp H)) - -/- prod -/ - -definition not_prod_of_not_left (b : Type) : ¬a → ¬(a × b) := -not.mto prod.pr1 - -definition not_prod_of_not_right (a : Type) {b : Type} : ¬b → ¬(a × b) := -not.mto prod.pr2 - -definition prod.imp_left (H : a → b) : a × c → b × c := -prod.imp H imp.id - -definition prod.imp_right (H : a → b) : c × a → c × b := -prod.imp imp.id H - -definition prod_of_prod_of_imp_of_imp (H₁ : a × b) (H₂ : a → c) (H₃ : b → d) : c × d := -prod.imp H₂ H₃ H₁ - -definition prod_of_prod_of_imp_left (H₁ : a × c) (H : a → b) : b × c := -prod.imp_left H H₁ - -definition prod_of_prod_of_imp_right (H₁ : c × a) (H : a → b) : c × b := -prod.imp_right H H₁ - -definition prod_imp_iff (a b c : Type) : (a × b → c) ↔ (a → b → c) := -iff.intro (λH a b, H (pair a b)) prod.rec - -/- sum -/ - -definition not_sum : ¬a → ¬b → ¬(a ⊎ b) := sum.rec - -definition sum_of_sum_of_imp_of_imp (H₁ : a ⊎ b) (H₂ : a → c) (H₃ : b → d) : c ⊎ d := -sum.imp H₂ H₃ H₁ - -definition sum_of_sum_of_imp_left (H₁ : a ⊎ c) (H : a → b) : b ⊎ c := -sum.imp_left H H₁ - -definition sum_of_sum_of_imp_right (H₁ : c ⊎ a) (H : a → b) : c ⊎ b := -sum.imp_right H H₁ - -definition sum.elim3 (H : a ⊎ b ⊎ c) (Ha : a → d) (Hb : b → d) (Hc : c → d) : d := -sum.elim H Ha (assume H₂, sum.elim H₂ Hb Hc) - -definition sum_resolve_right (H₁ : a ⊎ b) (H₂ : ¬a) : b := -sum.elim H₁ (not.elim H₂) imp.id - -definition sum_resolve_left (H₁ : a ⊎ b) : ¬b → a := -sum_resolve_right (sum.swap H₁) - -definition sum.imp_distrib : ((a ⊎ b) → c) ↔ ((a → c) × (b → c)) := -iff.intro - (λH, pair (imp.syl H sum.inl) (imp.syl H sum.inr)) - (prod.rec sum.rec) - -definition sum_iff_right_of_imp {a b : Type} (Ha : a → b) : (a ⊎ b) ↔ b := -iff.intro (sum.rec Ha imp.id) sum.inr - -definition sum_iff_left_of_imp {a b : Type} (Hb : b → a) : (a ⊎ b) ↔ a := -iff.intro (sum.rec imp.id Hb) sum.inl - -definition sum_iff_sum (H1 : a ↔ c) (H2 : b ↔ d) : (a ⊎ b) ↔ (c ⊎ d) := -iff.intro (sum.imp (iff.mp H1) (iff.mp H2)) (sum.imp (iff.mpr H1) (iff.mpr H2)) - -/- distributivity -/ - -definition prod.pr1_distrib (a b c : Type) : a × (b ⊎ c) ↔ (a × b) ⊎ (a × c) := -iff.intro - (prod.rec (λH, sum.imp (pair H) (pair H))) - (sum.rec (prod.imp_right sum.inl) (prod.imp_right sum.inr)) - -definition prod.pr2_distrib (a b c : Type) : (a ⊎ b) × c ↔ (a × c) ⊎ (b × c) := -iff.trans (iff.trans !prod.comm !prod.pr1_distrib) (sum_iff_sum !prod.comm !prod.comm) - -definition sum.left_distrib (a b c : Type) : a ⊎ (b × c) ↔ (a ⊎ b) × (a ⊎ c) := -iff.intro - (sum.rec (λH, pair (sum.inl H) (sum.inl H)) (prod.imp sum.inr sum.inr)) - (prod.rec (sum.rec (imp.syl imp.intro sum.inl) (imp.syl sum.imp_right pair))) - -definition sum.right_distrib (a b c : Type) : (a × b) ⊎ c ↔ (a ⊎ c) × (b ⊎ c) := -iff.trans (iff.trans !sum.comm !sum.left_distrib) (prod_congr !sum.comm !sum.comm) - -/- iff -/ - -definition iff.def : (a ↔ b) = ((a → b) × (b → a)) := rfl - -definition pi_imp_pi {A : Type} {P Q : A → Type} (H : Πa, (P a → Q a)) (p : Πa, P a) (a : A) : Q a := -(H a) (p a) - -definition pi_iff_pi {A : Type} {P Q : A → Type} (H : Πa, (P a ↔ Q a)) : (Πa, P a) ↔ (Πa, Q a) := -iff.intro (λp a, iff.elim_left (H a) (p a)) (λq a, iff.elim_right (H a) (q a)) - -definition imp_iff {P : Type} (Q : Type) (p : P) : (P → Q) ↔ Q := -iff.intro (λf, f p) imp.intro diff --git a/hott/init/datatypes.hlean b/hott/init/datatypes.hlean deleted file mode 100644 index 7e626f8acb..0000000000 --- a/hott/init/datatypes.hlean +++ /dev/null @@ -1,105 +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, Jakob von Raumer - -Basic datatypes --/ - -prelude -notation [parsing_only] `Type'` := Type.{_+1} -notation [parsing_only] `Type₊` := Type.{_+1} -notation `Type₀` := Type.{0} -notation `Type₁` := Type.{1} -notation `Type₂` := Type.{2} -notation `Type₃` := Type.{3} - -inductive poly_unit.{l} : Type.{l} := -star : poly_unit - -inductive unit : Type₀ := -star : unit - -inductive empty : Type₀ - -inductive eq.{l} {A : Type.{l}} (a : A) : A → Type.{l} := -refl : eq a a - -structure lift.{l₁ l₂} (A : Type.{l₁}) : Type.{max l₁ l₂} := -up :: (down : A) - -inductive prod (A B : Type) := -mk : A → B → prod A B - -definition prod.pr1 [reducible] [unfold 3] {A B : Type} (p : prod A B) : A := -prod.rec (λ a b, a) p - -definition prod.pr2 [reducible] [unfold 3] {A B : Type} (p : prod A B) : B := -prod.rec (λ a b, b) p - -definition prod.destruct [reducible] := @prod.cases_on - -inductive sum (A B : Type) : Type := -| inl {} : A → sum A B -| inr {} : B → sum A B - -definition sum.intro_left [reducible] {A : Type} (B : Type) (a : A) : sum A B := -sum.inl a - -definition sum.intro_right [reducible] (A : Type) {B : Type} (b : B) : sum A B := -sum.inr b - -inductive sigma {A : Type} (B : A → Type) := -mk : Π (a : A), B a → sigma B - -definition sigma.pr1 [reducible] [unfold 3] {A : Type} {B : A → Type} (p : sigma B) : A := -sigma.rec (λ a b, a) p - -definition sigma.pr2 [reducible] [unfold 3] {A : Type} {B : A → Type} (p : sigma B) : B (sigma.pr1 p) := -sigma.rec (λ a b, b) p - --- pos_num and num are two auxiliary datatypes used when parsing numerals such as 13, 0, 26. --- The parser will generate the terms (pos (bit1 (bit1 (bit0 one)))), zero, and (pos (bit0 (bit1 (bit1 one)))). --- This representation can be coerced in whatever we want (e.g., naturals, integers, reals, etc). -inductive pos_num : Type := -| one : pos_num -| bit1 : pos_num → pos_num -| bit0 : pos_num → pos_num - -namespace pos_num - definition succ (a : pos_num) : pos_num := - pos_num.rec_on a (bit0 one) (λn r, bit0 r) (λn r, bit1 n) -end pos_num - -inductive num : Type := -| zero : num -| pos : pos_num → num - -namespace num - open pos_num - definition succ (a : num) : num := - num.rec_on a (pos one) (λp, pos (succ p)) -end num - -inductive bool : Type := -| ff : bool -| tt : bool - -inductive char : Type := -mk : bool → bool → bool → bool → bool → bool → bool → bool → char - -inductive string : Type := -| empty : string -| str : char → string → string - -inductive option (A : Type) : Type := -| none {} : option A -| some : A → option A - --- Remark: we manually generate the nat.rec_on, nat.induction_on, nat.cases_on and nat.no_confusion. --- We do that because we want 0 instead of nat.zero in these eliminators. -set_option inductive.rec_on false -set_option inductive.cases_on false -inductive nat := -| zero : nat -| succ : nat → nat diff --git a/hott/init/default.hlean b/hott/init/default.hlean deleted file mode 100644 index 8d3e80475e..0000000000 --- a/hott/init/default.hlean +++ /dev/null @@ -1,27 +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, Jakob von Raumer, Floris van Doorn --/ - -prelude -import init.datatypes init.reserved_notation init.tactic init.logic -import init.bool init.num init.relation init.wf -import init.types init.connectives -import init.trunc init.path init.equiv init.util -import init.ua init.funext -import init.hedberg init.nat init.hit init.pathover - -namespace core - export bool unit - export empty (hiding elim) - export sum (hiding elim) - export sigma (hiding pr1 pr2) - export [notation] prod - export [notation] nat - export eq (idp idpath concat inverse transport ap ap10 cast tr_inv homotopy ap11 apd refl) - export [declaration] function - export equiv (to_inv to_right_inv to_left_inv) - export is_equiv (inv right_inv left_inv adjointify) - export [abbreviation] is_trunc -end core diff --git a/hott/init/equiv.hlean b/hott/init/equiv.hlean deleted file mode 100644 index 0c9158419a..0000000000 --- a/hott/init/equiv.hlean +++ /dev/null @@ -1,410 +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, Jakob von Raumer, Floris van Doorn - -Ported from Coq HoTT --/ - -prelude -import .path .function -open eq function lift - -/- Equivalences -/ - --- This is our definition of equivalence. In the HoTT-book it's called --- ihae (half-adjoint equivalence). -structure is_equiv [class] {A B : Type} (f : A → B) := -mk' :: - (inv : B → A) - (right_inv : Πb, f (inv b) = b) - (left_inv : Πa, inv (f a) = a) - (adj : Πx, right_inv (f x) = ap f (left_inv x)) - -attribute is_equiv.inv [reducible] - --- A more bundled version of equivalence -structure equiv (A B : Type) := - (to_fun : A → B) - (to_is_equiv : is_equiv to_fun) - -namespace is_equiv - /- Some instances and closure properties of equivalences -/ - postfix ⁻¹ := inv - /- a second notation for the inverse, which is not overloaded -/ - postfix [parsing_only] `⁻¹ᶠ`:std.prec.max_plus := inv - - section - variables {A B C : Type} (f : A → B) (g : B → C) {f' : A → B} - - -- The variant of mk' where f is explicit. - protected abbreviation mk [constructor] := @is_equiv.mk' A B f - - -- The identity function is an equivalence. - definition is_equiv_id [instance] [constructor] (A : Type) : (is_equiv (id : A → A)) := - is_equiv.mk id id (λa, idp) (λa, idp) (λa, idp) - - -- The composition of two equivalences is, again, an equivalence. - definition is_equiv_compose [constructor] [Hf : is_equiv f] [Hg : is_equiv g] - : is_equiv (g ∘ f) := - is_equiv.mk (g ∘ f) (f⁻¹ ∘ g⁻¹) - abstract (λc, ap g (right_inv f (g⁻¹ c)) ⬝ right_inv g c) end - abstract (λa, ap (inv f) (left_inv g (f a)) ⬝ left_inv f a) end - abstract (λa, (whisker_left _ (adj g (f a))) ⬝ - (ap_con g _ _)⁻¹ ⬝ - ap02 g ((ap_con_eq_con (right_inv f) (left_inv g (f a)))⁻¹ ⬝ - (ap_compose f (inv f) _ ◾ adj f a) ⬝ - (ap_con f _ _)⁻¹ - ) ⬝ - (ap_compose g f _)⁻¹) end - - -- Any function equal to an equivalence is an equivlance as well. - variable {f} - definition is_equiv_eq_closed [Hf : is_equiv f] (Heq : f = f') : is_equiv f' := - eq.rec_on Heq Hf - end - - section - parameters {A B : Type} (f : A → B) (g : B → A) - (ret : Πb, f (g b) = b) (sec : Πa, g (f a) = a) - - private definition adjointify_left_inv' (a : A) : g (f a) = a := - ap g (ap f (inverse (sec a))) ⬝ ap g (ret (f a)) ⬝ sec a - - private theorem adjointify_adj' (a : A) : ret (f a) = ap f (adjointify_left_inv' a) := - let fgretrfa := ap f (ap g (ret (f a))) in - let fgfinvsect := ap f (ap g (ap f (sec a)⁻¹)) in - let fgfa := f (g (f a)) in - let retrfa := ret (f a) in - have eq1 : ap f (sec a) = _, - from calc ap f (sec a) - = idp ⬝ ap f (sec a) : by rewrite idp_con - ... = (ret (f a) ⬝ (ret (f a))⁻¹) ⬝ ap f (sec a) : by rewrite con.right_inv - ... = ((ret fgfa)⁻¹ ⬝ ap (f ∘ g) (ret (f a))) ⬝ ap f (sec a) : by rewrite con_ap_eq_con - ... = ((ret fgfa)⁻¹ ⬝ fgretrfa) ⬝ ap f (sec a) : by rewrite ap_compose - ... = (ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)) : by rewrite con.assoc, - have eq2 : ap f (sec a) ⬝ idp = (ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a)), - from !con_idp ⬝ eq1, - have eq3 : idp = _, - from calc idp - = (ap f (sec a))⁻¹ ⬝ ((ret fgfa)⁻¹ ⬝ (fgretrfa ⬝ ap f (sec a))) : eq_inv_con_of_con_eq eq2 - ... = ((ap f (sec a))⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : by rewrite con.assoc' - ... = (ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ (fgretrfa ⬝ ap f (sec a)) : by rewrite ap_inv - ... = ((ap f (sec a)⁻¹ ⬝ (ret fgfa)⁻¹) ⬝ fgretrfa) ⬝ ap f (sec a) : by rewrite con.assoc' - ... = ((retrfa⁻¹ ⬝ ap (f ∘ g) (ap f (sec a)⁻¹)) ⬝ fgretrfa) ⬝ ap f (sec a) : by rewrite con_ap_eq_con - ... = ((retrfa⁻¹ ⬝ fgfinvsect) ⬝ fgretrfa) ⬝ ap f (sec a) : by rewrite ap_compose - ... = (retrfa⁻¹ ⬝ (fgfinvsect ⬝ fgretrfa)) ⬝ ap f (sec a) : by rewrite con.assoc' - ... = retrfa⁻¹ ⬝ ap f (ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ ap f (sec a) : by rewrite ap_con - ... = retrfa⁻¹ ⬝ (ap f (ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ ap f (sec a)) : by rewrite con.assoc' - ... = retrfa⁻¹ ⬝ ap f ((ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ sec a) : by rewrite -ap_con, - show ret (f a) = ap f ((ap g (ap f (sec a)⁻¹) ⬝ ap g (ret (f a))) ⬝ sec a), - from eq_of_idp_eq_inv_con eq3 - - definition adjointify [constructor] : is_equiv f := - is_equiv.mk f g ret adjointify_left_inv' adjointify_adj' - end - - -- Any function pointwise equal to an equivalence is an equivalence as well. - definition homotopy_closed [constructor] {A B : Type} (f : A → B) {f' : A → B} [Hf : is_equiv f] - (Hty : f ~ f') : is_equiv f' := - adjointify f' - (inv f) - (λ b, (Hty (inv f b))⁻¹ ⬝ right_inv f b) - (λ a, (ap (inv f) (Hty a))⁻¹ ⬝ left_inv f a) - - definition inv_homotopy_closed [constructor] {A B : Type} {f : A → B} {f' : B → A} - [Hf : is_equiv f] (Hty : f⁻¹ ~ f') : is_equiv f := - adjointify f - f' - (λ b, ap f !Hty⁻¹ ⬝ right_inv f b) - (λ a, !Hty⁻¹ ⬝ left_inv f a) - - definition is_equiv_up [instance] [constructor] (A : Type) - : is_equiv (up : A → lift A) := - adjointify up down (λa, by induction a;reflexivity) (λa, idp) - - section - variables {A B C : Type} (f : A → B) {f' : A → B} [Hf : is_equiv f] (g : B → C) - include Hf - - --The inverse of an equivalence is, again, an equivalence. - definition is_equiv_inv [instance] [constructor] : is_equiv f⁻¹ := - adjointify f⁻¹ f (left_inv f) (right_inv f) - - definition cancel_right (g : B → C) [Hgf : is_equiv (g ∘ f)] : (is_equiv g) := - have Hfinv : is_equiv f⁻¹, from is_equiv_inv f, - @homotopy_closed _ _ _ _ (is_equiv_compose f⁻¹ (g ∘ f)) (λb, ap g (@right_inv _ _ f _ b)) - - definition cancel_left (g : C → A) [Hgf : is_equiv (f ∘ g)] : (is_equiv g) := - have Hfinv : is_equiv f⁻¹, from is_equiv_inv f, - @homotopy_closed _ _ _ _ (is_equiv_compose (f ∘ g) f⁻¹) (λa, left_inv f (g a)) - - definition eq_of_fn_eq_fn' {x y : A} (q : f x = f y) : x = y := - (left_inv f x)⁻¹ ⬝ ap f⁻¹ q ⬝ left_inv f y - - theorem ap_eq_of_fn_eq_fn' {x y : A} (q : f x = f y) : ap f (eq_of_fn_eq_fn' f q) = q := - begin - rewrite [↑eq_of_fn_eq_fn',+ap_con,ap_inv,-+adj,-ap_compose,con.assoc, - ap_con_eq_con_ap (right_inv f) q,inv_con_cancel_left,ap_id], - end - - definition is_equiv_ap [instance] (x y : A) : is_equiv (ap f : x = y → f x = f y) := - adjointify - (ap f) - (eq_of_fn_eq_fn' f) - abstract (λq, !ap_con - ⬝ whisker_right !ap_con _ - ⬝ ((!ap_inv ⬝ inverse2 (adj f _)⁻¹) - ◾ (inverse (ap_compose f f⁻¹ _)) - ◾ (adj f _)⁻¹) - ⬝ con_ap_con_eq_con_con (right_inv f) _ _ - ⬝ whisker_right !con.left_inv _ - ⬝ !idp_con) end - abstract (λp, whisker_right (whisker_left _ (ap_compose f⁻¹ f _)⁻¹) _ - ⬝ con_ap_con_eq_con_con (left_inv f) _ _ - ⬝ whisker_right !con.left_inv _ - ⬝ !idp_con) end - - -- The function equiv_rect says that given an equivalence f : A → B, - -- and a hypothesis from B, one may always assume that the hypothesis - -- is in the image of e. - - -- In fibrational terms, if we have a fibration over B which has a section - -- once pulled back along an equivalence f : A → B, then it has a section - -- over all of B. - - definition is_equiv_rect (P : B → Type) (g : Πa, P (f a)) (b : B) : P b := - right_inv f b ▸ g (f⁻¹ b) - - definition is_equiv_rect' (P : A → B → Type) (g : Πb, P (f⁻¹ b) b) (a : A) : P a (f a) := - left_inv f a ▸ g (f a) - - definition is_equiv_rect_comp (P : B → Type) - (df : Π (x : A), P (f x)) (x : A) : is_equiv_rect f P df (f x) = df x := - calc - is_equiv_rect f P df (f x) - = right_inv f (f x) ▸ df (f⁻¹ (f x)) : by esimp - ... = ap f (left_inv f x) ▸ df (f⁻¹ (f x)) : by rewrite -adj - ... = left_inv f x ▸ df (f⁻¹ (f x)) : by rewrite -tr_compose - ... = df x : by rewrite (apd df (left_inv f x)) - - theorem adj_inv (b : B) : left_inv f (f⁻¹ b) = ap f⁻¹ (right_inv f b) := - is_equiv_rect f _ - (λa, eq.cancel_right (left_inv f (id a)) - (whisker_left _ !ap_id⁻¹ ⬝ (ap_con_eq_con_ap (left_inv f) (left_inv f a))⁻¹) ⬝ - !ap_compose ⬝ ap02 f⁻¹ (adj f a)⁻¹) - b - - end - - section - variables {A B C : Type} {f : A → B} [Hf : is_equiv f] {a : A} {b : B} {g : B → C} {h : A → C} - include Hf - - --Rewrite rules - definition eq_of_eq_inv (p : a = f⁻¹ b) : f a = b := - ap f p ⬝ right_inv f b - - definition eq_of_inv_eq (p : f⁻¹ b = a) : b = f a := - (eq_of_eq_inv p⁻¹)⁻¹ - - definition inv_eq_of_eq (p : b = f a) : f⁻¹ b = a := - ap f⁻¹ p ⬝ left_inv f a - - definition eq_inv_of_eq (p : f a = b) : a = f⁻¹ b := - (inv_eq_of_eq p⁻¹)⁻¹ - - variable (f) - definition homotopy_of_homotopy_inv' (p : g ~ h ∘ f⁻¹) : g ∘ f ~ h := - λa, p (f a) ⬝ ap h (left_inv f a) - - definition homotopy_of_inv_homotopy' (p : h ∘ f⁻¹ ~ g) : h ~ g ∘ f := - λa, ap h (left_inv f a)⁻¹ ⬝ p (f a) - - definition inv_homotopy_of_homotopy' (p : h ~ g ∘ f) : h ∘ f⁻¹ ~ g := - λb, p (f⁻¹ b) ⬝ ap g (right_inv f b) - - definition homotopy_inv_of_homotopy' (p : g ∘ f ~ h) : g ~ h ∘ f⁻¹ := - λb, ap g (right_inv f b)⁻¹ ⬝ p (f⁻¹ b) - - end - - --Transporting is an equivalence - definition is_equiv_tr [constructor] {A : Type} (P : A → Type) {x y : A} - (p : x = y) : (is_equiv (transport P p)) := - is_equiv.mk _ (transport P p⁻¹) (tr_inv_tr p) (inv_tr_tr p) (tr_inv_tr_lemma p) - - section - variables {A : Type} {B C : A → Type} (f : Π{a}, B a → C a) [H : Πa, is_equiv (@f a)] - {g : A → A} {g' : A → A} (h : Π{a}, B (g' a) → B (g a)) (h' : Π{a}, C (g' a) → C (g a)) - - include H - definition inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A} - (c : C (g' a)) : f⁻¹ (h' c) = h (f⁻¹ c) := - eq_of_fn_eq_fn' f (right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ c))⁻¹) - - definition fun_commute_of_inv_commute' (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ (h' c) = h (f⁻¹ c)) - {a : A} (b : B (g' a)) : f (h b) = h' (f b) := - eq_of_fn_eq_fn' f⁻¹ (left_inv f (h b) ⬝ ap h (left_inv f b)⁻¹ ⬝ (p (f b))⁻¹) - - definition ap_inv_commute' (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A} - (c : C (g' a)) : ap f (inv_commute' @f @h @h' p c) - = right_inv f (h' c) ⬝ ap h' (right_inv f c)⁻¹ ⬝ (p (f⁻¹ c))⁻¹ := - !ap_eq_of_fn_eq_fn' - - end - -end is_equiv -open is_equiv - -namespace eq - local attribute is_equiv_tr [instance] - - definition tr_inv_fn {A : Type} {B : A → Type} {a a' : A} (p : a = a') : - transport B p⁻¹ = (transport B p)⁻¹ := idp - definition tr_inv {A : Type} {B : A → Type} {a a' : A} (p : a = a') (b : B a') : - p⁻¹ ▸ b = (transport B p)⁻¹ b := idp - - definition cast_inv_fn {A B : Type} (p : A = B) : cast p⁻¹ = (cast p)⁻¹ := idp - definition cast_inv {A B : Type} (p : A = B) (b : B) : cast p⁻¹ b = (cast p)⁻¹ b := idp -end eq - -infix ` ≃ `:25 := equiv -attribute equiv.to_is_equiv [instance] - -namespace equiv - attribute to_fun [coercion] - - section - variables {A B C : Type} - - protected definition MK [reducible] [constructor] (f : A → B) (g : B → A) - (right_inv : Πb, f (g b) = b) (left_inv : Πa, g (f a) = a) : A ≃ B := - equiv.mk f (adjointify f g right_inv left_inv) - - definition to_inv [reducible] [unfold 3] (f : A ≃ B) : B → A := f⁻¹ - definition to_right_inv [reducible] [unfold 3] (f : A ≃ B) (b : B) : f (f⁻¹ b) = b := - right_inv f b - definition to_left_inv [reducible] [unfold 3] (f : A ≃ B) (a : A) : f⁻¹ (f a) = a := - left_inv f a - - protected definition refl [refl] [constructor] : A ≃ A := - equiv.mk id !is_equiv_id - - protected definition symm [symm] (f : A ≃ B) : B ≃ A := - equiv.mk f⁻¹ !is_equiv_inv - - protected definition trans [trans] (f : A ≃ B) (g : B ≃ C) : A ≃ C := - equiv.mk (g ∘ f) !is_equiv_compose - - infixl ` ⬝e `:75 := equiv.trans - postfix `⁻¹ᵉ`:(max + 1) := equiv.symm - -- notation for inverse which is not overloaded - abbreviation erfl [constructor] := @equiv.refl - - definition to_inv_trans [reducible] [unfold_full] (f : A ≃ B) (g : B ≃ C) - : to_inv (f ⬝e g) = to_fun (g⁻¹ᵉ ⬝e f⁻¹ᵉ) := - idp - - definition equiv_change_fun [constructor] (f : A ≃ B) {f' : A → B} (Heq : f ~ f') : A ≃ B := - equiv.mk f' (is_equiv.homotopy_closed f Heq) - - definition equiv_change_inv [constructor] (f : A ≃ B) {f' : B → A} (Heq : f⁻¹ ~ f') - : A ≃ B := - equiv.mk f (inv_homotopy_closed Heq) - - --rename: eq_equiv_fn_eq_of_is_equiv - definition eq_equiv_fn_eq [constructor] (f : A → B) [H : is_equiv f] (a b : A) : (a = b) ≃ (f a = f b) := - equiv.mk (ap f) !is_equiv_ap - - --rename: eq_equiv_fn_eq - definition eq_equiv_fn_eq_of_equiv [constructor] (f : A ≃ B) (a b : A) : (a = b) ≃ (f a = f b) := - equiv.mk (ap f) !is_equiv_ap - - definition equiv_ap [constructor] (P : A → Type) {a b : A} (p : a = b) : P a ≃ P b := - equiv.mk (transport P p) !is_equiv_tr - - definition equiv_of_eq [constructor] {A B : Type} (p : A = B) : A ≃ B := - equiv.mk (cast p) !is_equiv_tr - - definition eq_of_fn_eq_fn (f : A ≃ B) {x y : A} (q : f x = f y) : x = y := - (left_inv f x)⁻¹ ⬝ ap f⁻¹ q ⬝ left_inv f y - - definition eq_of_fn_eq_fn_inv (f : A ≃ B) {x y : B} (q : f⁻¹ x = f⁻¹ y) : x = y := - (right_inv f x)⁻¹ ⬝ ap f q ⬝ right_inv f y - - --we need this theorem for the funext_of_ua proof - theorem inv_eq {A B : Type} (eqf eqg : A ≃ B) (p : eqf = eqg) : (to_fun eqf)⁻¹ = (to_fun eqg)⁻¹ := - eq.rec_on p idp - - definition equiv_of_equiv_of_eq [trans] {A B C : Type} (p : A = B) (q : B ≃ C) : A ≃ C := - equiv_of_eq p ⬝e q - definition equiv_of_eq_of_equiv [trans] {A B C : Type} (p : A ≃ B) (q : B = C) : A ≃ C := - p ⬝e equiv_of_eq q - - definition equiv_lift [constructor] (A : Type) : A ≃ lift A := equiv.mk up _ - - definition equiv_rect (f : A ≃ B) (P : B → Type) (g : Πa, P (f a)) (b : B) : P b := - right_inv f b ▸ g (f⁻¹ b) - - definition equiv_rect' (f : A ≃ B) (P : A → B → Type) (g : Πb, P (f⁻¹ b) b) (a : A) : P a (f a) := - left_inv f a ▸ g (f a) - - definition equiv_rect_comp (f : A ≃ B) (P : B → Type) - (df : Π (x : A), P (f x)) (x : A) : equiv_rect f P df (f x) = df x := - calc - equiv_rect f P df (f x) - = right_inv f (f x) ▸ df (f⁻¹ (f x)) : by esimp - ... = ap f (left_inv f x) ▸ df (f⁻¹ (f x)) : by rewrite -adj - ... = left_inv f x ▸ df (f⁻¹ (f x)) : by rewrite -tr_compose - ... = df x : by rewrite (apd df (left_inv f x)) - end - - section - - variables {A : Type} {B C : A → Type} (f : Π{a}, B a ≃ C a) - {g : A → A} {g' : A → A} (h : Π{a}, B (g' a) → B (g a)) (h' : Π{a}, C (g' a) → C (g a)) - - definition inv_commute (p : Π⦃a : A⦄ (b : B (g' a)), f (h b) = h' (f b)) {a : A} - (c : C (g' a)) : f⁻¹ (h' c) = h (f⁻¹ c) := - inv_commute' @f @h @h' p c - - definition fun_commute_of_inv_commute (p : Π⦃a : A⦄ (c : C (g' a)), f⁻¹ (h' c) = h (f⁻¹ c)) - {a : A} (b : B (g' a)) : f (h b) = h' (f b) := - fun_commute_of_inv_commute' @f @h @h' p b - - end - - section - variables {A B C : Type} (f : A ≃ B) {a : A} {b : B} {g : B → C} {h : A → C} - - definition homotopy_of_homotopy_inv (p : g ~ h ∘ f⁻¹) : g ∘ f ~ h := - homotopy_of_homotopy_inv' f p - - definition homotopy_of_inv_homotopy (p : h ∘ f⁻¹ ~ g) : h ~ g ∘ f := - homotopy_of_inv_homotopy' f p - - definition inv_homotopy_of_homotopy (p : h ~ g ∘ f) : h ∘ f⁻¹ ~ g := - inv_homotopy_of_homotopy' f p - - definition homotopy_inv_of_homotopy (p : g ∘ f ~ h) : g ~ h ∘ f⁻¹ := - homotopy_inv_of_homotopy' f p - - end - - infixl ` ⬝pe `:75 := equiv_of_equiv_of_eq - infixl ` ⬝ep `:75 := equiv_of_eq_of_equiv - -end equiv - -open equiv -namespace is_equiv - - definition is_equiv_of_equiv_of_homotopy [constructor] {A B : Type} (f : A ≃ B) - {f' : A → B} (Hty : f ~ f') : is_equiv f' := - homotopy_closed f Hty - -end is_equiv - -export [unfold] equiv -export [unfold] is_equiv diff --git a/hott/init/function.hlean b/hott/init/function.hlean deleted file mode 100644 index 655ff42b9b..0000000000 --- a/hott/init/function.hlean +++ /dev/null @@ -1,63 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura - -General operations on functions. --/ - -prelude -import init.reserved_notation .types - -open prod - -namespace function - -variables {A B C D E : Type} - -definition compose [reducible] [unfold_full] (f : B → C) (g : A → B) : A → C := -λx, f (g x) - -definition compose_right [reducible] [unfold_full] (f : B → B → B) (g : A → B) : B → A → B := -λ b a, f b (g a) - -definition compose_left [reducible] [unfold_full] (f : B → B → B) (g : A → B) : A → B → B := -λ a b, f (g a) b - -definition on_fun [reducible] [unfold_full] (f : B → B → C) (g : A → B) : A → A → C := -λx y, f (g x) (g y) - -definition combine [reducible] [unfold_full] (f : A → B → C) (op : C → D → E) (g : A → B → D) - : A → B → E := -λx y, op (f x y) (g x y) - -definition const [reducible] [unfold_full] (B : Type) (a : A) : B → A := -λx, a - -definition dcompose [reducible] [unfold_full] {B : A → Type} {C : Π {x : A}, B x → Type} - (f : Π {x : A} (y : B x), C y) (g : Πx, B x) : Πx, C (g x) := -λx, f (g x) - -definition flip [reducible] [unfold_full] {C : A → B → Type} (f : Πx y, C x y) : Πy x, C x y := -λy x, f x y - -definition app [reducible] [unfold_full] {B : A → Type} (f : Πx, B x) (x : A) : B x := -f x - -definition curry [reducible] [unfold_full] : (A × B → C) → A → B → C := -λ f a b, f (a, b) - -definition uncurry [reducible] [unfold 5] : (A → B → C) → (A × B → C) := -λ f p, match p with (a, b) := f a b end - - -infixr ` ∘ ` := compose -infixr ` ∘' `:60 := dcompose -infixl ` on `:1 := on_fun -infixr ` $ `:1 := app -notation f ` -[` op `]- ` g := combine f op g - -end function - --- copy reducible annotations to top-level -export [reducible] [unfold] function diff --git a/hott/init/funext.hlean b/hott/init/funext.hlean deleted file mode 100644 index eba7eaf9cb..0000000000 --- a/hott/init/funext.hlean +++ /dev/null @@ -1,275 +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 --/ - -prelude -import .trunc .equiv .ua -open eq is_trunc sigma function is_equiv equiv prod unit prod.ops lift - -/- - We now prove that funext follows from a couple of weaker-looking forms - of function extensionality. - - This proof is originally due to Voevodsky; it has since been simplified - by Peter Lumsdaine and Michael Shulman. --/ - -definition funext.{l k} := - Π ⦃A : Type.{l}⦄ {P : A → Type.{k}} (f g : Π x, P x), is_equiv (@apd10 A P f g) - --- Naive funext is the simple assertion that pointwise equal functions are equal. -definition naive_funext := - Π ⦃A : Type⦄ {P : A → Type} (f g : Πx, P x), (f ~ g) → f = g - --- Weak funext says that a product of contractible types is contractible. -definition weak_funext := - Π ⦃A : Type⦄ (P : A → Type) [H: Πx, is_contr (P x)], is_contr (Πx, P x) - -definition weak_funext_of_naive_funext : naive_funext → weak_funext := - (λ nf A P (Pc : Πx, is_contr (P x)), - let c := λx, center (P x) in - is_contr.mk c (λ f, - have eq' : (λx, center (P x)) ~ f, - from (λx, center_eq (f x)), - have eq : (λx, center (P x)) = f, - from nf A P (λx, center (P x)) f eq', - eq - ) - ) - -/- - The less obvious direction is that weak_funext implies funext - (and hence all three are logically equivalent). The point is that under weak - funext, the space of "pointwise homotopies" has the same universal property as - the space of paths. --/ - -section - universe variables l k - parameters [wf : weak_funext.{l k}] {A : Type.{l}} {B : A → Type.{k}} (f : Π x, B x) - - definition is_contr_sigma_homotopy : is_contr (Σ (g : Π x, B x), f ~ g) := - is_contr.mk (sigma.mk f (homotopy.refl f)) - (λ dp, sigma.rec_on dp - (λ (g : Π x, B x) (h : f ~ g), - let r := λ (k : Π x, Σ y, f x = y), - @sigma.mk _ (λg, f ~ g) - (λx, pr1 (k x)) (λx, pr2 (k x)) in - let s := λ g h x, @sigma.mk _ (λy, f x = y) (g x) (h x) in - have t1 : Πx, is_contr (Σ y, f x = y), - from (λx, !is_contr_sigma_eq), - have t2 : is_contr (Πx, Σ y, f x = y), - from !wf, - have t3 : (λ x, @sigma.mk _ (λ y, f x = y) (f x) idp) = s g h, - from @eq_of_is_contr (Π x, Σ y, f x = y) t2 _ _, - have t4 : r (λ x, sigma.mk (f x) idp) = r (s g h), - from ap r t3, - have endt : sigma.mk f (homotopy.refl f) = sigma.mk g h, - from t4, - endt - ) - ) - local attribute is_contr_sigma_homotopy [instance] - - parameters (Q : Π g (h : f ~ g), Type) (d : Q f (homotopy.refl f)) - - definition homotopy_ind (g : Πx, B x) (h : f ~ g) : Q g h := - @transport _ (λ gh, Q (pr1 gh) (pr2 gh)) (sigma.mk f (homotopy.refl f)) (sigma.mk g h) - (@eq_of_is_contr _ is_contr_sigma_homotopy _ _) d - - local attribute weak_funext [reducible] - local attribute homotopy_ind [reducible] - definition homotopy_ind_comp : homotopy_ind f (homotopy.refl f) = d := - (@prop_eq_of_is_contr _ _ _ _ !eq_of_is_contr idp)⁻¹ ▸ idp -end - -/- Now the proof is fairly easy; we can just use the same induction principle on both sides. -/ -section -universe variables l k - -local attribute weak_funext [reducible] -theorem funext_of_weak_funext (wf : weak_funext.{l k}) : funext.{l k} := - λ A B f g, - let eq_to_f := (λ g' x, f = g') in - let sim2path := homotopy_ind f eq_to_f idp in - have t1 : sim2path f (homotopy.refl f) = idp, - proof homotopy_ind_comp f eq_to_f idp qed, - have t2 : apd10 (sim2path f (homotopy.refl f)) = (homotopy.refl f), - proof ap apd10 t1 qed, - have left_inv : apd10 ∘ (sim2path g) ~ id, - proof (homotopy_ind f (λ g' x, apd10 (sim2path g' x) = x) t2) g qed, - have right_inv : (sim2path g) ∘ apd10 ~ id, - from (λ h, eq.rec_on h (homotopy_ind_comp f _ idp)), - is_equiv.adjointify apd10 (sim2path g) left_inv right_inv - -definition funext_from_naive_funext : naive_funext → funext := - compose funext_of_weak_funext weak_funext_of_naive_funext -end - -section - universe variables l - - private theorem ua_isequiv_postcompose {A B : Type.{l}} {C : Type} - {w : A → B} [H0 : is_equiv w] : is_equiv (@compose C A B w) := - let w' := equiv.mk w H0 in - let eqinv : A = B := ((@is_equiv.inv _ _ _ (univalence A B)) w') in - let eq' := equiv_of_eq eqinv in - is_equiv.adjointify (@compose C A B w) - (@compose C B A (is_equiv.inv w)) - (λ (x : C → B), - have eqretr : eq' = w', - from (@right_inv _ _ (@equiv_of_eq A B) (univalence A B) w'), - have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹, - from inv_eq eq' w' eqretr, - have eqfin : (to_fun eq') ∘ ((to_fun eq')⁻¹ ∘ x) = x, - from (λ p, - (@eq.rec_on Type.{l} A - (λ B' p', Π (x' : C → B'), (to_fun (equiv_of_eq p')) - ∘ ((to_fun (equiv_of_eq p'))⁻¹ ∘ x') = x') - B p (λ x', idp)) - ) eqinv x, - have eqfin' : (to_fun w') ∘ ((to_fun eq')⁻¹ ∘ x) = x, - from eqretr ▸ eqfin, - have eqfin'' : (to_fun w') ∘ ((to_fun w')⁻¹ ∘ x) = x, - from invs_eq ▸ eqfin', - eqfin'' - ) - (λ (x : C → A), - have eqretr : eq' = w', - from (@right_inv _ _ (@equiv_of_eq A B) (univalence A B) w'), - have invs_eq : (to_fun eq')⁻¹ = (to_fun w')⁻¹, - from inv_eq eq' w' eqretr, - have eqfin : (to_fun eq')⁻¹ ∘ ((to_fun eq') ∘ x) = x, - from (λ p, eq.rec_on p idp) eqinv, - have eqfin' : (to_fun eq')⁻¹ ∘ ((to_fun w') ∘ x) = x, - from eqretr ▸ eqfin, - have eqfin'' : (to_fun w')⁻¹ ∘ ((to_fun w') ∘ x) = x, - from invs_eq ▸ eqfin', - eqfin'' - ) - - -- We are ready to prove functional extensionality, - -- starting with the naive non-dependent version. - private definition diagonal [reducible] (B : Type) : Type - := Σ xy : B × B, pr₁ xy = pr₂ xy - - private definition isequiv_src_compose {A B : Type} - : @is_equiv (A → diagonal B) - (A → B) - (compose (pr₁ ∘ pr1)) := - @ua_isequiv_postcompose _ _ _ (pr₁ ∘ pr1) - (is_equiv.adjointify (pr₁ ∘ pr1) - (λ x, sigma.mk (x , x) idp) (λx, idp) - (λ x, sigma.rec_on x - (λ xy, prod.rec_on xy - (λ b c p, eq.rec_on p idp)))) - - private definition isequiv_tgt_compose {A B : Type} - : is_equiv (compose (pr₂ ∘ pr1) : (A → diagonal B) → (A → B)) := - begin - refine @ua_isequiv_postcompose _ _ _ (pr2 ∘ pr1) _, - fapply adjointify, - { intro b, exact ⟨(b, b), idp⟩}, - { intro b, reflexivity}, - { intro a, induction a with q p, induction q, esimp at *, induction p, reflexivity} - end - - theorem nondep_funext_from_ua {A : Type} {B : Type} - : Π {f g : A → B}, f ~ g → f = g := - (λ (f g : A → B) (p : f ~ g), - let d := λ (x : A), @sigma.mk (B × B) (λ (xy : B × B), xy.1 = xy.2) (f x , f x) (eq.refl (f x, f x).1) in - let e := λ (x : A), @sigma.mk (B × B) (λ (xy : B × B), xy.1 = xy.2) (f x , g x) (p x) in - let precomp1 := compose (pr₁ ∘ sigma.pr1) in - have equiv1 : is_equiv precomp1, - from @isequiv_src_compose A B, - have equiv2 : Π (x y : A → diagonal B), is_equiv (ap precomp1), - from is_equiv.is_equiv_ap precomp1, - have H' : Π (x y : A → diagonal B), pr₁ ∘ pr1 ∘ x = pr₁ ∘ pr1 ∘ y → x = y, - from (λ x y, is_equiv.inv (ap precomp1)), - have eq2 : pr₁ ∘ pr1 ∘ d = pr₁ ∘ pr1 ∘ e, - from idp, - have eq0 : d = e, - from H' d e eq2, - have eq1 : (pr₂ ∘ pr1) ∘ d = (pr₂ ∘ pr1) ∘ e, - from ap _ eq0, - eq1 - ) - -end - --- Now we use this to prove weak funext, which as we know --- implies (with dependent eta) also the strong dependent funext. -theorem weak_funext_of_ua : weak_funext := - (λ (A : Type) (P : A → Type) allcontr, - let U := (λ (x : A), lift unit) in - have pequiv : Π (x : A), P x ≃ unit, - from (λ x, @equiv_unit_of_is_contr (P x) (allcontr x)), - have psim : Π (x : A), P x = U x, - from (λ x, eq_of_equiv_lift (pequiv x)), - have p : P = U, - from @nondep_funext_from_ua A Type P U psim, - have tU' : is_contr (A → lift unit), - from is_contr.mk (λ x, up ⋆) - (λ f, nondep_funext_from_ua (λa, by induction (f a) with u;induction u;reflexivity)), - have tU : is_contr (Π x, U x), - from tU', - have tlast : is_contr (Πx, P x), - from p⁻¹ ▸ tU, - tlast) - --- In the following we will proof function extensionality using the univalence axiom -definition funext_of_ua : funext := - funext_of_weak_funext (@weak_funext_of_ua) - -variables {A : Type} {P : A → Type} {f g : Π x, P x} - -namespace funext - theorem is_equiv_apd [instance] (f g : Π x, P x) : is_equiv (@apd10 A P f g) := - funext_of_ua f g -end funext - -open funext - -definition eq_equiv_homotopy : (f = g) ≃ (f ~ g) := -equiv.mk apd10 _ - -definition eq_of_homotopy [reducible] : f ~ g → f = g := -(@apd10 A P f g)⁻¹ - -definition apd10_eq_of_homotopy (p : f ~ g) : apd10 (eq_of_homotopy p) = p := -right_inv apd10 p - -definition eq_of_homotopy_apd10 (p : f = g) : eq_of_homotopy (apd10 p) = p := -left_inv apd10 p - -definition eq_of_homotopy_idp (f : Π x, P x) : eq_of_homotopy (λx : A, idpath (f x)) = idpath f := -is_equiv.left_inv apd10 idp - -definition naive_funext_of_ua : naive_funext := -λ A P f g h, eq_of_homotopy h - -protected definition homotopy.rec_on [recursor] {Q : (f ~ g) → Type} (p : f ~ g) - (H : Π(q : f = g), Q (apd10 q)) : Q p := -right_inv apd10 p ▸ H (eq_of_homotopy p) - -protected definition homotopy.rec_on_idp [recursor] {Q : Π{g}, (f ~ g) → Type} {g : Π x, P x} (p : f ~ g) (H : Q (homotopy.refl f)) : Q p := -homotopy.rec_on p (λq, eq.rec_on q H) - -definition eq_of_homotopy_inv {f g : Π x, P x} (H : f ~ g) - : eq_of_homotopy (λx, (H x)⁻¹) = (eq_of_homotopy H)⁻¹ := -begin - apply homotopy.rec_on_idp H, - rewrite [+eq_of_homotopy_idp] -end - -definition eq_of_homotopy_con {f g h : Π x, P x} (H1 : f ~ g) (H2 : g ~ h) - : eq_of_homotopy (λx, H1 x ⬝ H2 x) = eq_of_homotopy H1 ⬝ eq_of_homotopy H2 := -begin - apply homotopy.rec_on_idp H1, - apply homotopy.rec_on_idp H2, - rewrite [+eq_of_homotopy_idp] -end diff --git a/hott/init/hedberg.hlean b/hott/init/hedberg.hlean deleted file mode 100644 index 77a830c671..0000000000 --- a/hott/init/hedberg.hlean +++ /dev/null @@ -1,47 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. - -Author: Leonardo de Moura - -Hedberg's Theorem: every type with decidable equality is a set --/ - -prelude -import init.trunc -open eq eq.ops nat is_trunc sigma - --- TODO(Leo): move const coll and path_coll to a different file? -private definition const {A B : Type} (f : A → B) := ∀ x y, f x = f y -private definition coll (A : Type) := Σ f : A → A, const f -private definition path_coll (A : Type) := ∀ x y : A, coll (x = y) - -section - parameter {A : Type} - hypothesis [h : decidable_eq A] - variables {x y : A} - - private definition pc [reducible] : path_coll A := - λ a b, decidable.rec_on (h a b) - (λ p : a = b, ⟨(λ q, p), λ q r, rfl⟩) - (λ np : ¬ a = b, ⟨(λ q, q), λ q r, absurd q np⟩) - - private definition f [reducible] : x = y → x = y := - sigma.rec_on (pc x y) (λ f c, f) - - private definition f_const (p q : x = y) : f p = f q := - sigma.rec_on (pc x y) (λ f c, c p q) - - private definition aux (p : x = y) : p = (f (refl x))⁻¹ ⬝ (f p) := - have aux : refl x = (f (refl x))⁻¹ ⬝ (f (refl x)), from - eq.rec_on (f (refl x)) rfl, - eq.rec_on p aux - - definition is_set_of_decidable_eq : is_set A := - is_set.mk A (λ x y p q, calc - p = (f (refl x))⁻¹ ⬝ (f p) : aux - ... = (f (refl x))⁻¹ ⬝ (f q) : f_const - ... = q : aux) -end - -attribute is_set_of_decidable_eq [instance] [priority 600] diff --git a/hott/init/hit.hlean b/hott/init/hit.hlean deleted file mode 100644 index d96137396c..0000000000 --- a/hott/init/hit.hlean +++ /dev/null @@ -1,88 +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 primitive hits in Lean --/ - -prelude - -import .trunc .pathover - -open is_trunc eq - -/- - 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 - - quotients (not truncated) - For each of the hits we add the following constants: - - the type formation - - the term and path constructors - - the dependent recursor - We add the computation rule for point constructors judgmentally to the kernel of Lean. - The computation rules for the path constructors are added (propositionally) as axioms - - In this file we only define the dependent recursor. For the nondependent recursor and all other - uses of these hits, see the folder ../hit/ --/ - -constant trunc.{u} (n : trunc_index) (A : Type.{u}) : Type.{u} - -namespace trunc - constant tr {n : trunc_index} {A : Type} (a : A) : trunc n A - constant is_trunc_trunc (n : trunc_index) (A : Type) : is_trunc n (trunc n A) - - attribute is_trunc_trunc [instance] - - protected constant rec {n : trunc_index} {A : Type} {P : trunc n A → Type} - [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) : Πaa, P aa - - protected definition rec_on [reducible] {n : trunc_index} {A : Type} - {P : trunc n A → Type} (aa : trunc n A) [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) - : P aa := - trunc.rec H aa -end trunc - -constant quotient.{u v} {A : Type.{u}} (R : A → A → Type.{v}) : Type.{max u v} - -namespace quotient - - constant class_of {A : Type} (R : A → A → Type) (a : A) : quotient R - - constant eq_of_rel {A : Type} (R : A → A → Type) ⦃a a' : A⦄ (H : R a a') - : class_of R a = class_of R a' - - protected constant rec {A : Type} {R : A → A → Type} {P : quotient R → Type} - (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a') - (x : quotient R) : P x - - protected definition rec_on [reducible] {A : Type} {R : A → A → Type} {P : quotient R → Type} - (x : quotient R) (Pc : Π(a : A), P (class_of R a)) - (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a') : P x := - quotient.rec Pc Pp x - -end quotient - -init_hits -- Initialize builtin computational rules for trunc and quotient - -namespace trunc - definition rec_tr [reducible] {n : trunc_index} {A : Type} {P : trunc n A → Type} - [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) (a : A) : trunc.rec H (tr a) = H a := - idp -end trunc - -namespace quotient - definition rec_class_of {A : Type} {R : A → A → Type} {P : quotient R → Type} - (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a') - (a : A) : quotient.rec Pc Pp (class_of R a) = Pc a := - idp - - constant rec_eq_of_rel {A : Type} {R : A → A → Type} {P : quotient R → Type} - (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a') - {a a' : A} (H : R a a') : apdo (quotient.rec Pc Pp) (eq_of_rel R H) = Pp H -end quotient - -attribute quotient.class_of trunc.tr [constructor] -attribute quotient.rec_on trunc.rec_on [unfold 4] diff --git a/hott/init/init.md b/hott/init/init.md deleted file mode 100644 index 5214161e27..0000000000 --- a/hott/init/init.md +++ /dev/null @@ -1,42 +0,0 @@ -init -==== - -The files in this folder are required by low-level operations, and -are always imported by default. You can suppress this behavior by -beginning a file with the keyword "prelude". - -Syntax declarations: - -* [reserved_notation](reserved_notation.hlean) -* [tactic](tactic.hlean) - -Datatypes and logic: - -* [logic](logic.hlean) -* [datatypes](datatypes.hlean) (declaration of common types) -* [bool](bool.hlean) -* [num](num.hlean) -* [nat](nat.hlean) -* [function](function.hlean) -* [types](types.hlean) (notation and some theorems for the remaining basic types) -* [connectives](connectives.hlean) - -HoTT basics: - -* [path](path.hlean) -* [pathover](pathover.hlean) -* [hedberg](hedberg.hlean) -* [trunc](trunc.hlean) -* [equiv](equiv.hlean) -* [ua](ua.hlean) (declaration of the univalence axiom, and some basic properties) -* [funext](funext.hlean) (proof of equivalence of certain notions of function exensionality, and a proof that function extensionality follows from univalence) - -Support for well-founded recursion and automation: - -* [relation](relation.hlean) -* [wf](wf.hlean) -* [util](util.hlean) - -The default import: - -* [default](default.hlean) diff --git a/hott/init/logic.hlean b/hott/init/logic.hlean deleted file mode 100644 index e7ec11291a..0000000000 --- a/hott/init/logic.hlean +++ /dev/null @@ -1,702 +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, Floris van Doorn --/ - -prelude -import init.reserved_notation -open unit - -definition id [reducible] [unfold_full] {A : Type} (a : A) : A := -a - -/- not -/ - -definition not [reducible] (a : Type) := a → empty -prefix ¬ := not - -definition absurd {a b : Type} (H₁ : a) (H₂ : ¬a) : b := -empty.rec (λ e, b) (H₂ H₁) - -definition mt {a b : Type} (H₁ : a → b) (H₂ : ¬b) : ¬a := -assume Ha : a, absurd (H₁ Ha) H₂ - -definition not_empty : ¬empty := -assume H : empty, H - -definition non_contradictory (a : Type) : Type := ¬¬a - -definition non_contradictory_intro {a : Type} (Ha : a) : ¬¬a := -assume Hna : ¬a, absurd Ha Hna - -definition not.intro {a : Type} (H : a → empty) : ¬a := H - -/- empty -/ - -definition empty.elim {c : Type} (H : empty) : c := -empty.rec _ H - -/- eq -/ - -infix = := eq -definition rfl [constructor] {A : Type} {a : A} := eq.refl a - -/- - These notions are here only to make porting from the standard library easier. - They are defined again in init/path.hlean, and those definitions will be used - throughout the HoTT-library. That's why the notation for eq below is only local. --/ -namespace eq - variables {A : Type} {a b c : A} - - definition subst [unfold 5] {P : A → Type} (H₁ : a = b) (H₂ : P a) : P b := - eq.rec H₂ H₁ - - definition trans [unfold 5] (H₁ : a = b) (H₂ : b = c) : a = c := - subst H₂ H₁ - - definition symm [unfold 4] (H : a = b) : b = a := - subst H (refl a) - - definition mp {a b : Type} : (a = b) → a → b := - eq.rec_on - - definition mpr {a b : Type} : (a = b) → b → a := - assume H₁ H₂, eq.rec_on (eq.symm H₁) H₂ - - namespace ops end ops -- this is just to ensure that this namespace exists. There is nothing in it -end eq - -local postfix ⁻¹ := eq.symm --input with \sy or \-1 or \inv -local infixl ⬝ := eq.trans -local infixr ▸ := eq.subst - --- Auxiliary definition used by automation. It has the same type of eq.rec in the standard library -definition eq.nrec.{l₁ l₂} {A : Type.{l₂}} {a : A} {C : A → Type.{l₁}} (H₁ : C a) (b : A) (H₂ : a = b) : C b := -eq.rec H₁ H₂ - -definition congr {A B : Type} {f₁ f₂ : A → B} {a₁ a₂ : A} (H₁ : f₁ = f₂) (H₂ : a₁ = a₂) : f₁ a₁ = f₂ a₂ := -eq.subst H₁ (eq.subst H₂ rfl) - -definition congr_fun {A : Type} {B : A → Type} {f g : Π x, B x} (H : f = g) (a : A) : f a = g a := -eq.subst H (eq.refl (f a)) - -definition congr_arg {A B : Type} (a a' : A) (f : A → B) (Ha : a = a') : f a = f a' := -eq.subst Ha rfl - -definition congr_arg2 {A B C : Type} (a a' : A) (b b' : B) (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' := -eq.subst Ha (eq.subst Hb rfl) - -section - variables {A : Type} {a b c: A} - open eq.ops - - definition trans_rel_left (R : A → A → Type) (H₁ : R a b) (H₂ : b = c) : R a c := - H₂ ▸ H₁ - - definition trans_rel_right (R : A → A → Type) (H₁ : a = b) (H₂ : R b c) : R a c := - H₁⁻¹ ▸ H₂ -end - -attribute eq.subst [subst] -attribute eq.refl [refl] -attribute eq.trans [trans] -attribute eq.symm [symm] - -namespace lift - definition down_up.{l₁ l₂} {A : Type.{l₁}} (a : A) : down (up.{l₁ l₂} a) = a := - rfl - - definition up_down.{l₁ l₂} {A : Type.{l₁}} (a : lift.{l₁ l₂} A) : up (down a) = a := - lift.rec_on a (λ d, rfl) -end lift - -/- ne -/ - -definition ne [reducible] {A : Type} (a b : A) := ¬(a = b) -notation a ≠ b := ne a b - -namespace ne - open eq.ops - variable {A : Type} - variables {a b : A} - - definition intro (H : a = b → empty) : a ≠ b := H - - definition elim (H : a ≠ b) : a = b → empty := H - - definition irrefl (H : a ≠ a) : empty := H rfl - - definition symm (H : a ≠ b) : b ≠ a := - assume (H₁ : b = a), H (H₁⁻¹) -end ne - -definition empty_of_ne {A : Type} {a : A} : a ≠ a → empty := ne.irrefl - -section - open eq.ops - variables {p : Type₀} - - definition ne_empty_of_self : p → p ≠ empty := - assume (Hp : p) (Heq : p = empty), Heq ▸ Hp - - definition ne_unit_of_not : ¬p → p ≠ unit := - assume (Hnp : ¬p) (Heq : p = unit), (Heq ▸ Hnp) star - - definition unit_ne_empty : ¬unit = empty := - ne_empty_of_self star -end - -/- prod -/ - -abbreviation pair [constructor] := @prod.mk -infixr × := prod - -variables {a b c d : Type} - -attribute prod.rec [elim] -attribute prod.mk [intro!] - -protected definition prod.elim [unfold 4] (H₁ : a × b) (H₂ : a → b → c) : c := -prod.rec H₂ H₁ - -definition prod.swap [unfold 3] : a × b → b × a := -prod.rec (λHa Hb, prod.mk Hb Ha) - -/- sum -/ - -infixr ⊎ := sum - -attribute sum.rec [elim] - -protected definition sum.elim [unfold 4] (H₁ : a ⊎ b) (H₂ : a → c) (H₃ : b → c) : c := -sum.rec H₂ H₃ H₁ - -definition non_contradictory_em (a : Type) : ¬¬(a ⊎ ¬a) := -assume not_em : ¬(a ⊎ ¬a), - have neg_a : ¬a, from - assume pos_a : a, absurd (sum.inl pos_a) not_em, - absurd (sum.inr neg_a) not_em - -definition sum.swap : a ⊎ b → b ⊎ a := sum.rec sum.inr sum.inl - - -/- iff -/ - -definition iff (a b : Type) := (a → b) × (b → a) - -notation a <-> b := iff a b -notation a ↔ b := iff a b - -definition iff.intro : (a → b) → (b → a) → (a ↔ b) := prod.mk - -attribute iff.intro [intro!] - -definition iff.elim : ((a → b) → (b → a) → c) → (a ↔ b) → c := prod.rec - -attribute iff.elim [recursor 5] [elim] - -definition iff.elim_left : (a ↔ b) → a → b := prod.pr1 - -definition iff.mp := @iff.elim_left - -definition iff.elim_right : (a ↔ b) → b → a := prod.pr2 - -definition iff.mpr := @iff.elim_right - -definition iff.refl [refl] (a : Type) : a ↔ a := -iff.intro (assume H, H) (assume H, H) - -definition iff.rfl {a : Type} : a ↔ a := -iff.refl a - -definition iff.trans [trans] (H₁ : a ↔ b) (H₂ : b ↔ c) : a ↔ c := -iff.intro - (assume Ha, iff.mp H₂ (iff.mp H₁ Ha)) - (assume Hc, iff.mpr H₁ (iff.mpr H₂ Hc)) - -definition iff.symm [symm] (H : a ↔ b) : b ↔ a := -iff.intro (iff.elim_right H) (iff.elim_left H) - -definition iff.comm : (a ↔ b) ↔ (b ↔ a) := -iff.intro iff.symm iff.symm - -definition iff.of_eq {a b : Type} (H : a = b) : a ↔ b := -eq.rec_on H iff.rfl - -definition not_iff_not_of_iff (H₁ : a ↔ b) : ¬a ↔ ¬b := -iff.intro - (assume (Hna : ¬ a) (Hb : b), Hna (iff.elim_right H₁ Hb)) - (assume (Hnb : ¬ b) (Ha : a), Hnb (iff.elim_left H₁ Ha)) - -definition of_iff_unit (H : a ↔ unit) : a := -iff.mp (iff.symm H) star - -definition not_of_iff_empty : (a ↔ empty) → ¬a := iff.mp - -definition iff_unit_intro (H : a) : a ↔ unit := -iff.intro - (λ Hl, star) - (λ Hr, H) - -definition iff_empty_intro (H : ¬a) : a ↔ empty := -iff.intro H (empty.rec _) - -definition not_non_contradictory_iff_absurd (a : Type) : ¬¬¬a ↔ ¬a := -iff.intro - (λ (Hl : ¬¬¬a) (Ha : a), Hl (non_contradictory_intro Ha)) - absurd - -definition imp_congr [congr] (H1 : a ↔ c) (H2 : b ↔ d) : (a → b) ↔ (c → d) := -iff.intro - (λHab Hc, iff.mp H2 (Hab (iff.mpr H1 Hc))) - (λHcd Ha, iff.mpr H2 (Hcd (iff.mp H1 Ha))) - -definition not_not_intro (Ha : a) : ¬¬a := -assume Hna : ¬a, Hna Ha - -definition not_of_not_not_not (H : ¬¬¬a) : ¬a := -λ Ha, absurd (not_not_intro Ha) H - -definition not_unit [simp] : (¬ unit) ↔ empty := -iff_empty_intro (not_not_intro star) - -definition not_empty_iff [simp] : (¬ empty) ↔ unit := -iff_unit_intro not_empty - -definition not_congr (H : a ↔ b) : ¬a ↔ ¬b := -iff.intro (λ H₁ H₂, H₁ (iff.mpr H H₂)) (λ H₁ H₂, H₁ (iff.mp H H₂)) - -definition ne_self_iff_empty [simp] {A : Type} (a : A) : (not (a = a)) ↔ empty := -iff.intro empty_of_ne empty.elim - -definition eq_self_iff_unit [simp] {A : Type} (a : A) : (a = a) ↔ unit := -iff_unit_intro rfl - -definition iff_not_self [simp] (a : Type) : (a ↔ ¬a) ↔ empty := -iff_empty_intro (λ H, - have H' : ¬a, from (λ Ha, (iff.mp H Ha) Ha), - H' (iff.mpr H H')) - -definition not_iff_self [simp] (a : Type) : (¬a ↔ a) ↔ empty := -iff_empty_intro (λ H, - have H' : ¬a, from (λ Ha, (iff.mpr H Ha) Ha), - H' (iff.mp H H')) - -definition unit_iff_empty [simp] : (unit ↔ empty) ↔ empty := -iff_empty_intro (λ H, iff.mp H star) - -definition empty_iff_unit [simp] : (empty ↔ unit) ↔ empty := -iff_empty_intro (λ H, iff.mpr H star) - -definition empty_of_unit_iff_empty : (unit ↔ empty) → empty := -assume H, iff.mp H star - -/- prod simp rules -/ -definition prod.imp (H₂ : a → c) (H₃ : b → d) : a × b → c × d := -prod.rec (λHa Hb, prod.mk (H₂ Ha) (H₃ Hb)) - -definition prod_congr [congr] (H1 : a ↔ c) (H2 : b ↔ d) : (a × b) ↔ (c × d) := -iff.intro (prod.imp (iff.mp H1) (iff.mp H2)) (prod.imp (iff.mpr H1) (iff.mpr H2)) - -definition prod.comm [simp] : a × b ↔ b × a := -iff.intro prod.swap prod.swap - -definition prod.assoc [simp] : (a × b) × c ↔ a × (b × c) := -iff.intro - (prod.rec (λ H' Hc, prod.rec (λ Ha Hb, prod.mk Ha (prod.mk Hb Hc)) H')) - (prod.rec (λ Ha, prod.rec (λ Hb Hc, prod.mk (prod.mk Ha Hb) Hc))) - -definition prod.pr1_comm [simp] : a × (b × c) ↔ b × (a × c) := -iff.trans (iff.symm !prod.assoc) (iff.trans (prod_congr !prod.comm !iff.refl) !prod.assoc) - -definition prod_iff_left {a b : Type} (Hb : b) : (a × b) ↔ a := -iff.intro prod.pr1 (λHa, prod.mk Ha Hb) - -definition prod_iff_right {a b : Type} (Ha : a) : (a × b) ↔ b := -iff.intro prod.pr2 (prod.mk Ha) - -definition prod_unit [simp] (a : Type) : a × unit ↔ a := -prod_iff_left star - -definition unit_prod [simp] (a : Type) : unit × a ↔ a := -prod_iff_right star - -definition prod_empty [simp] (a : Type) : a × empty ↔ empty := -iff_empty_intro prod.pr2 - -definition empty_prod [simp] (a : Type) : empty × a ↔ empty := -iff_empty_intro prod.pr1 - -definition not_prod_self [simp] (a : Type) : (¬a × a) ↔ empty := -iff_empty_intro (λ H, prod.elim H (λ H₁ H₂, absurd H₂ H₁)) - -definition prod_not_self [simp] (a : Type) : (a × ¬a) ↔ empty := -iff_empty_intro (λ H, prod.elim H (λ H₁ H₂, absurd H₁ H₂)) - -definition prod_self [simp] (a : Type) : a × a ↔ a := -iff.intro prod.pr1 (assume H, prod.mk H H) - -/- sum simp rules -/ - -definition sum.imp (H₂ : a → c) (H₃ : b → d) : a ⊎ b → c ⊎ d := -sum.rec (λ H, sum.inl (H₂ H)) (λ H, sum.inr (H₃ H)) - -definition sum.imp_left (H : a → b) : a ⊎ c → b ⊎ c := -sum.imp H id - -definition sum.imp_right (H : a → b) : c ⊎ a → c ⊎ b := -sum.imp id H - -definition sum_congr [congr] (H1 : a ↔ c) (H2 : b ↔ d) : (a ⊎ b) ↔ (c ⊎ d) := -iff.intro (sum.imp (iff.mp H1) (iff.mp H2)) (sum.imp (iff.mpr H1) (iff.mpr H2)) - -definition sum.comm [simp] : a ⊎ b ↔ b ⊎ a := iff.intro sum.swap sum.swap - -definition sum.assoc [simp] : (a ⊎ b) ⊎ c ↔ a ⊎ (b ⊎ c) := -iff.intro - (sum.rec (sum.imp_right sum.inl) (λ H, sum.inr (sum.inr H))) - (sum.rec (λ H, sum.inl (sum.inl H)) (sum.imp_left sum.inr)) - -definition sum.left_comm [simp] : a ⊎ (b ⊎ c) ↔ b ⊎ (a ⊎ c) := -iff.trans (iff.symm !sum.assoc) (iff.trans (sum_congr !sum.comm !iff.refl) !sum.assoc) - -definition sum_unit [simp] (a : Type) : a ⊎ unit ↔ unit := -iff_unit_intro (sum.inr star) - -definition unit_sum [simp] (a : Type) : unit ⊎ a ↔ unit := -iff_unit_intro (sum.inl star) - -definition sum_empty [simp] (a : Type) : a ⊎ empty ↔ a := -iff.intro (sum.rec id empty.elim) sum.inl - -definition empty_sum [simp] (a : Type) : empty ⊎ a ↔ a := -iff.trans sum.comm !sum_empty - -definition sum_self [simp] (a : Type) : a ⊎ a ↔ a := -iff.intro (sum.rec id id) sum.inl - -/- sum resolution rulse -/ - -definition sum.resolve_left {a b : Type} (H : a ⊎ b) (na : ¬ a) : b := - sum.elim H (λ Ha, absurd Ha na) id - -definition sum.neg_resolve_left {a b : Type} (H : ¬ a ⊎ b) (Ha : a) : b := - sum.elim H (λ na, absurd Ha na) id - -definition sum.resolve_right {a b : Type} (H : a ⊎ b) (nb : ¬ b) : a := - sum.elim H id (λ Hb, absurd Hb nb) - -definition sum.neg_resolve_right {a b : Type} (H : a ⊎ ¬ b) (Hb : b) : a := - sum.elim H id (λ nb, absurd Hb nb) - -/- iff simp rules -/ - -definition iff_unit [simp] (a : Type) : (a ↔ unit) ↔ a := -iff.intro (assume H, iff.mpr H star) iff_unit_intro - -definition unit_iff [simp] (a : Type) : (unit ↔ a) ↔ a := -iff.trans iff.comm !iff_unit - -definition iff_empty [simp] (a : Type) : (a ↔ empty) ↔ ¬ a := -iff.intro prod.pr1 iff_empty_intro - -definition empty_iff [simp] (a : Type) : (empty ↔ a) ↔ ¬ a := -iff.trans iff.comm !iff_empty - -definition iff_self [simp] (a : Type) : (a ↔ a) ↔ unit := -iff_unit_intro iff.rfl - -definition iff_congr [congr] (H1 : a ↔ c) (H2 : b ↔ d) : (a ↔ b) ↔ (c ↔ d) := -prod_congr (imp_congr H1 H2) (imp_congr H2 H1) - -/- decidable -/ - -inductive decidable [class] (p : Type) : Type := -| inl : p → decidable p -| inr : ¬p → decidable p - -definition decidable_unit [instance] : decidable unit := -decidable.inl star - -definition decidable_empty [instance] : decidable empty := -decidable.inr not_empty - --- We use "dependent" if-then-else to be able to communicate the if-then-else condition --- to the branches -definition dite (c : Type) [H : decidable c] {A : Type} : (c → A) → (¬ c → A) → A := -decidable.rec_on H - -/- if-then-else -/ - -definition ite (c : Type) [H : decidable c] {A : Type} (t e : A) : A := -decidable.rec_on H (λ Hc, t) (λ Hnc, e) - -namespace decidable - variables {p q : Type} - - definition by_cases {q : Type} [C : decidable p] : (p → q) → (¬p → q) → q := !dite - - theorem em (p : Type) [H : decidable p] : p ⊎ ¬p := by_cases sum.inl sum.inr - - theorem by_contradiction [Hp : decidable p] (H : ¬p → empty) : p := - if H1 : p then H1 else empty.rec _ (H H1) -end decidable - -section - variables {p q : Type} - open decidable - definition decidable_of_decidable_of_iff (Hp : decidable p) (H : p ↔ q) : decidable q := - if Hp : p then inl (iff.mp H Hp) - else inr (iff.mp (not_iff_not_of_iff H) Hp) - - definition decidable_of_decidable_of_eq {p q : Type} (Hp : decidable p) (H : p = q) - : decidable q := - decidable_of_decidable_of_iff Hp (iff.of_eq H) - - protected definition sum.by_cases [Hp : decidable p] [Hq : decidable q] {A : Type} - (h : p ⊎ q) (h₁ : p → A) (h₂ : q → A) : A := - if hp : p then h₁ hp else - if hq : q then h₂ hq else - empty.rec _ (sum.elim h hp hq) -end - -section - variables {p q : Type} - open decidable (rec_on inl inr) - - definition decidable_prod [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p × q) := - if hp : p then - if hq : q then inl (prod.mk hp hq) - else inr (assume H : p × q, hq (prod.pr2 H)) - else inr (assume H : p × q, hp (prod.pr1 H)) - - definition decidable_sum [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p ⊎ q) := - if hp : p then inl (sum.inl hp) else - if hq : q then inl (sum.inr hq) else - inr (sum.rec hp hq) - - definition decidable_not [instance] [Hp : decidable p] : decidable (¬p) := - if hp : p then inr (absurd hp) else inl hp - - definition decidable_implies [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p → q) := - if hp : p then - if hq : q then inl (assume H, hq) - else inr (assume H : p → q, absurd (H hp) hq) - else inl (assume Hp, absurd Hp hp) - - definition decidable_iff [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p ↔ q) := - decidable_prod - -end - -definition decidable_pred [reducible] {A : Type} (R : A → Type) := Π (a : A), decidable (R a) -definition decidable_rel [reducible] {A : Type} (R : A → A → Type) := Π (a b : A), decidable (R a b) -definition decidable_eq [reducible] (A : Type) := decidable_rel (@eq A) -definition decidable_ne [instance] {A : Type} [H : decidable_eq A] (a b : A) : decidable (a ≠ b) := -decidable_implies - -namespace bool - theorem ff_ne_tt : ff = tt → empty - | [none] -end bool - -open bool -definition is_dec_eq {A : Type} (p : A → A → bool) : Type := Π ⦃x y : A⦄, p x y = tt → x = y -definition is_dec_refl {A : Type} (p : A → A → bool) : Type := Πx, p x x = tt - -open decidable -protected definition bool.has_decidable_eq [instance] : Πa b : bool, decidable (a = b) -| ff ff := inl rfl -| ff tt := inr ff_ne_tt -| tt ff := inr (ne.symm ff_ne_tt) -| tt tt := inl rfl - -definition decidable_eq_of_bool_pred {A : Type} {p : A → A → bool} (H₁ : is_dec_eq p) (H₂ : is_dec_refl p) : decidable_eq A := -take x y : A, if Hp : p x y = tt then inl (H₁ Hp) - else inr (assume Hxy : x = y, (eq.subst Hxy Hp) (H₂ y)) - -/- inhabited -/ - -inductive inhabited [class] (A : Type) : Type := -mk : A → inhabited A - -protected definition inhabited.value {A : Type} : inhabited A → A := -inhabited.rec (λa, a) - -protected definition inhabited.destruct {A : Type} {B : Type} (H1 : inhabited A) (H2 : A → B) : B := -inhabited.rec H2 H1 - -definition default (A : Type) [H : inhabited A] : A := -inhabited.value H - -definition arbitrary [irreducible] (A : Type) [H : inhabited A] : A := -inhabited.value H - -definition Type.is_inhabited [instance] : inhabited Type := -inhabited.mk (lift unit) - -definition inhabited_fun [instance] (A : Type) {B : Type} [H : inhabited B] : inhabited (A → B) := -inhabited.rec_on H (λb, inhabited.mk (λa, b)) - -definition inhabited_Pi [instance] (A : Type) {B : A → Type} [H : Πx, inhabited (B x)] : - inhabited (Πx, B x) := -inhabited.mk (λa, !default) - -protected definition bool.is_inhabited [instance] : inhabited bool := -inhabited.mk ff - -protected definition pos_num.is_inhabited [instance] : inhabited pos_num := -inhabited.mk pos_num.one - -protected definition num.is_inhabited [instance] : inhabited num := -inhabited.mk num.zero - -inductive nonempty [class] (A : Type) : Type := -intro : A → nonempty A - -protected definition nonempty.elim {A : Type} {B : Type} (H1 : nonempty A) (H2 : A → B) : B := -nonempty.rec H2 H1 - -theorem nonempty_of_inhabited [instance] {A : Type} [H : inhabited A] : nonempty A := -nonempty.intro !default - -theorem nonempty_of_exists {A : Type} {P : A → Type} : (sigma P) → nonempty A := -sigma.rec (λw H, nonempty.intro w) - -/- subsingleton -/ - -inductive subsingleton [class] (A : Type) : Type := -intro : (Π a b : A, a = b) → subsingleton A - -protected definition subsingleton.elim {A : Type} [H : subsingleton A] : Π(a b : A), a = b := -subsingleton.rec (λp, p) H - -protected theorem rec_subsingleton {p : Type} [H : decidable p] - {H1 : p → Type} {H2 : ¬p → Type} - [H3 : Π(h : p), subsingleton (H1 h)] [H4 : Π(h : ¬p), subsingleton (H2 h)] - : subsingleton (decidable.rec_on H H1 H2) := -decidable.rec_on H (λh, H3 h) (λh, H4 h) --this can be proven using dependent version of "by_cases" - -theorem if_pos {c : Type} [H : decidable c] (Hc : c) {A : Type} {t e : A} : (ite c t e) = t := -decidable.rec - (λ Hc : c, eq.refl (@ite c (decidable.inl Hc) A t e)) - (λ Hnc : ¬c, absurd Hc Hnc) - H - -theorem if_neg {c : Type} [H : decidable c] (Hnc : ¬c) {A : Type} {t e : A} : (ite c t e) = e := -decidable.rec - (λ Hc : c, absurd Hc Hnc) - (λ Hnc : ¬c, eq.refl (@ite c (decidable.inr Hnc) A t e)) - H - -theorem if_t_t [simp] (c : Type) [H : decidable c] {A : Type} (t : A) : (ite c t t) = t := -decidable.rec - (λ Hc : c, eq.refl (@ite c (decidable.inl Hc) A t t)) - (λ Hnc : ¬c, eq.refl (@ite c (decidable.inr Hnc) A t t)) - H - -theorem implies_of_if_pos {c t e : Type} [H : decidable c] (h : ite c t e) : c → t := -assume Hc, eq.rec_on (if_pos Hc) h - -theorem implies_of_if_neg {c t e : Type} [H : decidable c] (h : ite c t e) : ¬c → e := -assume Hnc, eq.rec_on (if_neg Hnc) h - -theorem if_ctx_congr {A : Type} {b c : Type} [dec_b : decidable b] [dec_c : decidable c] - {x y u v : A} - (h_c : b ↔ c) (h_t : c → x = u) (h_e : ¬c → y = v) : - ite b x y = ite c u v := -decidable.rec_on dec_b - (λ hp : b, calc - ite b x y = x : if_pos hp - ... = u : h_t (iff.mp h_c hp) - ... = ite c u v : if_pos (iff.mp h_c hp)) - (λ hn : ¬b, calc - ite b x y = y : if_neg hn - ... = v : h_e (iff.mp (not_iff_not_of_iff h_c) hn) - ... = ite c u v : if_neg (iff.mp (not_iff_not_of_iff h_c) hn)) - -theorem if_congr [congr] {A : Type} {b c : Type} [dec_b : decidable b] [dec_c : decidable c] - {x y u v : A} - (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) : - ite b x y = ite c u v := -@if_ctx_congr A b c dec_b dec_c x y u v h_c (λ h, h_t) (λ h, h_e) - -theorem if_ctx_simp_congr {A : Type} {b c : Type} [dec_b : decidable b] {x y u v : A} - (h_c : b ↔ c) (h_t : c → x = u) (h_e : ¬c → y = v) : - ite b x y = (@ite c (decidable_of_decidable_of_iff dec_b h_c) A u v) := -@if_ctx_congr A b c dec_b (decidable_of_decidable_of_iff dec_b h_c) x y u v h_c h_t h_e - -theorem if_simp_congr [congr] {A : Type} {b c : Type} [dec_b : decidable b] {x y u v : A} - (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) : - ite b x y = (@ite c (decidable_of_decidable_of_iff dec_b h_c) A u v) := -@if_ctx_simp_congr A b c dec_b x y u v h_c (λ h, h_t) (λ h, h_e) - -definition if_unit [simp] {A : Type} (t e : A) : (if unit then t else e) = t := -if_pos star - -definition if_empty [simp] {A : Type} (t e : A) : (if empty then t else e) = e := -if_neg not_empty - -theorem if_ctx_congr_prop {b c x y u v : Type} [dec_b : decidable b] [dec_c : decidable c] - (h_c : b ↔ c) (h_t : c → (x ↔ u)) (h_e : ¬c → (y ↔ v)) : - ite b x y ↔ ite c u v := -decidable.rec_on dec_b - (λ hp : b, calc - ite b x y ↔ x : iff.of_eq (if_pos hp) - ... ↔ u : h_t (iff.mp h_c hp) - ... ↔ ite c u v : iff.of_eq (if_pos (iff.mp h_c hp))) - (λ hn : ¬b, calc - ite b x y ↔ y : iff.of_eq (if_neg hn) - ... ↔ v : h_e (iff.mp (not_iff_not_of_iff h_c) hn) - ... ↔ ite c u v : iff.of_eq (if_neg (iff.mp (not_iff_not_of_iff h_c) hn))) - -theorem if_congr_prop [congr] {b c x y u v : Type} [dec_b : decidable b] [dec_c : decidable c] - (h_c : b ↔ c) (h_t : x ↔ u) (h_e : y ↔ v) : - ite b x y ↔ ite c u v := -if_ctx_congr_prop h_c (λ h, h_t) (λ h, h_e) - -theorem if_ctx_simp_congr_prop {b c x y u v : Type} [dec_b : decidable b] - (h_c : b ↔ c) (h_t : c → (x ↔ u)) (h_e : ¬c → (y ↔ v)) : - ite b x y ↔ (@ite c (decidable_of_decidable_of_iff dec_b h_c) Type u v) := -@if_ctx_congr_prop b c x y u v dec_b (decidable_of_decidable_of_iff dec_b h_c) h_c h_t h_e - -theorem if_simp_congr_prop [congr] {b c x y u v : Type} [dec_b : decidable b] - (h_c : b ↔ c) (h_t : x ↔ u) (h_e : y ↔ v) : - ite b x y ↔ (@ite c (decidable_of_decidable_of_iff dec_b h_c) Type u v) := -@if_ctx_simp_congr_prop b c x y u v dec_b h_c (λ h, h_t) (λ h, h_e) - --- Remark: dite and ite are "definitionally equal" when we ignore the proofs. -theorem dite_ite_eq (c : Type) [H : decidable c] {A : Type} (t : A) (e : A) : dite c (λh, t) (λh, e) = ite c t e := -rfl - -definition is_unit (c : Type) [H : decidable c] : Type₀ := -if c then unit else empty - -definition is_empty (c : Type) [H : decidable c] : Type₀ := -if c then empty else unit - -definition of_is_unit {c : Type} [H₁ : decidable c] (H₂ : is_unit c) : c := -decidable.rec_on H₁ (λ Hc, Hc) (λ Hnc, empty.rec _ (if_neg Hnc ▸ H₂)) - -notation `dec_star` := of_is_unit star - -theorem not_of_not_is_unit {c : Type} [H₁ : decidable c] (H₂ : ¬ is_unit c) : ¬ c := -if Hc : c then absurd star (if_pos Hc ▸ H₂) else Hc - -theorem not_of_is_empty {c : Type} [H₁ : decidable c] (H₂ : is_empty c) : ¬ c := -if Hc : c then empty.rec _ (if_pos Hc ▸ H₂) else Hc - -theorem of_not_is_empty {c : Type} [H₁ : decidable c] (H₂ : ¬ is_empty c) : c := -if Hc : c then Hc else absurd star (if_neg Hc ▸ H₂) - --- The following symbols should not be considered in the pattern inference procedure used by --- heuristic instantiation. -attribute prod sum not iff ite dite eq ne [no_pattern] - --- namespace used to collect congruence rules for "contextual simplification" -namespace contextual - attribute if_ctx_simp_congr [congr] - attribute if_ctx_simp_congr_prop [congr] -end contextual diff --git a/hott/init/nat.hlean b/hott/init/nat.hlean deleted file mode 100644 index 92bc546322..0000000000 --- a/hott/init/nat.hlean +++ /dev/null @@ -1,262 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn, Leonardo de Moura --/ -prelude -import init.tactic init.num init.types init.path -open eq eq.ops decidable -open algebra sum -set_option class.force_new true - -notation `ℕ` := nat - -namespace nat - protected definition rec_on [reducible] [recursor] [unfold 2] - {C : ℕ → Type} (n : ℕ) (H₁ : C 0) (H₂ : Π (a : ℕ), C a → C (succ a)) : C n := - nat.rec H₁ H₂ n - - protected definition cases_on [reducible] [recursor] [unfold 2] - {C : ℕ → Type} (n : ℕ) (H₁ : C 0) (H₂ : Π (a : ℕ), C (succ a)) : C n := - nat.rec H₁ (λ a ih, H₂ a) n - - protected definition no_confusion_type.{u} [reducible] (P : Type.{u}) (v₁ v₂ : ℕ) : Type.{u} := - nat.rec - (nat.rec - (P → lift P) - (λ a₂ ih, lift P) - v₂) - (λ a₁ ih, nat.rec - (lift P) - (λ a₂ ih, (a₁ = a₂ → P) → lift P) - v₂) - v₁ - - protected definition no_confusion [reducible] [unfold 4] - {P : Type} {v₁ v₂ : ℕ} (H : v₁ = v₂) : nat.no_confusion_type P v₁ v₂ := - eq.rec (λ H₁ : v₁ = v₁, nat.rec (λ h, lift.up h) (λ a ih h, lift.up (h (eq.refl a))) v₁) H H - - /- basic definitions on natural numbers -/ - inductive le (a : ℕ) : ℕ → Type := - | nat_refl : le a a -- use nat_refl to avoid overloading le.refl - | step : Π {b}, le a b → le a (succ b) - - definition nat_has_le [instance] [priority nat.prio]: has_le nat := has_le.mk nat.le - - protected definition le_refl [refl] : Π a : nat, a ≤ a := - le.nat_refl - - protected definition lt [reducible] (n m : ℕ) := succ n ≤ m - definition nat_has_lt [instance] [priority nat.prio] : has_lt nat := has_lt.mk nat.lt - - definition pred [unfold 1] (a : nat) : nat := - nat.cases_on a zero (λ a₁, a₁) - - -- add is defined in init.reserved_notation - - protected definition sub (a b : nat) : nat := - nat.rec_on b a (λ b₁, pred) - - protected definition mul (a b : nat) : nat := - nat.rec_on b zero (λ b₁ r, r + a) - - definition nat_has_sub [instance] [priority nat.prio] : has_sub nat := - has_sub.mk nat.sub - - definition nat_has_mul [instance] [priority nat.prio] : has_mul nat := - has_mul.mk nat.mul - - /- properties of ℕ -/ - - protected definition is_inhabited [instance] : inhabited nat := - inhabited.mk zero - - protected definition has_decidable_eq [instance] [priority nat.prio] : Π x y : nat, decidable (x = y) - | has_decidable_eq zero zero := inl rfl - | has_decidable_eq (succ x) zero := inr (by contradiction) - | has_decidable_eq zero (succ y) := inr (by contradiction) - | has_decidable_eq (succ x) (succ y) := - match has_decidable_eq x y with - | inl xeqy := inl (by rewrite xeqy) - | inr xney := inr (λ h : succ x = succ y, by injection h with xeqy; exact absurd xeqy xney) - end - - /- properties of inequality -/ - - protected definition le_of_eq {n m : ℕ} (p : n = m) : n ≤ m := p ▸ !nat.le_refl - - definition le_succ (n : ℕ) : n ≤ succ n := le.step !nat.le_refl - - definition pred_le (n : ℕ) : pred n ≤ n := by cases n;repeat constructor - - definition le_succ_iff_unit [simp] (n : ℕ) : n ≤ succ n ↔ unit := - iff_unit_intro (le_succ n) - - definition pred_le_iff_unit [simp] (n : ℕ) : pred n ≤ n ↔ unit := - iff_unit_intro (pred_le n) - - protected definition le_trans {n m k : ℕ} (H1 : n ≤ m) : m ≤ k → n ≤ k := - le.rec H1 (λp H2, le.step) - - definition le_succ_of_le {n m : ℕ} (H : n ≤ m) : n ≤ succ m := nat.le_trans H !le_succ - - definition le_of_succ_le {n m : ℕ} (H : succ n ≤ m) : n ≤ m := nat.le_trans !le_succ H - - protected definition le_of_lt {n m : ℕ} (H : n < m) : n ≤ m := le_of_succ_le H - - definition succ_le_succ {n m : ℕ} : n ≤ m → succ n ≤ succ m := - le.rec !nat.le_refl (λa b, le.step) - - theorem pred_le_pred {n m : ℕ} : n ≤ m → pred n ≤ pred m := - le.rec !nat.le_refl (nat.rec (λa b, b) (λa b c, le.step)) - - theorem le_of_succ_le_succ {n m : ℕ} : succ n ≤ succ m → n ≤ m := - pred_le_pred - - theorem le_succ_of_pred_le {n m : ℕ} : pred n ≤ m → n ≤ succ m := - nat.cases_on n le.step (λa, succ_le_succ) - - theorem not_succ_le_zero (n : ℕ) : ¬succ n ≤ 0 := - by intro H; cases H - - theorem succ_le_zero_iff_empty (n : ℕ) : succ n ≤ 0 ↔ empty := - iff_empty_intro !not_succ_le_zero - - theorem not_succ_le_self : Π {n : ℕ}, ¬succ n ≤ n := - nat.rec !not_succ_le_zero (λa b c, b (le_of_succ_le_succ c)) - - theorem succ_le_self_iff_empty [simp] (n : ℕ) : succ n ≤ n ↔ empty := - iff_empty_intro not_succ_le_self - - definition zero_le : Π (n : ℕ), 0 ≤ n := - nat.rec !nat.le_refl (λa, le.step) - - theorem zero_le_iff_unit [simp] (n : ℕ) : 0 ≤ n ↔ unit := - iff_unit_intro !zero_le - - theorem lt.step {n m : ℕ} : n < m → n < succ m := le.step - - theorem zero_lt_succ (n : ℕ) : 0 < succ n := - succ_le_succ !zero_le - - theorem zero_lt_succ_iff_unit [simp] (n : ℕ) : 0 < succ n ↔ unit := - iff_unit_intro (zero_lt_succ n) - - protected theorem lt_trans {n m k : ℕ} (H1 : n < m) : m < k → n < k := - nat.le_trans (le.step H1) - - protected theorem lt_of_le_of_lt {n m k : ℕ} (H1 : n ≤ m) : m < k → n < k := - nat.le_trans (succ_le_succ H1) - - protected theorem lt_of_lt_of_le {n m k : ℕ} : n < m → m ≤ k → n < k := nat.le_trans - - protected theorem lt_irrefl (n : ℕ) : ¬n < n := not_succ_le_self - - theorem lt_self_iff_empty (n : ℕ) : n < n ↔ empty := - iff_empty_intro (λ H, absurd H (nat.lt_irrefl n)) - - theorem self_lt_succ (n : ℕ) : n < succ n := !nat.le_refl - - theorem self_lt_succ_iff_unit [simp] (n : ℕ) : n < succ n ↔ unit := - iff_unit_intro (self_lt_succ n) - - theorem lt.base (n : ℕ) : n < succ n := !nat.le_refl - - theorem le_lt_antisymm {n m : ℕ} (H1 : n ≤ m) (H2 : m < n) : empty := - !nat.lt_irrefl (nat.lt_of_le_of_lt H1 H2) - - protected theorem le_antisymm {n m : ℕ} (H1 : n ≤ m) : m ≤ n → n = m := - le.cases_on H1 (λa, rfl) (λa b c, absurd (nat.lt_of_le_of_lt b c) !nat.lt_irrefl) - - theorem lt_le_antisymm {n m : ℕ} (H1 : n < m) (H2 : m ≤ n) : empty := - le_lt_antisymm H2 H1 - - protected theorem nat.lt_asymm {n m : ℕ} (H1 : n < m) : ¬ m < n := - le_lt_antisymm (nat.le_of_lt H1) - - theorem not_lt_zero (a : ℕ) : ¬ a < 0 := !not_succ_le_zero - - theorem lt_zero_iff_empty [simp] (a : ℕ) : a < 0 ↔ empty := - iff_empty_intro (not_lt_zero a) - - protected theorem eq_sum_lt_of_le {a b : ℕ} (H : a ≤ b) : a = b ⊎ a < b := - le.cases_on H (inl rfl) (λn h, inr (succ_le_succ h)) - - protected theorem le_of_eq_sum_lt {a b : ℕ} (H : a = b ⊎ a < b) : a ≤ b := - sum.rec_on H !nat.le_of_eq !nat.le_of_lt - - theorem succ_lt_succ {a b : ℕ} : a < b → succ a < succ b := - succ_le_succ - - theorem lt_of_succ_lt {a b : ℕ} : succ a < b → a < b := - le_of_succ_le - - theorem lt_of_succ_lt_succ {a b : ℕ} : succ a < succ b → a < b := - le_of_succ_le_succ - - definition decidable_le [instance] [priority nat.prio] : Π a b : nat, decidable (a ≤ b) := - nat.rec (λm, (decidable.inl !zero_le)) - (λn IH m, !nat.cases_on (decidable.inr (not_succ_le_zero n)) - (λm, decidable.rec (λH, inl (succ_le_succ H)) - (λH, inr (λa, H (le_of_succ_le_succ a))) (IH m))) - - definition decidable_lt [instance] [priority nat.prio] : Π a b : nat, decidable (a < b) := - λ a b, decidable_le (succ a) b - - protected theorem lt_sum_ge (a b : ℕ) : a < b ⊎ a ≥ b := - nat.rec (inr !zero_le) (λn, sum.rec - (λh, inl (le_succ_of_le h)) - (λh, sum.rec_on (nat.eq_sum_lt_of_le h) (λe, inl (eq.subst e !nat.le_refl)) inr)) b - - protected definition lt_ge_by_cases {a b : ℕ} {P : Type} (H1 : a < b → P) (H2 : a ≥ b → P) : P := - by_cases H1 (λh, H2 (sum.rec_on !nat.lt_sum_ge (λa, absurd a h) (λa, a))) - - protected definition lt_by_cases {a b : ℕ} {P : Type} (H1 : a < b → P) (H2 : a = b → P) - (H3 : b < a → P) : P := - nat.lt_ge_by_cases H1 (λh₁, - nat.lt_ge_by_cases H3 (λh₂, H2 (nat.le_antisymm h₂ h₁))) - - protected theorem lt_trichotomy (a b : ℕ) : a < b ⊎ a = b ⊎ b < a := - nat.lt_by_cases (λH, inl H) (λH, inr (inl H)) (λH, inr (inr H)) - - protected theorem eq_sum_lt_of_not_lt {a b : ℕ} (hnlt : ¬ a < b) : a = b ⊎ b < a := - sum.rec_on (nat.lt_trichotomy a b) - (λ hlt, absurd hlt hnlt) - (λ h, h) - - theorem lt_succ_of_le {a b : ℕ} : a ≤ b → a < succ b := - succ_le_succ - - theorem lt_of_succ_le {a b : ℕ} (h : succ a ≤ b) : a < b := h - - theorem succ_le_of_lt {a b : ℕ} (h : a < b) : succ a ≤ b := h - - theorem succ_sub_succ_eq_sub [simp] (a b : ℕ) : succ a - succ b = a - b := - nat.rec (by esimp) (λ b, ap pred) b - - theorem sub_eq_succ_sub_succ (a b : ℕ) : a - b = succ a - succ b := - inverse !succ_sub_succ_eq_sub - - theorem zero_sub_eq_zero [simp] (a : ℕ) : 0 - a = 0 := - nat.rec rfl (λ a, ap pred) a - - theorem zero_eq_zero_sub (a : ℕ) : 0 = 0 - a := - inverse !zero_sub_eq_zero - - theorem sub_le (a b : ℕ) : a - b ≤ a := - nat.rec_on b !nat.le_refl (λ b₁, nat.le_trans !pred_le) - - theorem sub_le_iff_unit [simp] (a b : ℕ) : a - b ≤ a ↔ unit := - iff_unit_intro (sub_le a b) - - theorem sub_lt {a b : ℕ} (H1 : 0 < a) (H2 : 0 < b) : a - b < a := - !nat.cases_on (λh, absurd h !nat.lt_irrefl) - (λa h, succ_le_succ (!nat.cases_on (λh, absurd h !nat.lt_irrefl) - (λb c, tr_rev _ !succ_sub_succ_eq_sub !sub_le) H2)) H1 - - theorem sub_lt_succ (a b : ℕ) : a - b < succ a := - lt_succ_of_le !sub_le - - theorem sub_lt_succ_iff_unit [simp] (a b : ℕ) : a - b < succ a ↔ unit := - iff_unit_intro !sub_lt_succ -end nat diff --git a/hott/init/num.hlean b/hott/init/num.hlean deleted file mode 100644 index 255f903d05..0000000000 --- a/hott/init/num.hlean +++ /dev/null @@ -1,84 +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 --/ -prelude -import init.bool -open bool algebra - -namespace pos_num - protected definition mul (a b : pos_num) : pos_num := - pos_num.rec_on a - b - (λn r, bit0 r + b) - (λn r, bit0 r) - - definition lt (a b : pos_num) : bool := - pos_num.rec_on a - (λ b, pos_num.cases_on b - ff - (λm, tt) - (λm, tt)) - (λn f b, pos_num.cases_on b - ff - (λm, f m) - (λm, f m)) - (λn f b, pos_num.cases_on b - ff - (λm, f (succ m)) - (λm, f m)) - b - - definition le (a b : pos_num) : bool := - pos_num.lt a (succ b) -end pos_num - -definition pos_num_has_mul [instance] : has_mul pos_num := -has_mul.mk pos_num.mul - -namespace num - open pos_num - - definition pred (a : num) : num := - num.rec_on a zero (λp, cond (is_one p) zero (pos (pred p))) - - definition size (a : num) : num := - num.rec_on a (pos one) (λp, pos (size p)) - - protected definition mul (a b : num) : num := - num.rec_on a zero (λpa, num.rec_on b zero (λpb, pos (pos_num.mul pa pb))) -end num - -definition num_has_mul [instance] : has_mul num := -has_mul.mk num.mul - -namespace num - protected definition le (a b : num) : bool := - num.rec_on a tt (λpa, num.rec_on b ff (λpb, pos_num.le pa pb)) - - private definition psub (a b : pos_num) : num := - pos_num.rec_on a - (λb, zero) - (λn f b, - cond (pos_num.le (bit1 n) b) - zero - (pos_num.cases_on b - (pos (bit0 n)) - (λm, 2 * f m) - (λm, 2 * f m + 1))) - (λn f b, - cond (pos_num.le (bit0 n) b) - zero - (pos_num.cases_on b - (pos (pos_num.pred (bit0 n))) - (λm, pred (2 * f m)) - (λm, 2 * f m))) - b - - protected definition sub (a b : num) : num := - num.rec_on a zero (λpa, num.rec_on b a (λpb, psub pa pb)) -end num - -definition num_has_sub [instance] : has_sub num := -has_sub.mk num.sub diff --git a/hott/init/path.hlean b/hott/init/path.hlean deleted file mode 100644 index 8680026961..0000000000 --- a/hott/init/path.hlean +++ /dev/null @@ -1,712 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Jeremy Avigad, Jakob von Raumer, Floris van Doorn - -Ported from Coq HoTT --/ - -prelude -import .function .tactic - -open function eq - -/- Path equality -/ - -namespace eq - variables {A B C : Type} {P : A → Type} {a a' x y z t : A} {b b' : B} - - --notation a = b := eq a b - notation x = y `:>`:50 A:49 := @eq A x y - definition idp [reducible] [constructor] {a : A} := refl a - definition idpath [reducible] [constructor] (a : A) := refl a - - -- unbased path induction - definition rec' [reducible] [unfold 6] {P : Π (a b : A), (a = b) → Type} - (H : Π (a : A), P a a idp) {a b : A} (p : a = b) : P a b p := - eq.rec (H a) p - - definition rec_on' [reducible] [unfold 5] {P : Π (a b : A), (a = b) → Type} - {a b : A} (p : a = b) (H : Π (a : A), P a a idp) : P a b p := - eq.rec (H a) p - - /- Concatenation and inverse -/ - - definition concat [trans] [unfold 6] (p : x = y) (q : y = z) : x = z := - by induction q; exact p - - definition inverse [symm] [unfold 4] (p : x = y) : y = x := - by induction p; reflexivity - - infix ⬝ := concat - postfix ⁻¹ := inverse - --a second notation for the inverse, which is not overloaded - postfix [parsing_only] `⁻¹ᵖ`:std.prec.max_plus := inverse - - /- The 1-dimensional groupoid structure -/ - - -- The identity path is a right unit. - definition con_idp [unfold_full] (p : x = y) : p ⬝ idp = p := - idp - - -- The identity path is a right unit. - definition idp_con [unfold 4] (p : x = y) : idp ⬝ p = p := - by induction p; reflexivity - - -- Concatenation is associative. - definition con.assoc' (p : x = y) (q : y = z) (r : z = t) : - p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r := - by induction r; reflexivity - - definition con.assoc (p : x = y) (q : y = z) (r : z = t) : - (p ⬝ q) ⬝ r = p ⬝ (q ⬝ r) := - by induction r; reflexivity - - -- The left inverse law. - definition con.right_inv [unfold 4] (p : x = y) : p ⬝ p⁻¹ = idp := - by induction p; reflexivity - - -- The right inverse law. - definition con.left_inv [unfold 4] (p : x = y) : p⁻¹ ⬝ p = idp := - by induction p; reflexivity - - /- Several auxiliary theorems about canceling inverses across associativity. These are somewhat - redundant, following from earlier theorems. -/ - - definition inv_con_cancel_left (p : x = y) (q : y = z) : p⁻¹ ⬝ (p ⬝ q) = q := - by induction q; induction p; reflexivity - - definition con_inv_cancel_left (p : x = y) (q : x = z) : p ⬝ (p⁻¹ ⬝ q) = q := - by induction q; induction p; reflexivity - - definition con_inv_cancel_right (p : x = y) (q : y = z) : (p ⬝ q) ⬝ q⁻¹ = p := - by induction q; reflexivity - - definition inv_con_cancel_right (p : x = z) (q : y = z) : (p ⬝ q⁻¹) ⬝ q = p := - by induction q; reflexivity - - -- Inverse distributes over concatenation - definition con_inv (p : x = y) (q : y = z) : (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ := - by induction q; induction p; reflexivity - - definition inv_con_inv_left (p : y = x) (q : y = z) : (p⁻¹ ⬝ q)⁻¹ = q⁻¹ ⬝ p := - by induction q; induction p; reflexivity - - -- universe metavariables - definition inv_con_inv_right (p : x = y) (q : z = y) : (p ⬝ q⁻¹)⁻¹ = q ⬝ p⁻¹ := - by induction q; induction p; reflexivity - - definition inv_con_inv_inv (p : y = x) (q : z = y) : (p⁻¹ ⬝ q⁻¹)⁻¹ = q ⬝ p := - by induction q; induction p; reflexivity - - -- Inverse is an involution. - definition inv_inv (p : x = y) : p⁻¹⁻¹ = p := - by induction p; reflexivity - - -- auxiliary definition used by 'cases' tactic - definition elim_inv_inv {A : Type} {a b : A} {C : a = b → Type} (H₁ : a = b) (H₂ : C (H₁⁻¹⁻¹)) : C H₁ := - eq.rec_on (inv_inv H₁) H₂ - - /- Theorems for moving things around in equations -/ - - definition con_eq_of_eq_inv_con {p : x = z} {q : y = z} {r : y = x} : - p = r⁻¹ ⬝ q → r ⬝ p = q := - begin - induction r, intro h, exact !idp_con ⬝ h ⬝ !idp_con - end - - definition con_eq_of_eq_con_inv [unfold 5] {p : x = z} {q : y = z} {r : y = x} : - r = q ⬝ p⁻¹ → r ⬝ p = q := - by induction p; exact id - - definition inv_con_eq_of_eq_con {p : x = z} {q : y = z} {r : x = y} : - p = r ⬝ q → r⁻¹ ⬝ p = q := - by induction r; intro h; exact !idp_con ⬝ h ⬝ !idp_con - - definition con_inv_eq_of_eq_con [unfold 5] {p : z = x} {q : y = z} {r : y = x} : - r = q ⬝ p → r ⬝ p⁻¹ = q := - by induction p; exact id - - definition eq_con_of_inv_con_eq {p : x = z} {q : y = z} {r : y = x} : - r⁻¹ ⬝ q = p → q = r ⬝ p := - by induction r; intro h; exact !idp_con⁻¹ ⬝ h ⬝ !idp_con⁻¹ - - definition eq_con_of_con_inv_eq [unfold 5] {p : x = z} {q : y = z} {r : y = x} : - q ⬝ p⁻¹ = r → q = r ⬝ p := - by induction p; exact id - - definition eq_inv_con_of_con_eq {p : x = z} {q : y = z} {r : x = y} : - r ⬝ q = p → q = r⁻¹ ⬝ p := - by induction r; intro h; exact !idp_con⁻¹ ⬝ h ⬝ !idp_con⁻¹ - - definition eq_con_inv_of_con_eq [unfold 5] {p : z = x} {q : y = z} {r : y = x} : - q ⬝ p = r → q = r ⬝ p⁻¹ := - by induction p; exact id - - definition eq_of_con_inv_eq_idp [unfold 5] {p q : x = y} : p ⬝ q⁻¹ = idp → p = q := - by induction q; exact id - - definition eq_of_inv_con_eq_idp {p q : x = y} : q⁻¹ ⬝ p = idp → p = q := - by induction q; intro h; exact !idp_con⁻¹ ⬝ h - - definition eq_inv_of_con_eq_idp' [unfold 5] {p : x = y} {q : y = x} : p ⬝ q = idp → p = q⁻¹ := - by induction q; exact id - - definition eq_inv_of_con_eq_idp {p : x = y} {q : y = x} : q ⬝ p = idp → p = q⁻¹ := - by induction q; intro h; exact !idp_con⁻¹ ⬝ h - - definition eq_of_idp_eq_inv_con {p q : x = y} : idp = p⁻¹ ⬝ q → p = q := - by induction p; intro h; exact h ⬝ !idp_con - - definition eq_of_idp_eq_con_inv [unfold 4] {p q : x = y} : idp = q ⬝ p⁻¹ → p = q := - by induction p; exact id - - definition inv_eq_of_idp_eq_con [unfold 4] {p : x = y} {q : y = x} : idp = q ⬝ p → p⁻¹ = q := - by induction p; exact id - - definition inv_eq_of_idp_eq_con' {p : x = y} {q : y = x} : idp = p ⬝ q → p⁻¹ = q := - by induction p; intro h; exact h ⬝ !idp_con - - definition con_inv_eq_idp [unfold 6] {p q : x = y} (r : p = q) : p ⬝ q⁻¹ = idp := - by cases r; apply con.right_inv - - definition inv_con_eq_idp [unfold 6] {p q : x = y} (r : p = q) : q⁻¹ ⬝ p = idp := - by cases r; apply con.left_inv - - definition con_eq_idp {p : x = y} {q : y = x} (r : p = q⁻¹) : p ⬝ q = idp := - by cases q; exact r - - definition idp_eq_inv_con {p q : x = y} (r : p = q) : idp = p⁻¹ ⬝ q := - by cases r; exact !con.left_inv⁻¹ - - definition idp_eq_con_inv {p q : x = y} (r : p = q) : idp = q ⬝ p⁻¹ := - by cases r; exact !con.right_inv⁻¹ - - definition idp_eq_con {p : x = y} {q : y = x} (r : p⁻¹ = q) : idp = q ⬝ p := - by cases p; exact r - - /- Transport -/ - - definition transport [subst] [reducible] [unfold 5] (P : A → Type) {x y : A} (p : x = y) - (u : P x) : P y := - by induction p; exact u - - -- This idiom makes the operation right associative. - infixr ` ▸ ` := transport _ - - definition cast [reducible] [unfold 3] {A B : Type} (p : A = B) (a : A) : B := - p ▸ a - - definition cast_def [reducible] [unfold_full] {A B : Type} (p : A = B) (a : A) - : cast p a = p ▸ a := - idp - - definition tr_rev [reducible] [unfold 6] (P : A → Type) {x y : A} (p : x = y) (u : P y) : P x := - p⁻¹ ▸ u - - definition ap [unfold 6] ⦃A B : Type⦄ (f : A → B) {x y:A} (p : x = y) : f x = f y := - by induction p; reflexivity - - abbreviation ap01 [parsing_only] := ap - - definition homotopy [reducible] (f g : Πx, P x) : Type := - Πx : A, f x = g x - - infix ~ := homotopy - - protected definition homotopy.refl [refl] [reducible] [unfold_full] (f : Πx, P x) : f ~ f := - λ x, idp - - protected definition homotopy.symm [symm] [reducible] [unfold_full] {f g : Πx, P x} (H : f ~ g) - : g ~ f := - λ x, (H x)⁻¹ - - protected definition homotopy.trans [trans] [reducible] [unfold_full] {f g h : Πx, P x} - (H1 : f ~ g) (H2 : g ~ h) : f ~ h := - λ x, H1 x ⬝ H2 x - - definition homotopy_of_eq {f g : Πx, P x} (H1 : f = g) : f ~ g := - H1 ▸ homotopy.refl f - - definition apd10 [unfold 5] {f g : Πx, P x} (H : f = g) : f ~ g := - λx, by induction H; reflexivity - - --the next theorem is useful if you want to write "apply (apd10' a)" - definition apd10' [unfold 6] {f g : Πx, P x} (a : A) (H : f = g) : f a = g a := - by induction H; reflexivity - - --apd10 is also ap evaluation - definition apd10_eq_ap_eval {f g : Πx, P x} (H : f = g) (a : A) - : apd10 H a = ap (λs : Πx, P x, s a) H := - by induction H; reflexivity - - definition ap10 [reducible] [unfold 5] {f g : A → B} (H : f = g) : f ~ g := apd10 H - - definition ap11 {f g : A → B} (H : f = g) {x y : A} (p : x = y) : f x = g y := - by induction H; exact ap f p - - definition apd [unfold 6] (f : Πa, P a) {x y : A} (p : x = y) : p ▸ f x = f y := - by induction p; reflexivity - - definition ap011 [unfold 9] (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' := - by cases Ha; exact ap (f a) Hb - - /- More theorems for moving things around in equations -/ - - definition tr_eq_of_eq_inv_tr {P : A → Type} {x y : A} {p : x = y} {u : P x} {v : P y} : - u = p⁻¹ ▸ v → p ▸ u = v := - by induction p; exact id - - definition inv_tr_eq_of_eq_tr {P : A → Type} {x y : A} {p : y = x} {u : P x} {v : P y} : - u = p ▸ v → p⁻¹ ▸ u = v := - by induction p; exact id - - definition eq_inv_tr_of_tr_eq {P : A → Type} {x y : A} {p : x = y} {u : P x} {v : P y} : - p ▸ u = v → u = p⁻¹ ▸ v := - by induction p; exact id - - definition eq_tr_of_inv_tr_eq {P : A → Type} {x y : A} {p : y = x} {u : P x} {v : P y} : - p⁻¹ ▸ u = v → u = p ▸ v := - by induction p; exact id - - /- Functoriality of functions -/ - - -- Here we prove that functions behave like functors between groupoids, and that [ap] itself is - -- functorial. - - -- Functions take identity paths to identity paths - definition ap_idp [unfold_full] (x : A) (f : A → B) : ap f idp = idp :> (f x = f x) := idp - - -- Functions commute with concatenation. - definition ap_con [unfold 8] (f : A → B) {x y z : A} (p : x = y) (q : y = z) : - ap f (p ⬝ q) = ap f p ⬝ ap f q := - by induction q; reflexivity - - definition con_ap_con_eq_con_ap_con_ap (f : A → B) {w x y z : A} (r : f w = f x) - (p : x = y) (q : y = z) : r ⬝ ap f (p ⬝ q) = (r ⬝ ap f p) ⬝ ap f q := - by induction q; induction p; reflexivity - - definition ap_con_con_eq_ap_con_ap_con (f : A → B) {w x y z : A} (p : x = y) (q : y = z) - (r : f z = f w) : ap f (p ⬝ q) ⬝ r = ap f p ⬝ (ap f q ⬝ r) := - by induction q; induction p; apply con.assoc - - -- Functions commute with path inverses. - definition ap_inv' [unfold 6] (f : A → B) {x y : A} (p : x = y) : (ap f p)⁻¹ = ap f p⁻¹ := - by induction p; reflexivity - - definition ap_inv [unfold 6] (f : A → B) {x y : A} (p : x = y) : ap f p⁻¹ = (ap f p)⁻¹ := - by induction p; reflexivity - - -- [ap] itself is functorial in the first argument. - - definition ap_id [unfold 4] (p : x = y) : ap id p = p := - by induction p; reflexivity - - definition ap_compose [unfold 8] (g : B → C) (f : A → B) {x y : A} (p : x = y) : - ap (g ∘ f) p = ap g (ap f p) := - by induction p; reflexivity - - -- Sometimes we don't have the actual function [compose]. - definition ap_compose' [unfold 8] (g : B → C) (f : A → B) {x y : A} (p : x = y) : - ap (λa, g (f a)) p = ap g (ap f p) := - by induction p; reflexivity - - -- The action of constant maps. - definition ap_constant [unfold 5] (p : x = y) (z : B) : ap (λu, z) p = idp := - by induction p; reflexivity - - -- Naturality of [ap]. - -- see also natural_square in cubical.square - definition ap_con_eq_con_ap {f g : A → B} (p : f ~ g) {x y : A} (q : x = y) : - ap f q ⬝ p y = p x ⬝ ap g q := - by induction q; apply idp_con - - -- Naturality of [ap] at identity. - definition ap_con_eq_con {f : A → A} (p : Πx, f x = x) {x y : A} (q : x = y) : - ap f q ⬝ p y = p x ⬝ q := - by induction q; apply idp_con - - definition con_ap_eq_con {f : A → A} (p : Πx, x = f x) {x y : A} (q : x = y) : - p x ⬝ ap f q = q ⬝ p y := - by induction q; exact !idp_con⁻¹ - - -- Naturality of [ap] with constant function - definition ap_con_eq {f : A → B} {b : B} (p : Πx, f x = b) {x y : A} (q : x = y) : - ap f q ⬝ p y = p x := - by induction q; apply idp_con - - -- Naturality with other paths hanging around. - - definition con_ap_con_con_eq_con_con_ap_con {f g : A → B} (p : f ~ g) {x y : A} (q : x = y) - {w z : B} (r : w = f x) (s : g y = z) : - (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (ap g q ⬝ s) := - by induction s; induction q; reflexivity - - definition con_ap_con_eq_con_con_ap {f g : A → B} (p : f ~ g) {x y : A} (q : x = y) - {w : B} (r : w = f x) : - (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ ap g q := - by induction q; reflexivity - - -- TODO: try this using the simplifier, and compare proofs - definition ap_con_con_eq_con_ap_con {f g : A → B} (p : f ~ g) {x y : A} (q : x = y) - {z : B} (s : g y = z) : - ap f q ⬝ (p y ⬝ s) = p x ⬝ (ap g q ⬝ s) := - begin - induction s, - induction q, - apply idp_con - end - - definition con_ap_con_con_eq_con_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y) - {w z : A} (r : w = f x) (s : y = z) : - (r ⬝ ap f q) ⬝ (p y ⬝ s) = (r ⬝ p x) ⬝ (q ⬝ s) := - by induction s; induction q; reflexivity - - definition con_con_ap_con_eq_con_con_con {g : A → A} (p : id ~ g) {x y : A} (q : x = y) - {w z : A} (r : w = x) (s : g y = z) : - (r ⬝ p x) ⬝ (ap g q ⬝ s) = (r ⬝ q) ⬝ (p y ⬝ s) := - by induction s; induction q; reflexivity - - definition con_ap_con_eq_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y) - {w : A} (r : w = f x) : - (r ⬝ ap f q) ⬝ p y = (r ⬝ p x) ⬝ q := - by induction q; reflexivity - - definition ap_con_con_eq_con_con {f : A → A} (p : f ~ id) {x y : A} (q : x = y) - {z : A} (s : y = z) : - ap f q ⬝ (p y ⬝ s) = p x ⬝ (q ⬝ s) := - by induction s; induction q; apply idp_con - - definition con_con_ap_eq_con_con {g : A → A} (p : id ~ g) {x y : A} (q : x = y) - {w : A} (r : w = x) : - (r ⬝ p x) ⬝ ap g q = (r ⬝ q) ⬝ p y := - begin cases q, exact idp end - - definition con_ap_con_eq_con_con' {g : A → A} (p : id ~ g) {x y : A} (q : x = y) - {z : A} (s : g y = z) : - p x ⬝ (ap g q ⬝ s) = q ⬝ (p y ⬝ s) := - by induction s; induction q; exact !idp_con⁻¹ - - /- Action of [apd10] and [ap10] on paths -/ - - -- Application of paths between functions preserves the groupoid structure - - definition apd10_idp (f : Πx, P x) (x : A) : apd10 (refl f) x = idp := idp - - definition apd10_con {f f' f'' : Πx, P x} (h : f = f') (h' : f' = f'') (x : A) : - apd10 (h ⬝ h') x = apd10 h x ⬝ apd10 h' x := - by induction h; induction h'; reflexivity - - definition apd10_inv {f g : Πx : A, P x} (h : f = g) (x : A) : - apd10 h⁻¹ x = (apd10 h x)⁻¹ := - by induction h; reflexivity - - definition ap10_idp {f : A → B} (x : A) : ap10 (refl f) x = idp := idp - - definition ap10_con {f f' f'' : A → B} (h : f = f') (h' : f' = f'') (x : A) : - ap10 (h ⬝ h') x = ap10 h x ⬝ ap10 h' x := apd10_con h h' x - - definition ap10_inv {f g : A → B} (h : f = g) (x : A) : ap10 h⁻¹ x = (ap10 h x)⁻¹ := - apd10_inv h x - - -- [ap10] also behaves nicely on paths produced by [ap] - definition ap_ap10 (f g : A → B) (h : B → C) (p : f = g) (a : A) : - ap h (ap10 p a) = ap10 (ap (λ f', h ∘ f') p) a:= - by induction p; reflexivity - - - /- Transport and the groupoid structure of paths -/ - - definition idp_tr {P : A → Type} {x : A} (u : P x) : idp ▸ u = u := idp - - definition con_tr [unfold 7] {P : A → Type} {x y z : A} (p : x = y) (q : y = z) (u : P x) : - p ⬝ q ▸ u = q ▸ p ▸ u := - by induction q; reflexivity - - definition tr_inv_tr {P : A → Type} {x y : A} (p : x = y) (z : P y) : - p ▸ p⁻¹ ▸ z = z := - (con_tr p⁻¹ p z)⁻¹ ⬝ ap (λr, transport P r z) (con.left_inv p) - - definition inv_tr_tr {P : A → Type} {x y : A} (p : x = y) (z : P x) : - p⁻¹ ▸ p ▸ z = z := - (con_tr p p⁻¹ z)⁻¹ ⬝ ap (λr, transport P r z) (con.right_inv p) - - definition con_tr_lemma {P : A → Type} - {x y z w : A} (p : x = y) (q : y = z) (r : z = w) (u : P x) : - ap (λe, e ▸ u) (con.assoc' p q r) ⬝ (con_tr (p ⬝ q) r u) ⬝ - ap (transport P r) (con_tr p q u) - = (con_tr p (q ⬝ r) u) ⬝ (con_tr q r (p ▸ u)) - :> ((p ⬝ (q ⬝ r)) ▸ u = r ▸ q ▸ p ▸ u) := - by induction r; induction q; induction p; reflexivity - - -- Here is another coherence lemma for transport. - definition tr_inv_tr_lemma {P : A → Type} {x y : A} (p : x = y) (z : P x) : - tr_inv_tr p (transport P p z) = ap (transport P p) (inv_tr_tr p z) := - by induction p; reflexivity - - /- some properties for apd -/ - - definition apd_idp (x : A) (f : Πx, P x) : apd f idp = idp :> (f x = f x) := idp - - definition apd_con (f : Πx, P x) {x y z : A} (p : x = y) (q : y = z) - : apd f (p ⬝ q) = con_tr p q (f x) ⬝ ap (transport P q) (apd f p) ⬝ apd f q := - by cases p; cases q; apply idp - - definition apd_inv (f : Πx, P x) {x y : A} (p : x = y) - : apd f p⁻¹ = (eq_inv_tr_of_tr_eq (apd f p))⁻¹ := - by cases p; apply idp - - - -- Dependent transport in a doubly dependent type. - definition transportD [unfold 6] {P : A → Type} (Q : Πa, P a → Type) - {a a' : A} (p : a = a') (b : P a) (z : Q a b) : Q a' (p ▸ b) := - by induction p; exact z - - -- In Coq the variables P, Q and b are explicit, but in Lean we can probably have them implicit - -- using the following notation - notation p ` ▸D `:65 x:64 := transportD _ p _ x - - -- Transporting along higher-dimensional paths - definition transport2 [unfold 7] (P : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : P x) : - p ▸ z = q ▸ z := - ap (λp', p' ▸ z) r - - notation p ` ▸2 `:65 x:64 := transport2 _ p _ x - - -- An alternative definition. - definition tr2_eq_ap10 (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : - transport2 Q r z = ap10 (ap (transport Q) r) z := - by induction r; reflexivity - - definition tr2_con {P : A → Type} {x y : A} {p1 p2 p3 : x = y} - (r1 : p1 = p2) (r2 : p2 = p3) (z : P x) : - transport2 P (r1 ⬝ r2) z = transport2 P r1 z ⬝ transport2 P r2 z := - by induction r1; induction r2; reflexivity - - definition tr2_inv (Q : A → Type) {x y : A} {p q : x = y} (r : p = q) (z : Q x) : - transport2 Q r⁻¹ z = (transport2 Q r z)⁻¹ := - by induction r; reflexivity - - definition transportD2 [unfold 7] {B C : A → Type} (D : Π(a:A), B a → C a → Type) - {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) : D x2 (p ▸ y) (p ▸ z) := - by induction p; exact w - - notation p ` ▸D2 `:65 x:64 := transportD2 _ p _ _ x - - definition ap_tr_con_tr2 (P : A → Type) {x y : A} {p q : x = y} {z w : P x} (r : p = q) - (s : z = w) : - ap (transport P p) s ⬝ transport2 P r w = transport2 P r z ⬝ ap (transport P q) s := - by induction r; exact !idp_con⁻¹ - - definition fn_tr_eq_tr_fn {P Q : A → Type} {x y : A} (p : x = y) (f : Πx, P x → Q x) (z : P x) : - f y (p ▸ z) = p ▸ f x z := - by induction p; reflexivity - - /- Transporting in particular fibrations -/ - - /- - From the Coq HoTT library: - - One frequently needs lemmas showing that transport in a certain dependent type is equal to some - more explicitly defined operation, defined according to the structure of that dependent type. - For most dependent types, we prove these lemmas in the appropriate file in the types/ - subdirectory. Here we consider only the most basic cases. - -/ - - -- Transporting in a constant fibration. - definition tr_constant (p : x = y) (z : B) : transport (λx, B) p z = z := - by induction p; reflexivity - - definition tr2_constant {p q : x = y} (r : p = q) (z : B) : - tr_constant p z = transport2 (λu, B) r z ⬝ tr_constant q z := - by induction r; exact !idp_con⁻¹ - - -- Transporting in a pulled back fibration. - definition tr_compose (P : B → Type) (f : A → B) (p : x = y) (z : P (f x)) : - transport (P ∘ f) p z = transport P (ap f p) z := - by induction p; reflexivity - - definition ap_precompose (f : A → B) (g g' : B → C) (p : g = g') : - ap (λh, h ∘ f) p = transport (λh : B → C, g ∘ f = h ∘ f) p idp := - by induction p; reflexivity - - definition apd10_ap_precompose (f : A → B) (g g' : B → C) (p : g = g') : - apd10 (ap (λh : B → C, h ∘ f) p) = λa, apd10 p (f a) := - by induction p; reflexivity - - definition apd10_ap_precompose_dependent {C : B → Type} - (f : A → B) {g g' : Πb : B, C b} (p : g = g') - : apd10 (ap (λ(h : (Πb : B, C b))(a : A), h (f a)) p) = λa, apd10 p (f a) := - by induction p; reflexivity - - definition apd10_ap_postcompose (f : B → C) (g g' : A → B) (p : g = g') : - apd10 (ap (λh : A → B, f ∘ h) p) = λa, ap f (apd10 p a) := - by induction p; reflexivity - - -- A special case of [tr_compose] which seems to come up a lot. - definition tr_eq_cast_ap {P : A → Type} {x y} (p : x = y) (u : P x) : p ▸ u = cast (ap P p) u := - by induction p; reflexivity - - definition tr_eq_cast_ap_fn {P : A → Type} {x y} (p : x = y) : transport P p = cast (ap P p) := - by induction p; reflexivity - - /- The behavior of [ap] and [apd] -/ - - -- In a constant fibration, [apd] reduces to [ap], modulo [transport_const]. - definition apd_eq_tr_constant_con_ap (f : A → B) (p : x = y) : - apd f p = tr_constant p (f x) ⬝ ap f p := - by induction p; reflexivity - - - /- The 2-dimensional groupoid structure -/ - - -- Horizontal composition of 2-dimensional paths. - definition concat2 [unfold 9 10] {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q') - : p ⬝ q = p' ⬝ q' := - ap011 concat h h' - - -- 2-dimensional path inversion - definition inverse2 [unfold 6] {p q : x = y} (h : p = q) : p⁻¹ = q⁻¹ := - ap inverse h - - infixl ` ◾ `:75 := concat2 - postfix [parsing_only] `⁻²`:(max+10) := inverse2 --this notation is abusive, should we use it? - - /- Whiskering -/ - - definition whisker_left [unfold 8] (p : x = y) {q r : y = z} (h : q = r) : p ⬝ q = p ⬝ r := - idp ◾ h - - definition whisker_right [unfold 7] {p q : x = y} (h : p = q) (r : y = z) : p ⬝ r = q ⬝ r := - h ◾ idp - - -- Unwhiskering, a.k.a. cancelling - - definition cancel_left {x y z : A} (p : x = y) {q r : y = z} : (p ⬝ q = p ⬝ r) → (q = r) := - λs, !inv_con_cancel_left⁻¹ ⬝ whisker_left p⁻¹ s ⬝ !inv_con_cancel_left - - definition cancel_right {x y z : A} {p q : x = y} (r : y = z) : (p ⬝ r = q ⬝ r) → (p = q) := - λs, !con_inv_cancel_right⁻¹ ⬝ whisker_right s r⁻¹ ⬝ !con_inv_cancel_right - - -- Whiskering and identity paths. - - definition whisker_right_idp {p q : x = y} (h : p = q) : - whisker_right h idp = h := - by induction h; induction p; reflexivity - - definition whisker_right_idp_left [unfold_full] (p : x = y) (q : y = z) : - whisker_right idp q = idp :> (p ⬝ q = p ⬝ q) := - idp - - definition whisker_left_idp_right [unfold_full] (p : x = y) (q : y = z) : - whisker_left p idp = idp :> (p ⬝ q = p ⬝ q) := - idp - - definition whisker_left_idp {p q : x = y} (h : p = q) : - (idp_con p)⁻¹ ⬝ whisker_left idp h ⬝ idp_con q = h := - by induction h; induction p; reflexivity - - definition whisker_left_idp2 {A : Type} {a : A} (p : idp = idp :> a = a) : - whisker_left idp p = p := - begin - refine _ ⬝ whisker_left_idp p, - exact !idp_con⁻¹ - end - - definition con2_idp [unfold_full] {p q : x = y} (h : p = q) : - h ◾ idp = whisker_right h idp :> (p ⬝ idp = q ⬝ idp) := - idp - - definition idp_con2 [unfold_full] {p q : x = y} (h : p = q) : - idp ◾ h = whisker_left idp h :> (idp ⬝ p = idp ⬝ q) := - idp - - definition inverse2_concat2 {p p' : x = y} (h : p = p') - : h⁻² ◾ h = con.left_inv p ⬝ (con.left_inv p')⁻¹ := - by induction h; induction p; reflexivity - - -- The interchange law for concatenation. - definition con2_con_con2 {p p' p'' : x = y} {q q' q'' : y = z} - (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') : - (a ◾ c) ⬝ (b ◾ d) = (a ⬝ b) ◾ (c ⬝ d) := - by induction d; induction c; induction b;induction a; reflexivity - - definition concat2_eq_rl {A : Type} {x y z : A} {p p' : x = y} {q q' : y = z} - (a : p = p') (b : q = q') : a ◾ b = whisker_right a q ⬝ whisker_left p' b := - by induction b; induction a; reflexivity - - definition concat2_eq_lf {A : Type} {x y z : A} {p p' : x = y} {q q' : y = z} - (a : p = p') (b : q = q') : a ◾ b = whisker_left p b ⬝ whisker_right a q' := - by induction b; induction a; reflexivity - - definition whisker_right_con_whisker_left {x y z : A} {p p' : x = y} {q q' : y = z} - (a : p = p') (b : q = q') : - (whisker_right a q) ⬝ (whisker_left p' b) = (whisker_left p b) ⬝ (whisker_right a q') := - by induction b; induction a; reflexivity - - -- Structure corresponding to the coherence equations of a bicategory. - - -- The "pentagonator": the 3-cell witnessing the associativity pentagon. - definition pentagon {v w x y z : A} (p : v = w) (q : w = x) (r : x = y) (s : y = z) : - whisker_left p (con.assoc' q r s) - ⬝ con.assoc' p (q ⬝ r) s - ⬝ whisker_right (con.assoc' p q r) s - = con.assoc' p q (r ⬝ s) ⬝ con.assoc' (p ⬝ q) r s := - by induction s;induction r;induction q;induction p;reflexivity - - -- The 3-cell witnessing the left unit triangle. - definition triangulator (p : x = y) (q : y = z) : - con.assoc' p idp q ⬝ whisker_right (con_idp p) q = whisker_left p (idp_con q) := - by induction q; induction p; reflexivity - - definition eckmann_hilton {x:A} (p q : idp = idp :> x = x) : p ⬝ q = q ⬝ p := - begin - refine (whisker_right_idp p ◾ whisker_left_idp2 q)⁻¹ ⬝ _, - refine !whisker_right_con_whisker_left ⬝ _, - refine !whisker_left_idp2 ◾ !whisker_right_idp - end - - definition concat_eq_concat2 {A : Type} {a : A} (p q : idp = idp :> a = a) : p ⬝ q = p ◾ q := - begin - refine (whisker_right_idp p ◾ whisker_left_idp2 q)⁻¹ ⬝ _, - exact !concat2_eq_rl⁻¹ - end - - definition inverse_eq_inverse2 {A : Type} {a : A} (p : idp = idp :> a = a) : p⁻¹ = p⁻² := - begin - apply eq.cancel_right p, - refine !con.left_inv ⬝ _, - refine _ ⬝ !concat_eq_concat2⁻¹, - exact !inverse2_concat2⁻¹, - end - - -- The action of functions on 2-dimensional paths - definition ap02 [unfold 8] [reducible] (f : A → B) {x y : A} {p q : x = y} (r : p = q) - : ap f p = ap f q := - ap (ap f) r - - definition ap02_con (f : A → B) {x y : A} {p p' p'' : x = y} (r : p = p') (r' : p' = p'') : - ap02 f (r ⬝ r') = ap02 f r ⬝ ap02 f r' := - by induction r; induction r'; reflexivity - - definition ap02_con2 (f : A → B) {x y z : A} {p p' : x = y} {q q' :y = z} (r : p = p') - (s : q = q') : - ap02 f (r ◾ s) = ap_con f p q - ⬝ (ap02 f r ◾ ap02 f s) - ⬝ (ap_con f p' q')⁻¹ := - by induction r; induction s; induction q; induction p; reflexivity - - definition apd02 [unfold 8] {p q : x = y} (f : Π x, P x) (r : p = q) : - apd f p = transport2 P r (f x) ⬝ apd f q := - by induction r; exact !idp_con⁻¹ - - -- And now for a lemma whose statement is much longer than its proof. - definition apd02_con {P : A → Type} (f : Π x:A, P x) {x y : A} - {p1 p2 p3 : x = y} (r1 : p1 = p2) (r2 : p2 = p3) : - apd02 f (r1 ⬝ r2) = apd02 f r1 - ⬝ whisker_left (transport2 P r1 (f x)) (apd02 f r2) - ⬝ con.assoc' _ _ _ - ⬝ (whisker_right (tr2_con r1 r2 (f x))⁻¹ (apd f p3)) := - by induction r2; induction r1; induction p1; reflexivity - -end eq diff --git a/hott/init/pathover.hlean b/hott/init/pathover.hlean deleted file mode 100644 index 3eeb044323..0000000000 --- a/hott/init/pathover.hlean +++ /dev/null @@ -1,327 +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 - -Basic theorems about pathovers --/ - -prelude -import .path .equiv - -open equiv is_equiv function - -variables {A A' : Type} {B B' : A → Type} {B'' : A' → Type} {C : Π⦃a⦄, B a → Type} - {a a₂ a₃ a₄ : A} {p p' : a = a₂} {p₂ : a₂ = a₃} {p₃ : a₃ = a₄} {p₁₃ : a = a₃} - {b b' : B a} {b₂ b₂' : B a₂} {b₃ : B a₃} {b₄ : B a₄} - {c : C b} {c₂ : C b₂} - -namespace eq - inductive pathover.{l} (B : A → Type.{l}) (b : B a) : Π{a₂ : A}, a = a₂ → B a₂ → Type.{l} := - idpatho : pathover B b (refl a) b - - notation b ` =[`:50 p:0 `] `:0 b₂:50 := pathover _ b p b₂ - - definition idpo [reducible] [constructor] : b =[refl a] b := - pathover.idpatho b - - /- equivalences with equality using transport -/ - definition pathover_of_tr_eq [unfold 5 8] (r : p ▸ b = b₂) : b =[p] b₂ := - by cases p; cases r; constructor - - definition pathover_of_eq_tr [unfold 5 8] (r : b = p⁻¹ ▸ b₂) : b =[p] b₂ := - by cases p; cases r; constructor - - definition tr_eq_of_pathover [unfold 8] (r : b =[p] b₂) : p ▸ b = b₂ := - by cases r; reflexivity - - definition eq_tr_of_pathover [unfold 8] (r : b =[p] b₂) : b = p⁻¹ ▸ b₂ := - by cases r; reflexivity - - definition pathover_equiv_tr_eq [constructor] (p : a = a₂) (b : B a) (b₂ : B a₂) - : (b =[p] b₂) ≃ (p ▸ b = b₂) := - begin - fapply equiv.MK, - { exact tr_eq_of_pathover}, - { exact pathover_of_tr_eq}, - { intro r, cases p, cases r, apply idp}, - { intro r, cases r, apply idp}, - end - - definition pathover_equiv_eq_tr [constructor] (p : a = a₂) (b : B a) (b₂ : B a₂) - : (b =[p] b₂) ≃ (b = p⁻¹ ▸ b₂) := - begin - fapply equiv.MK, - { exact eq_tr_of_pathover}, - { exact pathover_of_eq_tr}, - { intro r, cases p, cases r, apply idp}, - { intro r, cases r, apply idp}, - end - - definition pathover_tr [unfold 5] (p : a = a₂) (b : B a) : b =[p] p ▸ b := - by cases p;constructor - - definition tr_pathover [unfold 5] (p : a = a₂) (b : B a₂) : p⁻¹ ▸ b =[p] b := - by cases p;constructor - - definition concato [unfold 12] (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃) : b =[p ⬝ p₂] b₃ := - pathover.rec_on r₂ r - - definition inverseo [unfold 8] (r : b =[p] b₂) : b₂ =[p⁻¹] b := - pathover.rec_on r idpo - - definition apdo [unfold 6] (f : Πa, B a) (p : a = a₂) : f a =[p] f a₂ := - eq.rec_on p idpo - - definition concato_eq [unfold 10] (r : b =[p] b₂) (q : b₂ = b₂') : b =[p] b₂' := - eq.rec_on q r - - definition eq_concato [unfold 9] (q : b = b') (r : b' =[p] b₂) : b =[p] b₂ := - by induction q;exact r - - definition change_path [unfold 9] (q : p = p') (r : b =[p] b₂) : b =[p'] b₂ := - q ▸ r - - -- infix ` ⬝ ` := concato - infix ` ⬝o `:72 := concato - infix ` ⬝op `:73 := concato_eq - infix ` ⬝po `:73 := eq_concato - -- postfix `⁻¹` := inverseo - postfix `⁻¹ᵒ`:(max+10) := inverseo - - definition pathover_cancel_right (q : b =[p ⬝ p₂] b₃) (r : b₃ =[p₂⁻¹] b₂) : b =[p] b₂ := - change_path !con_inv_cancel_right (q ⬝o r) - - definition pathover_cancel_right' (q : b =[p₁₃ ⬝ p₂⁻¹] b₂) (r : b₂ =[p₂] b₃) : b =[p₁₃] b₃ := - change_path !inv_con_cancel_right (q ⬝o r) - - definition pathover_cancel_left (q : b₂ =[p⁻¹] b) (r : b =[p ⬝ p₂] b₃) : b₂ =[p₂] b₃ := - change_path !inv_con_cancel_left (q ⬝o r) - - definition pathover_cancel_left' (q : b =[p] b₂) (r : b₂ =[p⁻¹ ⬝ p₁₃] b₃) : b =[p₁₃] b₃ := - change_path !con_inv_cancel_left (q ⬝o r) - - /- Some of the theorems analogous to theorems for = in init.path -/ - - definition cono_idpo (r : b =[p] b₂) : r ⬝o idpo =[con_idp p] r := - pathover.rec_on r idpo - - definition idpo_cono (r : b =[p] b₂) : idpo ⬝o r =[idp_con p] r := - pathover.rec_on r idpo - - definition cono.assoc' (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃) (r₃ : b₃ =[p₃] b₄) : - r ⬝o (r₂ ⬝o r₃) =[!con.assoc'] (r ⬝o r₂) ⬝o r₃ := - pathover.rec_on r₃ (pathover.rec_on r₂ (pathover.rec_on r idpo)) - - definition cono.assoc (r : b =[p] b₂) (r₂ : b₂ =[p₂] b₃) (r₃ : b₃ =[p₃] b₄) : - (r ⬝o r₂) ⬝o r₃ =[!con.assoc] r ⬝o (r₂ ⬝o r₃) := - pathover.rec_on r₃ (pathover.rec_on r₂ (pathover.rec_on r idpo)) - - definition cono.right_inv (r : b =[p] b₂) : r ⬝o r⁻¹ᵒ =[!con.right_inv] idpo := - pathover.rec_on r idpo - - definition cono.left_inv (r : b =[p] b₂) : r⁻¹ᵒ ⬝o r =[!con.left_inv] idpo := - pathover.rec_on r idpo - - definition eq_of_pathover {a' a₂' : A'} (q : a' =[p] a₂') : a' = a₂' := - by cases q;reflexivity - - definition pathover_of_eq [unfold 5 8] {a' a₂' : A'} (q : a' = a₂') : a' =[p] a₂' := - by cases p;cases q;constructor - - definition pathover_constant [constructor] (p : a = a₂) (a' a₂' : A') : a' =[p] a₂' ≃ a' = a₂' := - begin - fapply equiv.MK, - { exact eq_of_pathover}, - { exact pathover_of_eq}, - { intro r, cases p, cases r, reflexivity}, - { intro r, cases r, reflexivity}, - end - - definition eq_of_pathover_idp [unfold 6] {b' : B a} (q : b =[idpath a] b') : b = b' := - tr_eq_of_pathover q - - --should B be explicit in the next two definitions? - definition pathover_idp_of_eq [unfold 6] {b' : B a} (q : b = b') : b =[idpath a] b' := - pathover_of_tr_eq q - - definition pathover_idp [constructor] (b : B a) (b' : B a) : b =[idpath a] b' ≃ b = b' := - equiv.MK eq_of_pathover_idp - (pathover_idp_of_eq) - (to_right_inv !pathover_equiv_tr_eq) - (to_left_inv !pathover_equiv_tr_eq) - - - -- definition pathover_idp (b : B a) (b' : B a) : b =[idpath a] b' ≃ b = b' := - -- pathover_equiv_tr_eq idp b b' - - -- definition eq_of_pathover_idp [reducible] {b' : B a} (q : b =[idpath a] b') : b = b' := - -- to_fun !pathover_idp q - - -- definition pathover_idp_of_eq [reducible] {b' : B a} (q : b = b') : b =[idpath a] b' := - -- to_inv !pathover_idp q - - definition idp_rec_on [recursor] {P : Π⦃b₂ : B a⦄, b =[idpath a] b₂ → Type} - {b₂ : B a} (r : b =[idpath a] b₂) (H : P idpo) : P r := - have H2 : P (pathover_idp_of_eq (eq_of_pathover_idp r)), from - eq.rec_on (eq_of_pathover_idp r) H, - proof left_inv !pathover_idp r ▸ H2 qed - - definition rec_on_right [recursor] {P : Π⦃b₂ : B a₂⦄, b =[p] b₂ → Type} - {b₂ : B a₂} (r : b =[p] b₂) (H : P !pathover_tr) : P r := - by cases r; exact H - - definition rec_on_left [recursor] {P : Π⦃b : B a⦄, b =[p] b₂ → Type} - {b : B a} (r : b =[p] b₂) (H : P !tr_pathover) : P r := - by cases r; exact H - - --pathover with fibration B' ∘ f - definition pathover_ap [unfold 10] (B' : A' → Type) (f : A → A') {p : a = a₂} - {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[p] b₂) : b =[ap f p] b₂ := - by cases q; constructor - - definition pathover_of_pathover_ap (B' : A' → Type) (f : A → A') {p : a = a₂} - {b : B' (f a)} {b₂ : B' (f a₂)} (q : b =[ap f p] b₂) : b =[p] b₂ := - by cases p; apply (idp_rec_on q); apply idpo - - definition pathover_compose [constructor] (B' : A' → Type) (f : A → A') (p : a = a₂) - (b : B' (f a)) (b₂ : B' (f a₂)) : b =[p] b₂ ≃ b =[ap f p] b₂ := - begin - fapply equiv.MK, - { exact pathover_ap B' f}, - { exact pathover_of_pathover_ap B' f}, - { intro q, cases p, esimp, apply (idp_rec_on q), apply idp}, - { intro q, cases q, reflexivity}, - end - - definition apdo_con (f : Πa, B a) (p : a = a₂) (q : a₂ = a₃) - : apdo f (p ⬝ q) = apdo f p ⬝o apdo f q := - by cases p; cases q; reflexivity - - definition apdo_inv (f : Πa, B a) (p : a = a₂) : apdo f p⁻¹ = (apdo f p)⁻¹ᵒ := - by cases p; reflexivity - - definition apdo_eq_pathover_of_eq_ap (f : A → A') (p : a = a₂) : - apdo f p = pathover_of_eq (ap f p) := - eq.rec_on p idp - - definition pathover_of_pathover_tr (q : b =[p ⬝ p₂] p₂ ▸ b₂) : b =[p] b₂ := - pathover_cancel_right q !pathover_tr⁻¹ᵒ - - definition pathover_tr_of_pathover (q : b =[p₁₃ ⬝ p₂⁻¹] b₂) : b =[p₁₃] p₂ ▸ b₂ := - pathover_cancel_right' q !pathover_tr - - definition pathover_of_tr_pathover (q : p ▸ b =[p⁻¹ ⬝ p₁₃] b₃) : b =[p₁₃] b₃ := - pathover_cancel_left' !pathover_tr q - - definition tr_pathover_of_pathover (q : b =[p ⬝ p₂] b₃) : p ▸ b =[p₂] b₃ := - pathover_cancel_left !pathover_tr⁻¹ᵒ q - - definition pathover_tr_of_eq (q : b = b') : b =[p] p ▸ b' := - by cases q;apply pathover_tr - - definition tr_pathover_of_eq (q : b₂ = b₂') : p⁻¹ ▸ b₂ =[p] b₂' := - by cases q;apply tr_pathover - - variable (C) - definition transporto (r : b =[p] b₂) (c : C b) : C b₂ := - by induction r;exact c - infix ` ▸o `:75 := transporto _ - - definition fn_tro_eq_tro_fn (C' : Π ⦃a : A⦄, B a → Type) (q : b =[p] b₂) - (f : Π(b : B a), C b → C' b) (c : C b) : f b (q ▸o c) = (q ▸o (f b c)) := - by induction q;reflexivity - variable {C} - - definition apo {f : A → A'} (g : Πa, B a → B'' (f a)) - (q : b =[p] b₂) : g a b =[p] g a₂ b₂ := - by induction q; constructor - - definition apo011 [unfold 10] (f : Πa, B a → A') (Ha : a = a₂) (Hb : b =[Ha] b₂) - : f a b = f a₂ b₂ := - by cases Hb; reflexivity - - definition apo0111 (f : Πa b, C b → A') (Ha : a = a₂) (Hb : b =[Ha] b₂) - (Hc : c =[apo011 C Ha Hb] c₂) : f a b c = f a₂ b₂ c₂ := - by cases Hb; apply (idp_rec_on Hc); apply idp - - definition apod11 {f : Πb, C b} {g : Πb₂, C b₂} (r : f =[p] g) - {b : B a} {b₂ : B a₂} (q : b =[p] b₂) : f b =[apo011 C p q] g b₂ := - by cases r; apply (idp_rec_on q); constructor - - definition apdo10 {f : Πb, C b} {g : Πb₂, C b₂} (r : f =[p] g) - (b : B a) : f b =[apo011 C p !pathover_tr] g (p ▸ b) := - by cases r; constructor - - definition apo10 [unfold 9] {f : B a → B' a} {g : B a₂ → B' a₂} (r : f =[p] g) - (b : B a) : f b =[p] g (p ▸ b) := - by cases r; constructor - - definition apo10_constant_right [unfold 9] {f : B a → A'} {g : B a₂ → A'} (r : f =[p] g) - (b : B a) : f b = g (p ▸ b) := - by cases r; constructor - - definition apo10_constant_left [unfold 9] {f : A' → B a} {g : A' → B a₂} (r : f =[p] g) - (a' : A') : f a' =[p] g a' := - by cases r; constructor - - definition apo11 {f : B a → B' a} {g : B a₂ → B' a₂} (r : f =[p] g) - (q : b =[p] b₂) : f b =[p] g b₂ := - by induction q; exact apo10 r b - - definition apdo_compose1 (g : Πa, B a → B' a) (f : Πa, B a) (p : a = a₂) - : apdo (g ∘' f) p = apo g (apdo f p) := - by induction p; reflexivity - - definition apdo_compose2 (g : Πa', B'' a') (f : A → A') (p : a = a₂) - : apdo (λa, g (f a)) p = pathover_of_pathover_ap B'' f (apdo g (ap f p)) := - by induction p; reflexivity - - definition cono.right_inv_eq (q : b = b') - : concato_eq (pathover_idp_of_eq q) q⁻¹ = (idpo : b =[refl a] b) := - by induction q;constructor - - definition cono.right_inv_eq' (q : b = b') - : eq_concato q (pathover_idp_of_eq q⁻¹) = (idpo : b =[refl a] b) := - by induction q;constructor - - definition cono.left_inv_eq (q : b = b') - : concato_eq (pathover_idp_of_eq q⁻¹) q = (idpo : b' =[refl a] b') := - by induction q;constructor - - definition cono.left_inv_eq' (q : b = b') - : eq_concato q⁻¹ (pathover_idp_of_eq q) = (idpo : b' =[refl a] b') := - by induction q;constructor - - definition pathover_of_fn_pathover_fn (f : Π{a}, B a ≃ B' a) (r : f b =[p] f b₂) : b =[p] b₂ := - (left_inv f b)⁻¹ ⬝po apo (λa, f⁻¹ᵉ) r ⬝op left_inv f b₂ - - definition change_path_of_pathover (s : p = p') (r : b =[p] b₂) (r' : b =[p'] b₂) - (q : r =[s] r') : change_path s r = r' := - by induction s; eapply idp_rec_on q; reflexivity - - definition pathover_of_change_path (s : p = p') (r : b =[p] b₂) (r' : b =[p'] b₂) - (q : change_path s r = r') : r =[s] r' := - by induction s; induction q; constructor - - definition pathover_pathover_path [constructor] (s : p = p') (r : b =[p] b₂) (r' : b =[p'] b₂) : - (r =[s] r') ≃ change_path s r = r' := - begin - fapply equiv.MK, - { apply change_path_of_pathover}, - { apply pathover_of_change_path}, - { intro q, induction s, induction q, reflexivity}, - { intro q, induction s, eapply idp_rec_on q, reflexivity}, - end - - definition inverseo2 [unfold 10] {r r' : b =[p] b₂} (s : r = r') : r⁻¹ᵒ = r'⁻¹ᵒ := - by induction s; reflexivity - - definition concato2 [unfold 15 16] {r r' : b =[p] b₂} {r₂ r₂' : b₂ =[p₂] b₃} - (s : r = r') (s₂ : r₂ = r₂') : r ⬝o r₂ = r' ⬝o r₂' := - by induction s; induction s₂; reflexivity - - infixl ` ◾o `:75 := concato2 - postfix [parsing_only] `⁻²ᵒ`:(max+10) := inverseo2 --this notation is abusive, should we use it? - -end eq diff --git a/hott/init/relation.hlean b/hott/init/relation.hlean deleted file mode 100644 index 4cdeee4dfd..0000000000 --- a/hott/init/relation.hlean +++ /dev/null @@ -1,41 +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 --/ - -prelude -import init.logic - --- TODO(Leo): remove duplication between this file and algebra/relation.lean --- We need some of the following definitions asap when "initializing" Lean. - -variables {A B : Type} (R : B → B → Type) -local infix `≺`:50 := R - -definition reflexive := ∀x, x ≺ x - -definition symmetric := ∀⦃x y⦄, x ≺ y → y ≺ x - -definition transitive := ∀⦃x y z⦄, x ≺ y → y ≺ z → x ≺ z - -definition irreflexive := ∀x, ¬ x ≺ x - -definition anti_symmetric := ∀⦃x y⦄, x ≺ y → y ≺ x → x = y - -definition empty_relation := λa₁ a₂ : A, empty - -definition subrelation (Q R : B → B → Type) := ∀⦃x y⦄, Q x y → R x y - -definition inv_image (f : A → B) : A → A → Type := -λa₁ a₂, f a₁ ≺ f a₂ - -definition inv_image.trans (f : A → B) (H : transitive R) : transitive (inv_image R f) := -λ (a₁ a₂ a₃ : A) (H₁ : inv_image R f a₁ a₂) (H₂ : inv_image R f a₂ a₃), H H₁ H₂ - -definition inv_image.irreflexive (f : A → B) (H : irreflexive R) : irreflexive (inv_image R f) := -λ (a : A) (H₁ : inv_image R f a a), H (f a) H₁ - -inductive tc {A : Type} (R : A → A → Type) : A → A → Type := -| base : ∀a b, R a b → tc R a b -| trans : ∀a b c, tc R a b → tc R b c → tc R a c diff --git a/hott/init/reserved_notation.hlean b/hott/init/reserved_notation.hlean deleted file mode 100644 index 14f79ca397..0000000000 --- a/hott/init/reserved_notation.hlean +++ /dev/null @@ -1,231 +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, Floris van Doorn --/ -prelude -import init.datatypes - -notation `assume` binders `,` r:(scoped f, f) := r -notation `take` binders `,` r:(scoped f, f) := r - -structure has_zero [class] (A : Type) := (zero : A) -structure has_one [class] (A : Type) := (one : A) -structure has_add [class] (A : Type) := (add : A → A → A) -structure has_mul [class] (A : Type) := (mul : A → A → A) -structure has_inv [class] (A : Type) := (inv : A → A) -structure has_neg [class] (A : Type) := (neg : A → A) -structure has_sub [class] (A : Type) := (sub : A → A → A) -structure has_div [class] (A : Type) := (div : A → A → A) -structure has_mod [class] (A : Type) := (mod : A → A → A) -structure has_dvd.{l} [class] (A : Type.{l}) : Type.{l+1} := (dvd : A → A → Type.{l}) -structure has_le.{l} [class] (A : Type.{l}) : Type.{l+1} := (le : A → A → Type.{l}) -structure has_lt.{l} [class] (A : Type.{l}) : Type.{l+1} := (lt : A → A → Type.{l}) - -definition zero [reducible] {A : Type} [s : has_zero A] : A := has_zero.zero A -definition one [reducible] {A : Type} [s : has_one A] : A := has_one.one A -definition add [reducible] {A : Type} [s : has_add A] : A → A → A := has_add.add -definition mul {A : Type} [s : has_mul A] : A → A → A := has_mul.mul -definition sub {A : Type} [s : has_sub A] : A → A → A := has_sub.sub -definition div {A : Type} [s : has_div A] : A → A → A := has_div.div -definition dvd {A : Type} [s : has_dvd A] : A → A → Type := has_dvd.dvd -definition mod {A : Type} [s : has_mod A] : A → A → A := has_mod.mod -definition neg {A : Type} [s : has_neg A] : A → A := has_neg.neg -definition inv {A : Type} [s : has_inv A] : A → A := has_inv.inv -definition le {A : Type} [s : has_le A] : A → A → Type := has_le.le -definition lt {A : Type} [s : has_lt A] : A → A → Type := has_lt.lt - -definition ge [reducible] {A : Type} [s : has_le A] (a b : A) : Type := le b a -definition gt [reducible] {A : Type} [s : has_lt A] (a b : A) : Type := lt b a -definition bit0 [reducible] {A : Type} [s : has_add A] (a : A) : A := add a a -definition bit1 [reducible] {A : Type} [s₁ : has_one A] [s₂ : has_add A] (a : A) : A := -add (bit0 a) one - -definition num_has_zero [instance] : has_zero num := -has_zero.mk num.zero - -definition num_has_one [instance] : has_one num := -has_one.mk (num.pos pos_num.one) - -definition pos_num_has_one [instance] : has_one pos_num := -has_one.mk (pos_num.one) - -namespace pos_num - open bool - definition is_one (a : pos_num) : bool := - pos_num.rec_on a tt (λn r, ff) (λn r, ff) - - definition pred (a : pos_num) : pos_num := - pos_num.rec_on a one (λn r, bit0 n) (λn r, bool.rec_on (is_one n) (bit1 r) one) - - definition size (a : pos_num) : pos_num := - pos_num.rec_on a one (λn r, succ r) (λn r, succ r) - - definition add (a b : pos_num) : pos_num := - pos_num.rec_on a - succ - (λn f b, pos_num.rec_on b - (succ (bit1 n)) - (λm r, succ (bit1 (f m))) - (λm r, bit1 (f m))) - (λn f b, pos_num.rec_on b - (bit1 n) - (λm r, bit1 (f m)) - (λm r, bit0 (f m))) - b -end pos_num - -definition pos_num_has_add [instance] : has_add pos_num := -has_add.mk pos_num.add - -namespace num - open pos_num - - definition add (a b : num) : num := - num.rec_on a b (λpa, num.rec_on b (pos pa) (λpb, pos (pos_num.add pa pb))) -end num - -definition num_has_add [instance] : has_add num := -has_add.mk num.add - -definition std.priority.default : num := 1000 -definition std.priority.max : num := 4294967295 - -namespace nat - protected definition prio := num.add std.priority.default 100 - - protected definition add (a b : nat) : nat := - nat.rec a (λ b₁ r, succ r) b - - definition of_num (n : num) : nat := - num.rec zero - (λ n, pos_num.rec (succ zero) (λ n r, nat.add (nat.add r r) (succ zero)) (λ n r, nat.add r r) n) n -end nat - -attribute pos_num_has_add pos_num_has_one num_has_zero num_has_one num_has_add - [instance] [priority nat.prio] - -definition nat_has_zero [instance] [priority nat.prio] : has_zero nat := -has_zero.mk nat.zero - -definition nat_has_one [instance] [priority nat.prio] : has_one nat := -has_one.mk (nat.succ (nat.zero)) - -definition nat_has_add [instance] [priority nat.prio] : has_add nat := -has_add.mk nat.add - -/- - Global declarations of right binding strength - - If a module reassigns these, it will be incompatible with other modules that adhere to these - conventions. - - When hovering over a symbol, use "C-c C-k" to see how to input it. --/ -definition std.prec.max : num := 1024 -- the strength of application, identifiers, (, [, etc. -definition std.prec.arrow : num := 25 - -/- -The next definition is "max + 10". It can be used e.g. for postfix operations that should -be stronger than application. --/ - -definition std.prec.max_plus := -num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ - (num.succ std.prec.max))))))))) - -/- Logical operations and relations -/ - -reserve prefix `¬`:40 -reserve prefix `~`:40 -reserve infixr ` ∧ `:35 -reserve infixr ` /\ `:35 -reserve infixr ` \/ `:30 -reserve infixr ` ∨ `:30 -reserve infix ` <-> `:20 -reserve infix ` ↔ `:20 -reserve infix ` = `:50 -reserve infix ` ≠ `:50 -reserve infix ` ≈ `:50 -reserve infix ` ~ `:50 -reserve infix ` ≡ `:50 - -reserve infixr ` ∘ `:60 -- input with \comp -reserve postfix `⁻¹`:std.prec.max_plus -- input with \sy or \-1 or \inv - -reserve infixl ` ⬝ `:75 -reserve infixr ` ▸ `:75 -reserve infixr ` ▹ `:75 - -/- types and type constructors -/ - -reserve infixr ` ⊎ `:30 -reserve infixr ` × `:35 - -/- arithmetic operations -/ - -reserve infixl ` + `:65 -reserve infixl ` - `:65 -reserve infixl ` * `:70 -reserve infixl ` / `:70 -reserve infixl ` % `:70 -reserve prefix `-`:100 -reserve infix ` ^ `:80 - -reserve infix ` <= `:50 -reserve infix ` ≤ `:50 -reserve infix ` < `:50 -reserve infix ` >= `:50 -reserve infix ` ≥ `:50 -reserve infix ` > `:50 - -/- boolean operations -/ - -reserve infixl ` && `:70 -reserve infixl ` || `:65 - -/- set operations -/ - -reserve infix ` ∈ `:50 -reserve infix ` ∉ `:50 -reserve infixl ` ∩ `:70 -reserve infixl ` ∪ `:65 -reserve infix ` ⊆ `:50 -reserve infix ` ⊇ `:50 - -/- other symbols -/ - -reserve infix ` ∣ `:50 -reserve infixl ` ++ `:65 -reserve infixr ` :: `:67 - -/- - in the HoTT library we might not always want to overload the following notation, - so we put it in namespace algebra --/ - -infix + := add -infix * := mul -infix - := sub -infix / := div -infix ∣ := dvd -infix % := mod -prefix - := neg -namespace algebra -postfix ⁻¹ := inv -end algebra -infix ≤ := le -infix ≥ := ge -infix < := lt -infix > := gt - -notation [parsing_only] x ` +[`:65 A:0 `] `:0 y:65 := @add A _ x y -notation [parsing_only] x ` -[`:65 A:0 `] `:0 y:65 := @sub A _ x y -notation [parsing_only] x ` *[`:70 A:0 `] `:0 y:70 := @mul A _ x y -notation [parsing_only] x ` /[`:70 A:0 `] `:0 y:70 := @div A _ x y -notation [parsing_only] x ` ∣[`:70 A:0 `] `:0 y:70 := @dvd A _ x y -notation [parsing_only] x ` %[`:70 A:0 `] `:0 y:70 := @mod A _ x y -notation [parsing_only] x ` ≤[`:50 A:0 `] `:0 y:50 := @le A _ x y -notation [parsing_only] x ` ≥[`:50 A:0 `] `:0 y:50 := @ge A _ x y -notation [parsing_only] x ` <[`:50 A:0 `] `:0 y:50 := @lt A _ x y -notation [parsing_only] x ` >[`:50 A:0 `] `:0 y:50 := @gt A _ x y diff --git a/hott/init/tactic.hlean b/hott/init/tactic.hlean deleted file mode 100644 index fa323a1bc8..0000000000 --- a/hott/init/tactic.hlean +++ /dev/null @@ -1,151 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura - -This is just a trick to embed the 'tactic language' as a Lean -expression. We should view 'tactic' as automation that when execute -produces a term. tactic.builtin is just a "dummy" for creating the -definitions that are actually implemented in C++ --/ -prelude -import init.datatypes init.reserved_notation init.num - -inductive tactic : -Type := builtin : tactic - -namespace tactic --- Remark the following names are not arbitrary, the tactic module --- uses them when converting Lean expressions into actual tactic objects. --- The bultin 'by' construct triggers the process of converting a --- a term of type 'tactic' into a tactic that sythesizes a term -definition and_then (t1 t2 : tactic) : tactic := builtin -definition or_else (t1 t2 : tactic) : tactic := builtin -definition par (t1 t2 : tactic) : tactic := builtin -definition fixpoint (f : tactic → tactic) : tactic := builtin -definition repeat (t : tactic) : tactic := builtin -definition at_most (t : tactic) (k : num) : tactic := builtin -definition discard (t : tactic) (k : num) : tactic := builtin -definition focus_at (t : tactic) (i : num) : tactic := builtin -definition try_for (t : tactic) (ms : num) : tactic := builtin -definition all_goals (t : tactic) : tactic := builtin -definition now : tactic := builtin -definition assumption : tactic := builtin -definition eassumption : tactic := builtin -definition state : tactic := builtin -definition fail : tactic := builtin -definition id : tactic := builtin -definition info : tactic := builtin -definition contradiction : tactic := builtin -definition exfalso : tactic := builtin -definition congruence : tactic := builtin -definition rotate_left (k : num) := builtin -definition rotate_right (k : num) := builtin -definition rotate (k : num) := rotate_left k - --- This is just a trick to embed expressions into tactics. --- The nested expressions are "raw". They tactic should --- elaborate them when it is executed. -inductive expr : Type := -builtin : expr - -inductive expr_list : Type := -| nil : expr_list -| cons : expr → expr_list → expr_list - --- auxiliary type used to mark optional list of arguments -definition opt_expr_list := expr_list - --- auxiliary types used to mark that the expression is suppose to be an identifier, optional, or a list. -definition identifier := expr -definition identifier_list := expr_list -definition opt_identifier_list := expr_list --- Remark: the parser has special support for tactics containing `location` parameters. --- It will parse the optional `at ...` modifier. -definition location := expr --- Marker for instructing the parser to parse it as 'with ' -definition with_expr := expr - --- Marker for instructing the parser to parse it as '?(using )' -definition using_expr := expr --- Constant used to denote the case were no expression was provided -definition none_expr : expr := expr.builtin - -definition apply (e : expr) : tactic := builtin -definition eapply (e : expr) : tactic := builtin -definition fapply (e : expr) : tactic := builtin -definition rename (a b : identifier) : tactic := builtin -definition intro (e : opt_identifier_list) : tactic := builtin -definition generalize_tac (e : expr) (id : identifier) : tactic := builtin -definition clear (e : identifier_list) : tactic := builtin -definition revert (e : identifier_list) : tactic := builtin -definition refine (e : expr) : tactic := builtin -definition exact (e : expr) : tactic := builtin --- Relaxed version of exact that does not enforce goal type -definition rexact (e : expr) : tactic := builtin -definition check_expr (e : expr) : tactic := builtin -definition trace (s : string) : tactic := builtin - --- rewrite_tac is just a marker for the builtin 'rewrite' notation --- used to create instances of this tactic. -definition rewrite_tac (e : expr_list) : tactic := builtin -definition xrewrite_tac (e : expr_list) : tactic := builtin -definition krewrite_tac (e : expr_list) : tactic := builtin -definition replace (old : expr) (new : with_expr) (loc : location) : tactic := builtin - --- Arguments: --- - ls : lemmas to be used (if not provided, then blast will choose them) --- - ds : definitions that can be unfolded (if not provided, then blast will choose them) -definition blast (ls : opt_identifier_list) (ds : opt_identifier_list) : tactic := builtin - --- with_options_tac is just a marker for the builtin 'with_options' notation -definition with_options_tac (o : expr) (t : tactic) : tactic := builtin --- with_options_tac is just a marker for the builtin 'with_attributes' notation -definition with_attributes_tac (o : expr) (n : identifier_list) (t : tactic) : tactic := builtin - -definition cases (h : expr) (ids : opt_identifier_list) : tactic := builtin - -definition induction (h : expr) (rec : using_expr) (ids : opt_identifier_list) : tactic := builtin - -definition intros (ids : opt_identifier_list) : tactic := builtin - -definition generalizes (es : expr_list) : tactic := builtin - -definition clears (ids : identifier_list) : tactic := builtin - -definition reverts (ids : identifier_list) : tactic := builtin - -definition change (e : expr) : tactic := builtin - -definition assert_hypothesis (id : identifier) (e : expr) : tactic := builtin - -definition note_tac (id : identifier) (e : expr) : tactic := builtin - -definition constructor (k : option num) : tactic := builtin -definition fconstructor (k : option num) : tactic := builtin -definition existsi (e : expr) : tactic := builtin -definition split : tactic := builtin -definition left : tactic := builtin -definition right : tactic := builtin - -definition injection (e : expr) (ids : opt_identifier_list) : tactic := builtin - -definition subst (ids : identifier_list) : tactic := builtin -definition substvars : tactic := builtin - -definition reflexivity : tactic := builtin -definition symmetry : tactic := builtin -definition transitivity (e : expr) : tactic := builtin - -definition try (t : tactic) : tactic := or_else t id -definition repeat1 (t : tactic) : tactic := and_then t (repeat t) -definition focus (t : tactic) : tactic := focus_at t 0 -definition determ (t : tactic) : tactic := at_most t 1 -definition trivial : tactic := or_else (apply eq.refl) assumption -definition do (n : num) (t : tactic) : tactic := -nat.rec id (λn t', and_then t t') (nat.of_num n) - -end tactic -tactic_infixl `;`:15 := tactic.and_then -tactic_notation T1 `:`:15 T2 := tactic.focus (tactic.and_then T1 (tactic.all_goals T2)) -tactic_notation `(` h `|` r:(foldl `|` (e r, tactic.or_else r e) h) `)` := r diff --git a/hott/init/trunc.hlean b/hott/init/trunc.hlean deleted file mode 100644 index e1e01f1390..0000000000 --- a/hott/init/trunc.hlean +++ /dev/null @@ -1,376 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Jeremy Avigad, Floris van Doorn - -Definition of is_trunc (n-truncatedness) - -Ported from Coq HoTT. --/ - -prelude -import .nat .logic .equiv .pathover -open eq nat sigma unit sigma.ops ---set_option class.force_new true - -/- Truncation levels -/ - -inductive trunc_index : Type₀ := -| minus_two : trunc_index -| succ : trunc_index → trunc_index - -open trunc_index - -/- - notation for trunc_index is -2, -1, 0, 1, ... - from 0 and up this comes from a coercion from num to trunc_index (via ℕ) --/ - -notation `ℕ₋₂` := trunc_index -- input using \N-2 - -definition has_zero_trunc_index [instance] [priority 2000] : has_zero ℕ₋₂ := -has_zero.mk (succ (succ minus_two)) - -definition has_one_trunc_index [instance] [priority 2000] : has_one ℕ₋₂ := -has_one.mk (succ (succ (succ minus_two))) - -namespace trunc_index - - notation `-1` := trunc_index.succ trunc_index.minus_two -- ISSUE: -1 gets printed as -2.+1? - notation `-2` := trunc_index.minus_two - postfix `.+1`:(max+1) := trunc_index.succ - postfix `.+2`:(max+1) := λn, (n .+1 .+1) - - --addition, where we add two to the result - definition add_plus_two [reducible] (n m : ℕ₋₂) : ℕ₋₂ := - trunc_index.rec_on m n (λ k l, l .+1) - - infix ` +2+ `:65 := trunc_index.add_plus_two - - -- addition of trunc_indices, where results smaller than -2 are changed to -2 - protected definition add (n m : ℕ₋₂) : ℕ₋₂ := - trunc_index.cases_on m - (trunc_index.cases_on n -2 (λn', (trunc_index.cases_on n' -2 id))) - (λm', trunc_index.cases_on m' - (trunc_index.cases_on n -2 id) - (add_plus_two n)) - - /- we give a weird name to the reflexivity step to avoid overloading le.refl - (which can be used if types.trunc is imported) -/ - inductive le (a : ℕ₋₂) : ℕ₋₂ → Type := - | tr_refl : le a a - | step : Π {b}, le a b → le a (b.+1) - -end trunc_index - -definition has_le_trunc_index [instance] [priority 2000] : has_le ℕ₋₂ := -has_le.mk trunc_index.le - -attribute trunc_index.add [reducible] - -definition has_add_trunc_index [instance] [priority 2000] : has_add ℕ₋₂ := -has_add.mk trunc_index.add - -namespace trunc_index - - definition sub_two [reducible] (n : ℕ) : ℕ₋₂ := - nat.rec_on n -2 (λ n k, k.+1) - - definition add_two [reducible] (n : ℕ₋₂) : ℕ := - trunc_index.rec_on n nat.zero (λ n k, nat.succ k) - - postfix `.-2`:(max+1) := sub_two - postfix `.-1`:(max+1) := λn, (n .-2 .+1) - - definition of_nat [coercion] [reducible] (n : ℕ) : ℕ₋₂ := - n.-2.+2 - - definition succ_le_succ {n m : ℕ₋₂} (H : n ≤ m) : n.+1 ≤ m.+1 := - by induction H with m H IH; apply le.tr_refl; exact le.step IH - - definition minus_two_le (n : ℕ₋₂) : -2 ≤ n := - by induction n with n IH; apply le.tr_refl; exact le.step IH - -end trunc_index open trunc_index - -namespace is_trunc - - export [notation] [coercion] trunc_index - - /- truncated types -/ - - /- - Just as in Coq HoTT we define an internal version of contractibility and is_trunc, but we only - use `is_trunc` and `is_contr` - -/ - - structure contr_internal (A : Type) := - (center : A) - (center_eq : Π(a : A), center = a) - - definition is_trunc_internal (n : ℕ₋₂) : Type → Type := - trunc_index.rec_on n - (λA, contr_internal A) - (λn trunc_n A, (Π(x y : A), trunc_n (x = y))) - -end is_trunc open is_trunc - -structure is_trunc [class] (n : ℕ₋₂) (A : Type) := - (to_internal : is_trunc_internal n A) - -open nat num trunc_index - -namespace is_trunc - - abbreviation is_contr := is_trunc -2 - abbreviation is_prop := is_trunc -1 - abbreviation is_set := is_trunc 0 - - variables {A B : Type} - - definition is_trunc_succ_intro (A : Type) (n : ℕ₋₂) [H : ∀x y : A, is_trunc n (x = y)] - : is_trunc n.+1 A := - is_trunc.mk (λ x y, !is_trunc.to_internal) - - definition is_trunc_eq [instance] [priority 1200] - (n : ℕ₋₂) [H : is_trunc (n.+1) A] (x y : A) : is_trunc n (x = y) := - is_trunc.mk (is_trunc.to_internal (n.+1) A x y) - - /- contractibility -/ - - definition is_contr.mk (center : A) (center_eq : Π(a : A), center = a) : is_contr A := - is_trunc.mk (contr_internal.mk center center_eq) - - definition center (A : Type) [H : is_contr A] : A := - contr_internal.center (is_trunc.to_internal -2 A) - - definition center_eq [H : is_contr A] (a : A) : !center = a := - contr_internal.center_eq (is_trunc.to_internal -2 A) a - - definition eq_of_is_contr [H : is_contr A] (x y : A) : x = y := - (center_eq x)⁻¹ ⬝ (center_eq y) - - definition prop_eq_of_is_contr {A : Type} [H : is_contr A] {x y : A} (p q : x = y) : p = q := - have K : ∀ (r : x = y), eq_of_is_contr x y = r, from (λ r, eq.rec_on r !con.left_inv), - (K p)⁻¹ ⬝ K q - - theorem is_contr_eq {A : Type} [H : is_contr A] (x y : A) : is_contr (x = y) := - is_contr.mk !eq_of_is_contr (λ p, !prop_eq_of_is_contr) - local attribute is_contr_eq [instance] - - /- truncation is upward close -/ - - -- n-types are also (n+1)-types - theorem is_trunc_succ [instance] [priority 900] (A : Type) (n : ℕ₋₂) - [H : is_trunc n A] : is_trunc (n.+1) A := - trunc_index.rec_on n - (λ A (H : is_contr A), !is_trunc_succ_intro) - (λ n IH A (H : is_trunc (n.+1) A), @is_trunc_succ_intro _ _ (λ x y, IH _ _)) - A H - --in the proof the type of H is given explicitly to make it available for class inference - - theorem is_trunc_of_le.{l} (A : Type.{l}) {n m : ℕ₋₂} (Hnm : n ≤ m) - [Hn : is_trunc n A] : is_trunc m A := - begin - induction Hnm with m Hnm IH, - { exact Hn}, - { exact _} - end - - definition is_trunc_of_imp_is_trunc {n : ℕ₋₂} (H : A → is_trunc (n.+1) A) - : is_trunc (n.+1) A := - @is_trunc_succ_intro _ _ (λx y, @is_trunc_eq _ _ (H x) x y) - - definition is_trunc_of_imp_is_trunc_of_le {n : ℕ₋₂} (Hn : -1 ≤ n) (H : A → is_trunc n A) - : is_trunc n A := - begin - cases Hn with n' Hn': apply is_trunc_of_imp_is_trunc H - end - - -- these must be definitions, because we need them to compute sometimes - definition is_trunc_of_is_contr (A : Type) (n : ℕ₋₂) [H : is_contr A] : is_trunc n A := - trunc_index.rec_on n H (λn H, _) - - definition is_trunc_succ_of_is_prop (A : Type) (n : ℕ₋₂) [H : is_prop A] - : is_trunc (n.+1) A := - is_trunc_of_le A (show -1 ≤ n.+1, from succ_le_succ (minus_two_le n)) - - definition is_trunc_succ_succ_of_is_set (A : Type) (n : ℕ₋₂) [H : is_set A] - : is_trunc (n.+2) A := - is_trunc_of_le A (show 0 ≤ n.+2, from succ_le_succ (succ_le_succ (minus_two_le n))) - - /- props -/ - - definition is_prop.elim [H : is_prop A] (x y : A) : x = y := - !center - - definition is_contr_of_inhabited_prop {A : Type} [H : is_prop A] (x : A) : is_contr A := - is_contr.mk x (λy, !is_prop.elim) - - theorem is_prop_of_imp_is_contr {A : Type} (H : A → is_contr A) : is_prop A := - @is_trunc_succ_intro A -2 - (λx y, - have H2 : is_contr A, from H x, - !is_contr_eq) - - theorem is_prop.mk {A : Type} (H : ∀x y : A, x = y) : is_prop A := - is_prop_of_imp_is_contr (λ x, is_contr.mk x (H x)) - - theorem is_prop_elim_self {A : Type} {H : is_prop A} (x : A) : is_prop.elim x x = idp := - !is_prop.elim - - /- sets -/ - - theorem is_set.mk (A : Type) (H : ∀(x y : A) (p q : x = y), p = q) : is_set A := - @is_trunc_succ_intro _ _ (λ x y, is_prop.mk (H x y)) - - definition is_set.elim [H : is_set A] ⦃x y : A⦄ (p q : x = y) : p = q := - !is_prop.elim - - /- instances -/ - - definition is_contr_sigma_eq [instance] [priority 800] {A : Type} (a : A) - : is_contr (Σ(x : A), a = x) := - is_contr.mk (sigma.mk a idp) (λp, sigma.rec_on p (λ b q, eq.rec_on q idp)) - - definition is_contr_sigma_eq' [instance] [priority 800] {A : Type} (a : A) - : is_contr (Σ(x : A), x = a) := - is_contr.mk (sigma.mk a idp) (λp, sigma.rec_on p (λ b q, eq.rec_on q idp)) - - definition ap_pr1_center_eq_sigma_eq {A : Type} {a x : A} (p : a = x) - : ap pr₁ (center_eq ⟨x, p⟩) = p := - by induction p; reflexivity - - definition ap_pr1_center_eq_sigma_eq' {A : Type} {a x : A} (p : x = a) - : ap pr₁ (center_eq ⟨x, p⟩) = p⁻¹ := - by induction p; reflexivity - - definition is_contr_unit : is_contr unit := - is_contr.mk star (λp, unit.rec_on p idp) - - definition is_prop_empty : is_prop empty := - is_prop.mk (λx, !empty.elim x) - - local attribute is_contr_unit is_prop_empty [instance] - - definition is_trunc_unit [instance] (n : ℕ₋₂) : is_trunc n unit := - !is_trunc_of_is_contr - - definition is_trunc_empty [instance] (n : ℕ₋₂) : is_trunc (n.+1) empty := - !is_trunc_succ_of_is_prop - - /- interaction with equivalences -/ - - section - open is_equiv equiv - - definition is_contr_is_equiv_closed (f : A → B) [Hf : is_equiv f] [HA: is_contr A] - : (is_contr B) := - is_contr.mk (f (center A)) (λp, eq_of_eq_inv !center_eq) - - definition is_contr_equiv_closed (H : A ≃ B) [HA: is_contr A] : is_contr B := - is_contr_is_equiv_closed (to_fun H) - - definition equiv_of_is_contr_of_is_contr [HA : is_contr A] [HB : is_contr B] : A ≃ B := - equiv.mk - (λa, center B) - (is_equiv.adjointify (λa, center B) (λb, center A) center_eq center_eq) - - theorem is_trunc_is_equiv_closed (n : ℕ₋₂) (f : A → B) [H : is_equiv f] - [HA : is_trunc n A] : is_trunc n B := - begin - revert A HA B f H, induction n with n IH: intros, - { exact is_contr_is_equiv_closed f}, - { apply is_trunc_succ_intro, intro x y, - exact IH (f⁻¹ x = f⁻¹ y) _ (x = y) (ap f⁻¹)⁻¹ !is_equiv_inv} - end - - definition is_trunc_is_equiv_closed_rev (n : ℕ₋₂) (f : A → B) [H : is_equiv f] - [HA : is_trunc n B] : is_trunc n A := - is_trunc_is_equiv_closed n f⁻¹ - - definition is_trunc_equiv_closed (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n A] - : is_trunc n B := - is_trunc_is_equiv_closed n (to_fun f) - - definition is_trunc_equiv_closed_rev (n : ℕ₋₂) (f : A ≃ B) [HA : is_trunc n B] - : is_trunc n A := - is_trunc_is_equiv_closed n (to_inv f) - - definition is_equiv_of_is_prop [constructor] [HA : is_prop A] [HB : is_prop B] - (f : A → B) (g : B → A) : is_equiv f := - is_equiv.mk f g (λb, !is_prop.elim) (λa, !is_prop.elim) (λa, !is_set.elim) - - definition equiv_of_is_prop [constructor] [HA : is_prop A] [HB : is_prop B] - (f : A → B) (g : B → A) : A ≃ B := - equiv.mk f (is_equiv_of_is_prop f g) - - definition equiv_of_iff_of_is_prop [unfold 5] [HA : is_prop A] [HB : is_prop B] (H : A ↔ B) : A ≃ B := - equiv_of_is_prop (iff.elim_left H) (iff.elim_right H) - - /- truncatedness of lift -/ - definition is_trunc_lift [instance] [priority 1450] (A : Type) (n : ℕ₋₂) - [H : is_trunc n A] : is_trunc n (lift A) := - is_trunc_equiv_closed _ !equiv_lift - - end - - /- interaction with the Unit type -/ - - open equiv - /- A contractible type is equivalent to unit. -/ - variable (A) - definition equiv_unit_of_is_contr [H : is_contr A] : A ≃ unit := - equiv.MK (λ (x : A), ⋆) - (λ (u : unit), center A) - (λ (u : unit), unit.rec_on u idp) - (λ (x : A), center_eq x) - - /- interaction with pathovers -/ - variable {A} - variables {C : A → Type} - {a a₂ : A} (p : a = a₂) - (c : C a) (c₂ : C a₂) - - definition is_prop.elimo [H : is_prop (C a)] : c =[p] c₂ := - pathover_of_eq_tr !is_prop.elim - - definition is_trunc_pathover [instance] - (n : ℕ₋₂) [H : is_trunc (n.+1) (C a)] : is_trunc n (c =[p] c₂) := - is_trunc_equiv_closed_rev n !pathover_equiv_eq_tr - - variables {p c c₂} - theorem is_set.elimo (q q' : c =[p] c₂) [H : is_set (C a)] : q = q' := - !is_prop.elim - - -- TODO: port "Truncated morphisms" - - /- truncated universe -/ - -end is_trunc - -structure trunctype (n : ℕ₋₂) := - (carrier : Type) - (struct : is_trunc n carrier) - -notation n `-Type` := trunctype n -abbreviation Prop := -1-Type -abbreviation Set := 0-Type - -attribute trunctype.carrier [coercion] -attribute trunctype.struct [instance] [priority 1400] - -protected abbreviation Prop.mk := @trunctype.mk -1 -protected abbreviation Set.mk := @trunctype.mk (-1.+1) - -protected definition trunctype.mk' [constructor] (n : ℕ₋₂) (A : Type) [H : is_trunc n A] - : n-Type := -trunctype.mk A H - -namespace is_trunc - - definition tlift.{u v} [constructor] {n : ℕ₋₂} (A : trunctype.{u} n) - : trunctype.{max u v} n := - trunctype.mk (lift A) !is_trunc_lift - -end is_trunc diff --git a/hott/init/types.hlean b/hott/init/types.hlean deleted file mode 100644 index 7080922718..0000000000 --- a/hott/init/types.hlean +++ /dev/null @@ -1,96 +0,0 @@ -/- -Copyright (c) 2014-2015 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn, Jakob von Raumer --/ - -prelude -import init.num init.relation -open iff - --- Empty type --- ---------- - -protected definition empty.has_decidable_eq [instance] : decidable_eq empty := -take (a b : empty), decidable.inl (!empty.elim a) - --- Unit type --- --------- - -namespace unit - - notation `⋆` := star - -end unit - --- Sigma type --- ---------- - -notation `Σ` binders `, ` r:(scoped P, sigma P) := r -abbreviation dpair [constructor] := @sigma.mk -namespace sigma - notation `⟨`:max t:(foldr `, ` (e r, mk e r)) `⟩`:0 := t --input ⟨ ⟩ as \< \> - - namespace ops - postfix `.1`:(max+1) := pr1 - postfix `.2`:(max+1) := pr2 - abbreviation pr₁ := @pr1 - abbreviation pr₂ := @pr2 - end ops -end sigma - --- Sum type --- -------- - -namespace sum - infixr + := sum - namespace low_precedence_plus - reserve infixr ` + `:25 -- conflicts with notation for addition - infixr ` + ` := sum - end low_precedence_plus - - variables {a b c d : Type} - - definition sum_of_sum_of_imp_of_imp (H₁ : a ⊎ b) (H₂ : a → c) (H₃ : b → d) : c ⊎ d := - sum.rec_on H₁ - (assume Ha : a, sum.inl (H₂ Ha)) - (assume Hb : b, sum.inr (H₃ Hb)) - - definition sum_of_sum_of_imp_left (H₁ : a ⊎ c) (H : a → b) : b ⊎ c := - sum.rec_on H₁ - (assume H₂ : a, sum.inl (H H₂)) - (assume H₂ : c, sum.inr H₂) - - definition sum_of_sum_of_imp_right (H₁ : c ⊎ a) (H : a → b) : c ⊎ b := - sum.rec_on H₁ - (assume H₂ : c, sum.inl H₂) - (assume H₂ : a, sum.inr (H H₂)) -end sum - --- Product type --- ------------ - -namespace prod - - -- notation for n-ary tuples - notation `(` h `, ` t:(foldl `,` (e r, prod.mk r e) h) `)` := t - - namespace ops - postfix `.1`:(max+1) := pr1 - postfix `.2`:(max+1) := pr2 - abbreviation pr₁ := @pr1 - abbreviation pr₂ := @pr2 - end ops - - namespace low_precedence_times - - reserve infixr ` * `:30 -- conflicts with notation for multiplication - infixr ` * ` := prod - - end low_precedence_times - - open prod.ops - - definition flip [unfold 3] {A B : Type} (a : A × B) : B × A := pair (pr2 a) (pr1 a) - -end prod diff --git a/hott/init/ua.hlean b/hott/init/ua.hlean deleted file mode 100644 index 5ece71c4c6..0000000000 --- a/hott/init/ua.hlean +++ /dev/null @@ -1,87 +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 --/ - -prelude -import .equiv -open eq equiv is_equiv - ---Ensure that the types compared are in the same universe -section - universe variable l - variables {A B : Type.{l}} - - definition is_equiv_cast_of_eq [constructor] (H : A = B) : is_equiv (cast H) := - is_equiv_tr (λX, X) H - - definition equiv_of_eq [constructor] (H : A = B) : A ≃ B := - equiv.mk _ (is_equiv_cast_of_eq H) - - definition equiv_of_eq_refl [reducible] [unfold_full] (A : Type) - : equiv_of_eq (refl A) = equiv.refl := - idp - - -end - -axiom univalence (A B : Type) : is_equiv (@equiv_of_eq A B) - -attribute univalence [instance] - --- This is the version of univalence axiom we will probably use most often -definition ua [reducible] {A B : Type} : A ≃ B → A = B := -equiv_of_eq⁻¹ - -definition eq_equiv_equiv (A B : Type) : (A = B) ≃ (A ≃ B) := -equiv.mk equiv_of_eq _ - -definition equiv_of_eq_ua [reducible] {A B : Type} (f : A ≃ B) : equiv_of_eq (ua f) = f := -right_inv equiv_of_eq f - -definition cast_ua_fn {A B : Type} (f : A ≃ B) : cast (ua f) = f := -ap to_fun (equiv_of_eq_ua f) - -definition cast_ua {A B : Type} (f : A ≃ B) (a : A) : cast (ua f) a = f a := -ap10 (cast_ua_fn f) a - -definition ua_equiv_of_eq [reducible] {A B : Type} (p : A = B) : ua (equiv_of_eq p) = p := -left_inv equiv_of_eq p - -definition eq_of_equiv_lift {A B : Type} (f : A ≃ B) : A = lift B := -ua (f ⬝e !equiv_lift) - -namespace equiv - definition ua_refl (A : Type) : ua erfl = idpath A := - eq_of_fn_eq_fn !eq_equiv_equiv (right_inv !eq_equiv_equiv erfl) - - -- One consequence of UA is that we can transport along equivalencies of types - -- We can use this for calculation evironments - protected definition transport_of_equiv [subst] (P : Type → Type) {A B : Type} (H : A ≃ B) - : P A → P B := - eq.transport P (ua H) - - -- we can "recurse" on equivalences, by replacing them by (equiv_of_eq _) - definition rec_on_ua [recursor] {A B : Type} {P : A ≃ B → Type} - (f : A ≃ B) (H : Π(q : A = B), P (equiv_of_eq q)) : P f := - right_inv equiv_of_eq f ▸ H (ua f) - - -- a variant where we immediately recurse on the equality in the new goal - definition rec_on_ua_idp [recursor] {A : Type} {P : Π{B}, A ≃ B → Type} {B : Type} - (f : A ≃ B) (H : P equiv.refl) : P f := - rec_on_ua f (λq, eq.rec_on q H) - - -- a variant where (equiv_of_eq (ua f)) will be replaced by f in the new goal - definition rec_on_ua' {A B : Type} {P : A ≃ B → A = B → Type} - (f : A ≃ B) (H : Π(q : A = B), P (equiv_of_eq q) q) : P f (ua f) := - right_inv equiv_of_eq f ▸ H (ua f) - - -- a variant where we do both - definition rec_on_ua_idp' {A : Type} {P : Π{B}, A ≃ B → A = B → Type} {B : Type} - (f : A ≃ B) (H : P equiv.refl idp) : P f (ua f) := - rec_on_ua' f (λq, eq.rec_on q H) - -end equiv diff --git a/hott/init/util.hlean b/hott/init/util.hlean deleted file mode 100644 index cf5c8d203c..0000000000 --- a/hott/init/util.hlean +++ /dev/null @@ -1,16 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura - -Auxiliary definitions used by automation --/ - -prelude -import init.trunc - -open is_trunc - -definition eq_rec_eq.{l₁ l₂} {A : Type.{l₁}} {B : A → Type.{l₂}} [h : is_set A] {a : A} (b : B a) (p : a = a) : - b = @eq.rec.{l₂ l₁} A a (λ (a' : A) (h : a = a'), B a') b a p := -eq.rec_on (is_set.elim (eq.refl a) p) (eq.refl (eq.rec_on (eq.refl a) b)) diff --git a/hott/init/wf.hlean b/hott/init/wf.hlean deleted file mode 100644 index 82c688a6e0..0000000000 --- a/hott/init/wf.hlean +++ /dev/null @@ -1,246 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura --/ -prelude -import init.relation init.tactic init.funext - -open eq - -inductive acc.{l₁ l₂} {A : Type.{l₁}} (R : A → A → Type.{l₂}) : A → Type.{max l₁ l₂} := -intro : ∀x, (∀ y, R y x → acc R y) → acc R x - -namespace acc - variables {A : Type} {R : A → A → Type} - - definition acc_eq {a : A} (H₁ H₂ : acc R a) : H₁ = H₂ := - begin - induction H₁ with a K₁ IH₁, - induction H₂ with a K₂ IH₂, - apply eq.ap (intro a), - apply eq_of_homotopy, intro a, - apply eq_of_homotopy, intro r, - apply IH₁ - end - - definition inv {x y : A} (H₁ : acc R x) (H₂ : R y x) : acc R y := - acc.rec_on H₁ (λ x₁ ac₁ iH H₂, ac₁ y H₂) H₂ - - -- dependent elimination for acc - protected definition drec [recursor] - {C : Π (a : A), acc R a → Type} - (h₁ : Π (x : A) (acx : Π (y : A), R y x → acc R y), - (Π (y : A) (ryx : R y x), C y (acx y ryx)) → C x (acc.intro x acx)) - {a : A} (h₂ : acc R a) : C a h₂ := - acc.rec h₁ h₂ -end acc - -inductive well_founded [class] {A : Type} (R : A → A → Type) : Type := -intro : (Π a, acc R a) → well_founded R - -namespace well_founded - definition apply [coercion] {A : Type} {R : A → A → Type} (wf : well_founded R) : Πa, acc R a := - take a, well_founded.rec_on wf (λp, p) a - - section - parameters {A : Type} {R : A → A → Type} - local infix `≺`:50 := R - - hypothesis [Hwf : well_founded R] - - theorem recursion {C : A → Type} (a : A) (H : Πx, (Πy, y ≺ x → C y) → C x) : C a := - acc.rec_on (Hwf a) (λ x₁ ac₁ iH, H x₁ iH) - - theorem induction {C : A → Type} (a : A) (H : Πx, (Πy, y ≺ x → C y) → C x) : C a := - recursion a H - - variable {C : A → Type} - variable F : Πx, (Πy, y ≺ x → C y) → C x - - definition fix_F (x : A) (a : acc R x) : C x := - acc.rec_on a (λ x₁ ac₁ iH, F x₁ iH) - - theorem fix_F_eq (x : A) (r : acc R x) : - fix_F F x r = F x (λ (y : A) (p : y ≺ x), fix_F F y (acc.inv r p)) := - begin - induction r using acc.drec, - reflexivity -- proof is star due to proof irrelevance - end - end - - variables {A : Type} {C : A → Type} {R : A → A → Type} - - -- Well-founded fixpoint - definition fix [Hwf : well_founded R] (F : Πx, (Πy, R y x → C y) → C x) (x : A) : C x := - fix_F F x (Hwf x) - - -- Well-founded fixpoint satisfies fixpoint equation - theorem fix_eq [Hwf : well_founded R] (F : Πx, (Πy, R y x → C y) → C x) (x : A) : - fix F x = F x (λy h, fix F y) := - begin - refine fix_F_eq F x (Hwf x) ⬝ _, - apply ap (F x), - apply eq_of_homotopy, intro a, - apply eq_of_homotopy, intro r, - apply ap (fix_F F a), - apply acc.acc_eq - end -end well_founded - -open well_founded - --- Empty relation is well-founded -definition empty.wf {A : Type} : well_founded empty_relation := -well_founded.intro (λ (a : A), - acc.intro a (λ (b : A) (lt : empty), empty.rec _ lt)) - --- Subrelation of a well-founded relation is well-founded -namespace subrelation -section - universe variable u - parameters {A : Type} {R Q : A → A → Type} - parameters (H₁ : subrelation Q R) - parameters (H₂ : well_founded R) - - definition accessible {a : A} (ac : acc R a) : acc Q a := - using H₁, - begin - induction ac with x ax ih, constructor, - exact λ (y : A) (lt : Q y x), ih y (H₁ lt) - end - - definition wf : well_founded Q := - using H₂, - well_founded.intro (λ a, accessible proof (@apply A R H₂ a) qed) -end -end subrelation - --- The inverse image of a well-founded relation is well-founded -namespace inv_image -section - parameters {A B : Type} {R : B → B → Type} - parameters (f : A → B) - parameters (H : well_founded R) - - private definition acc_aux {b : B} (ac : acc R b) : Π x, f x = b → acc (inv_image R f) x := - begin - induction ac with x acx ih, - intro z e, constructor, - intro y lt, subst x, - exact ih (f y) lt y rfl - end - - definition accessible {a : A} (ac : acc R (f a)) : acc (inv_image R f) a := - acc_aux ac a rfl - - definition wf : well_founded (inv_image R f) := - well_founded.intro (λ a, accessible (H (f a))) -end -end inv_image - --- The transitive closure of a well-founded relation is well-founded -namespace tc -section - parameters {A : Type} {R : A → A → Type} - local notation `R⁺` := tc R - - definition accessible {z} (ac: acc R z) : acc R⁺ z := - begin - induction ac with x acx ih, - constructor, intro y rel, - induction rel with a b rab a b c rab rbc ih₁ ih₂, - {exact ih a rab}, - {exact acc.inv (ih₂ acx ih) rab} - end - - definition wf (H : well_founded R) : well_founded R⁺ := - well_founded.intro (λ a, accessible (H a)) -end -end tc - -namespace nat - - -- less-than is well-founded - definition lt.wf [instance] : well_founded (lt : ℕ → ℕ → Type₀) := - begin - constructor, intro n, induction n with n IH, - { constructor, intros n H, exfalso, exact !not_lt_zero H}, - { constructor, intros m H, - have aux : ∀ {n₁} (hlt : m < n₁), succ n = n₁ → acc lt m, - begin - intros n₁ hlt, induction hlt, - { intro p, injection p with q, exact q ▸ IH}, - { intro p, injection p with q, exact (acc.inv (q ▸ IH) a)} - end, - apply aux H rfl}, - end - - definition measure {A : Type} : (A → ℕ) → A → A → Type₀ := - inv_image lt - - definition measure.wf {A : Type} (f : A → ℕ) : well_founded (measure f) := - inv_image.wf f lt.wf - -end nat - -namespace prod - - open well_founded prod.ops - - section - variables {A B : Type} - variable (Ra : A → A → Type) - variable (Rb : B → B → Type) - - -- Lexicographical order based on Ra and Rb - inductive lex : A × B → A × B → Type := - | left : ∀{a₁ b₁} a₂ b₂, Ra a₁ a₂ → lex (a₁, b₁) (a₂, b₂) - | right : ∀a {b₁ b₂}, Rb b₁ b₂ → lex (a, b₁) (a, b₂) - - -- Relational product based on Ra and Rb - inductive rprod : A × B → A × B → Type := - intro : ∀{a₁ b₁ a₂ b₂}, Ra a₁ a₂ → Rb b₁ b₂ → rprod (a₁, b₁) (a₂, b₂) - end - - section - parameters {A B : Type} - parameters {Ra : A → A → Type} {Rb : B → B → Type} - local infix `≺`:50 := lex Ra Rb - - definition lex.accessible {a} (aca : acc Ra a) (acb : ∀b, acc Rb b): ∀b, acc (lex Ra Rb) (a, b) := - acc.rec_on aca - (λxa aca (iHa : ∀y, Ra y xa → ∀b, acc (lex Ra Rb) (y, b)), - λb, acc.rec_on (acb b) - (λxb acb - (iHb : ∀y, Rb y xb → acc (lex Ra Rb) (xa, y)), - acc.intro (xa, xb) (λp (lt : p ≺ (xa, xb)), - have aux : xa = xa → xb = xb → acc (lex Ra Rb) p, from - @prod.lex.rec_on A B Ra Rb (λp₁ p₂ h, pr₁ p₂ = xa → pr₂ p₂ = xb → acc (lex Ra Rb) p₁) - p (xa, xb) lt - (λa₁ b₁ a₂ b₂ (H : Ra a₁ a₂) (eq₂ : a₂ = xa) (eq₃ : b₂ = xb), - show acc (lex Ra Rb) (a₁, b₁), from - have Ra₁ : Ra a₁ xa, from eq.rec_on eq₂ H, - iHa a₁ Ra₁ b₁) - (λa b₁ b₂ (H : Rb b₁ b₂) (eq₂ : a = xa) (eq₃ : b₂ = xb), - show acc (lex Ra Rb) (a, b₁), from - have Rb₁ : Rb b₁ xb, from eq.rec_on eq₃ H, - have eq₂' : xa = a, from eq.rec_on eq₂ rfl, - eq.rec_on eq₂' (iHb b₁ Rb₁)), - aux rfl rfl))) - - -- The lexicographical order of well founded relations is well-founded - definition lex.wf (Ha : well_founded Ra) (Hb : well_founded Rb) : well_founded (lex Ra Rb) := - well_founded.intro (λp, destruct p (λa b, lex.accessible (Ha a) (well_founded.apply Hb) b)) - - -- Relational product is a subrelation of the lex - definition rprod.sub_lex : ∀ a b, rprod Ra Rb a b → lex Ra Rb a b := - λa b H, prod.rprod.rec_on H (λ a₁ b₁ a₂ b₂ H₁ H₂, lex.left Rb a₂ b₂ H₁) - - -- The relational product of well founded relations is well-founded - definition rprod.wf (Ha : well_founded Ra) (Hb : well_founded Rb) : well_founded (rprod Ra Rb) := - subrelation.wf (rprod.sub_lex) (lex.wf Ha Hb) - - end - -end prod diff --git a/hott/logic.hlean b/hott/logic.hlean deleted file mode 100644 index ad53a46b4e..0000000000 --- a/hott/logic.hlean +++ /dev/null @@ -1,18 +0,0 @@ -/- -Copyright (c) Jakob von Raumer. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Jakob von Raumer - -Logic lemmas we don't want/need in the prelude. --/ -import types.pi - -open eq is_trunc decidable - -theorem dif_pos {c : Type} [H : decidable c] [P : is_prop c] (Hc : c) - {A : Type} {t : c → A} {e : ¬ c → A} : dite c t e = t Hc := -by induction H with Hc Hnc; apply ap t; apply is_prop.elim; apply absurd Hc Hnc - -theorem dif_neg {c : Type} [H : decidable c] (Hnc : ¬c) - {A : Type} {t : c → A} {e : ¬ c → A} : dite c t e = e Hnc := -by induction H with Hc Hnc; apply absurd Hc Hnc; apply ap e; apply is_prop.elim diff --git a/hott/port.md b/hott/port.md deleted file mode 100644 index 14a3d48f61..0000000000 --- a/hott/port.md +++ /dev/null @@ -1,21 +0,0 @@ -We port a lot of algebra and number systems (nat, int, ...) files from the standard library to the HoTT library. - -Port instructions: -- use the script port.pl in scripts/ to port the file. e.g. execute the following in the `scripts` folder: `./port.pl ../library/algebra/lattice.lean ../hott/algebra/lattice.hlean` -- remove imports starting with `data.` or `logic.` (sometimes you need to replace a `data.` import by the corresponding `types.` import) -- Open namespaces `eq` and `algebra` if needed -- (optional) add option `set_option class.force_new true` -- fix all remaining errors. Typical errors include - - Replacing "and" by "prod" in comments - - and.intro is replaced by prod.intro, which should be prod.mk. - - the usage of the simp tactic - -Currently, the following differences exist between the two libraries, relevant to porting: -- All of the algebraic hierarchy is in the algebra namespace in the HoTT library (on top-level in the standard library). -- The projections "zero" and "one" are reducible in HoTT. This was needed to allow type class inferences to infer -``` -H : is_trunc 0 A |- is_trunc (succ (-1)) A -H : is_trunc 1 A |- is_trunc (succ 0) A -``` -- Projections of most algebraic structures are definitions instead of theorems in HoTT -- Basic properties of `nat.add` have a simpler proof in HoTT (so that it computes better) \ No newline at end of file diff --git a/hott/prop_trunc.hlean b/hott/prop_trunc.hlean deleted file mode 100644 index 52b44412b6..0000000000 --- a/hott/prop_trunc.hlean +++ /dev/null @@ -1,53 +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, Floris van Doorn - -Proof of the theorem that (is_trunc n A) is a mere proposition -We prove this here to avoid circular dependency of files -We want to use this in .equiv; .equiv is imported by .function and .function is imported by .trunc --/ - -import types.pi - -open equiv sigma sigma.ops eq function pi - -namespace is_trunc - definition is_contr.sigma_char (A : Type) : - (Σ (center : A), Π (a : A), center = a) ≃ (is_contr A) := - begin - fapply equiv.MK, - { intro S, exact (is_contr.mk S.1 S.2)}, - { intro H, cases H with H', cases H' with ce co, exact ⟨ce, co⟩}, - { intro H, cases H with H', cases H' with ce co, exact idp}, - { intro S, cases S, apply idp} - end - - definition is_trunc.pi_char (n : trunc_index) (A : Type) : - (Π (x y : A), is_trunc n (x = y)) ≃ (is_trunc (n .+1) A) := - begin - fapply equiv.MK, - { intro H, apply is_trunc_succ_intro}, - { intro H x y, apply is_trunc_eq}, - { intro H, cases H, apply idp}, - { intro P, apply eq_of_homotopy, intro a, apply eq_of_homotopy, intro b, - change is_trunc.mk (to_internal n (a = b)) = P a b, - induction (P a b), apply idp}, - end - - definition is_prop_is_trunc [instance] (n : trunc_index) : - Π (A : Type), is_prop (is_trunc n A) := - begin - induction n, - { intro A, - apply is_trunc_is_equiv_closed, - { apply equiv.to_is_equiv, apply is_contr.sigma_char}, - apply is_prop.mk, intros, - fapply sigma_eq, apply x.2, - apply is_prop.elimo}, - { intro A, - apply is_trunc_is_equiv_closed, - apply equiv.to_is_equiv, - apply is_trunc.pi_char}, - end -end is_trunc diff --git a/hott/tools/helper_tactics.hlean b/hott/tools/helper_tactics.hlean deleted file mode 100644 index 91375d8f76..0000000000 --- a/hott/tools/helper_tactics.hlean +++ /dev/null @@ -1,15 +0,0 @@ --- Copyright (c) 2014 Microsoft Corporation. All rights reserved. --- Released under Apache 2.0 license as described in the file LICENSE. --- Author: Leonardo de Moura, Jeremy Avigad - --- tools.helper_tactics --- ==================== - --- Useful tactics. - -open tactic - -namespace helper_tactics - definition apply_refl := apply eq.refl - tactic_hint apply_refl -end helper_tactics diff --git a/hott/tools/tools.md b/hott/tools/tools.md deleted file mode 100644 index 6a06271ae5..0000000000 --- a/hott/tools/tools.md +++ /dev/null @@ -1,6 +0,0 @@ -tools -===== - -Various additional tools. - -* [helper_tactics](helper_tactics.hlean) : useful tactics diff --git a/hott/types/W.hlean b/hott/types/W.hlean deleted file mode 100644 index 7ea30fdb72..0000000000 --- a/hott/types/W.hlean +++ /dev/null @@ -1,131 +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 W-types (well-founded trees) --/ - -import .sigma .pi -open eq equiv is_equiv sigma sigma.ops - -inductive Wtype.{l k} {A : Type.{l}} (B : A → Type.{k}) : Type.{max l k} := -sup : Π (a : A), (B a → Wtype.{l k} B) → Wtype.{l k} B - -namespace Wtype - notation `W` binders `, ` r:(scoped B, Wtype B) := r - - universe variables u v - variables {A A' : Type.{u}} {B B' : A → Type.{v}} {C : Π(a : A), B a → Type} - {a a' : A} {f : B a → W a, B a} {f' : B a' → W a, B a} {w w' : W(a : A), B a} - - protected definition pr1 [unfold 3] (w : W(a : A), B a) : A := - by cases w with a f; exact a - - protected definition pr2 [unfold 3] (w : W(a : A), B a) : B (Wtype.pr1 w) → W(a : A), B a := - by cases w with a f; exact f - - namespace ops - postfix `.1`:(max+1) := Wtype.pr1 - postfix `.2`:(max+1) := Wtype.pr2 - notation `⟨` a `, ` f `⟩`:0 := Wtype.sup a f --input ⟨ ⟩ as \< \> - end ops - open ops - - protected definition eta [unfold 3] (w : W a, B a) : ⟨w.1 , w.2⟩ = w := - by cases w; exact idp - - definition sup_eq_sup [unfold 8] (p : a = a') (q : f =[p] f') : ⟨a, f⟩ = ⟨a', f'⟩ := - by cases q; exact idp - - definition Wtype_eq [unfold 3 4] (p : w.1 = w'.1) (q : w.2 =[p] w'.2) : w = w' := - by cases w; cases w';exact (sup_eq_sup p q) - - definition Wtype_eq_pr1 [unfold 5] (p : w = w') : w.1 = w'.1 := - by cases p;exact idp - - definition Wtype_eq_pr2 [unfold 5] (p : w = w') : w.2 =[Wtype_eq_pr1 p] w'.2 := - by cases p;exact idpo - - namespace ops - postfix `..1`:(max+1) := Wtype_eq_pr1 - postfix `..2`:(max+1) := Wtype_eq_pr2 - end ops open ops open sigma - - definition sup_path_W (p : w.1 = w'.1) (q : w.2 =[p] w'.2) - : ⟨(Wtype_eq p q)..1, (Wtype_eq p q)..2⟩ = ⟨p, q⟩ := - by cases w; cases w'; cases q; exact idp - - definition pr1_path_W (p : w.1 = w'.1) (q : w.2 =[p] w'.2) : (Wtype_eq p q)..1 = p := - !sup_path_W..1 - - definition pr2_path_W (p : w.1 = w'.1) (q : w.2 =[p] w'.2) - : (Wtype_eq p q)..2 =[pr1_path_W p q] q := - !sup_path_W..2 - - definition eta_path_W (p : w = w') : Wtype_eq (p..1) (p..2) = p := - by cases p; cases w; exact idp - - definition transport_pr1_path_W {B' : A → Type} (p : w.1 = w'.1) (q : w.2 =[p] w'.2) - : transport (λx, B' x.1) (Wtype_eq p q) = transport B' p := - by cases w; cases w'; cases q; exact idp - - definition path_W_uncurried (pq : Σ(p : w.1 = w'.1), w.2 =[p] w'.2) : w = w' := - by cases pq with p q; exact (Wtype_eq p q) - - definition sup_path_W_uncurried (pq : Σ(p : w.1 = w'.1), w.2 =[p] w'.2) - : ⟨(path_W_uncurried pq)..1, (path_W_uncurried pq)..2⟩ = pq := - by cases pq with p q; exact (sup_path_W p q) - - definition pr1_path_W_uncurried (pq : Σ(p : w.1 = w'.1), w.2 =[p] w'.2) - : (path_W_uncurried pq)..1 = pq.1 := - !sup_path_W_uncurried..1 - - definition pr2_path_W_uncurried (pq : Σ(p : w.1 = w'.1), w.2 =[p] w'.2) - : (path_W_uncurried pq)..2 =[pr1_path_W_uncurried pq] pq.2 := - !sup_path_W_uncurried..2 - - definition eta_path_W_uncurried (p : w = w') : path_W_uncurried ⟨p..1, p..2⟩ = p := - !eta_path_W - - definition transport_pr1_path_W_uncurried {B' : A → Type} (pq : Σ(p : w.1 = w'.1), w.2 =[p] w'.2) - : transport (λx, B' x.1) (@path_W_uncurried A B w w' pq) = transport B' pq.1 := - by cases pq with p q; exact (transport_pr1_path_W p q) - - definition isequiv_path_W /-[instance]-/ (w w' : W a, B a) - : is_equiv (path_W_uncurried : (Σ(p : w.1 = w'.1), w.2 =[p] w'.2) → w = w') := - adjointify path_W_uncurried - (λp, ⟨p..1, p..2⟩) - eta_path_W_uncurried - sup_path_W_uncurried - - definition equiv_path_W (w w' : W a, B a) : (Σ(p : w.1 = w'.1), w.2 =[p] w'.2) ≃ (w = w') := - equiv.mk path_W_uncurried !isequiv_path_W - - definition double_induction_on {P : (W a, B a) → (W a, B a) → Type} (w w' : W a, B a) - (H : ∀ (a a' : A) (f : B a → W a, B a) (f' : B a' → W a, B a), - (∀ (b : B a) (b' : B a'), P (f b) (f' b')) → P (sup a f) (sup a' f')) : P w w' := - begin - revert w', - induction w with a f IH, - intro w', - cases w' with a' f', - apply H, intro b b', - apply IH - end - - /- truncatedness -/ - open is_trunc pi - definition is_trunc_W [instance] (n : trunc_index) - [HA : is_trunc (n.+1) A] : is_trunc (n.+1) (W a, B a) := - begin - fapply is_trunc_succ_intro, intro w w', - eapply (double_induction_on w w'), intro a a' f f' IH, - fapply is_trunc_equiv_closed, - { apply equiv_path_W}, - { apply is_trunc_sigma, - intro p, cases p, esimp, apply is_trunc_equiv_closed_rev, - apply pathover_idp} - end - -end Wtype diff --git a/hott/types/arrow.hlean b/hott/types/arrow.hlean deleted file mode 100644 index 91a892eb18..0000000000 --- a/hott/types/arrow.hlean +++ /dev/null @@ -1,144 +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 - -Ported from Coq HoTT -Theorems about arrow types (function spaces) --/ - -import types.pi - -open eq equiv is_equiv funext pi is_trunc unit - -namespace pi - - variables {A A' : Type} {B B' : Type} {C : A → B → Type} {D : A → Type} - {a a' a'' : A} {b b' b'' : B} {f g : A → B} {d : D a} {d' : D a'} - - -- all lemmas here are special cases of the ones for pi-types - - /- Functorial action -/ - variables (f0 : A' → A) (f1 : B → B') - - definition arrow_functor [unfold_full] : (A → B) → (A' → B') := pi_functor f0 (λa, f1) - - /- Equivalences -/ - - definition is_equiv_arrow_functor [constructor] - [H0 : is_equiv f0] [H1 : is_equiv f1] : is_equiv (arrow_functor f0 f1) := - is_equiv_pi_functor f0 (λa, f1) - - definition arrow_equiv_arrow_rev [constructor] (f0 : A' ≃ A) (f1 : B ≃ B') - : (A → B) ≃ (A' → B') := - equiv.mk _ (is_equiv_arrow_functor f0 f1) - - definition arrow_equiv_arrow [constructor] (f0 : A ≃ A') (f1 : B ≃ B') : (A → B) ≃ (A' → B') := - arrow_equiv_arrow_rev (equiv.symm f0) f1 - - variable (A) - definition arrow_equiv_arrow_right [constructor] (f1 : B ≃ B') : (A → B) ≃ (A → B') := - arrow_equiv_arrow_rev equiv.refl f1 - - variables {A} (B) - definition arrow_equiv_arrow_left_rev [constructor] (f0 : A' ≃ A) : (A → B) ≃ (A' → B) := - arrow_equiv_arrow_rev f0 equiv.refl - - definition arrow_equiv_arrow_left [constructor] (f0 : A ≃ A') : (A → B) ≃ (A' → B) := - arrow_equiv_arrow f0 equiv.refl - - variables {B} - definition arrow_equiv_arrow_right' [constructor] (f1 : A → (B ≃ B')) : (A → B) ≃ (A → B') := - pi_equiv_pi_right f1 - - /- Equivalence if one of the types is contractible -/ - - variables (A B) - definition arrow_equiv_of_is_contr_left [constructor] [H : is_contr A] : (A → B) ≃ B := - !pi_equiv_of_is_contr_left - - definition arrow_equiv_of_is_contr_right [constructor] [H : is_contr B] : (A → B) ≃ unit := - !pi_equiv_of_is_contr_right - - /- Interaction with other type constructors -/ - - -- most of these are in the file of the other type constructor - - definition arrow_empty_left [constructor] : (empty → B) ≃ unit := - !pi_empty_left - - definition arrow_unit_left [constructor] : (unit → B) ≃ B := - !arrow_equiv_of_is_contr_left - - definition arrow_unit_right [constructor] : (A → unit) ≃ unit := - !arrow_equiv_of_is_contr_right - - variables {A B} - - /- Transport -/ - - definition arrow_transport {B C : A → Type} (p : a = a') (f : B a → C a) - : (transport (λa, B a → C a) p f) ~ (λb, p ▸ f (p⁻¹ ▸ b)) := - eq.rec_on p (λx, idp) - - /- Pathovers -/ - - definition arrow_pathover {B C : A → Type} {f : B a → C a} {g : B a' → C a'} {p : a = a'} - (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - exact eq_of_pathover_idp (r b b idpo), - end - - definition arrow_pathover_left {B C : A → Type} {f : B a → C a} {g : B a' → C a'} {p : a = a'} - (r : Π(b : B a), f b =[p] g (p ▸ b)) : f =[p] g := - begin - induction p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - exact eq_of_pathover_idp (r b), - end - - definition arrow_pathover_right {B C : A → Type} {f : B a → C a} {g : B a' → C a'} {p : a = a'} - (r : Π(b' : B a'), f (p⁻¹ ▸ b') =[p] g b') : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - exact eq_of_pathover_idp (r b), - end - - definition arrow_pathover_constant_left {B : Type} {C : A → Type} {f : B → C a} {g : B → C a'} - {p : a = a'} (r : Π(b : B), f b =[p] g b) : f =[p] g := - pi_pathover_constant r - - definition arrow_pathover_constant_right' {B : A → Type} {C : Type} - {f : B a → C} {g : B a' → C} {p : a = a'} - (r : Π⦃b : B a⦄ ⦃b' : B a'⦄ (q : b =[p] b'), f b = g b') : f =[p] g := - arrow_pathover (λb b' q, pathover_of_eq (r q)) - - definition arrow_pathover_constant_right {B : A → Type} {C : Type} {f : B a → C} - {g : B a' → C} {p : a = a'} (r : Π(b : B a), f b = g (p ▸ b)) : f =[p] g := - arrow_pathover_left (λb, pathover_of_eq (r b)) - - /- a lemma used for the flattening lemma -/ - definition apo011_arrow_pathover_constant_right {f : D a → A'} {g : D a' → A'} {p : a = a'} - {q : d =[p] d'} (r : Π(d : D a), f d = g (p ▸ d)) - : eq_of_pathover (apo11 (arrow_pathover_constant_right r) q) = r d ⬝ ap g (tr_eq_of_pathover q) - := - begin - induction q, esimp at r, - eapply homotopy.rec_on r, clear r, esimp, intro r, induction r, esimp, - esimp [arrow_pathover_constant_right, arrow_pathover_left], - rewrite [eq_of_homotopy_idp] - end - - - /- - The fact that the arrow type preserves truncation level is a direct consequence - of the fact that pi's preserve truncation level - -/ - - definition is_trunc_arrow (B : Type) (n : trunc_index) [H : is_trunc n B] : is_trunc n (A → B) := - _ - -end pi diff --git a/hott/types/arrow_2.hlean b/hott/types/arrow_2.hlean deleted file mode 100644 index 148a431fd8..0000000000 --- a/hott/types/arrow_2.hlean +++ /dev/null @@ -1,111 +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 ..function - -open eq is_equiv function - -namespace arrow - - structure arrow := - (dom : Type) - (cod : Type) - (arrow : dom → cod) - - abbreviation dom [unfold 2] := @arrow.dom - abbreviation cod [unfold 2] := @arrow.cod - - definition arrow_of_fn {A B : Type} (f : A → B) : arrow := - arrow.mk A B f - - structure morphism (A B : Type) := - (mor : A → B) - - definition morphism_of_arrow [coercion] (f : arrow) : morphism (dom f) (cod f) := - morphism.mk (arrow.arrow f) - - attribute morphism.mor [coercion] - - structure arrow_hom (f g : arrow) := - (on_dom : dom f → dom g) - (on_cod : cod f → cod g) - (commute : Π(x : dom f), g (on_dom x) = on_cod (f x)) - - abbreviation on_dom [unfold 2] := @arrow_hom.on_dom - abbreviation on_cod [unfold 2] := @arrow_hom.on_cod - abbreviation commute [unfold 2] := @arrow_hom.commute - - variables {f g : arrow} - - definition on_fiber [reducible] (r : arrow_hom f g) (y : cod f) - : fiber f y → fiber g (on_cod r y) := - fiber.rec (λx p, fiber.mk (on_dom r x) (commute r x ⬝ ap (on_cod r) p)) - - structure is_retraction [class] (r : arrow_hom f g) : Type := - (sect : arrow_hom g f) - (right_inverse_dom : Π(a : dom g), on_dom r (on_dom sect a) = a) - (right_inverse_cod : Π(b : cod g), on_cod r (on_cod sect b) = b) - (cohere : Π(a : dom g), commute r (on_dom sect a) ⬝ ap (on_cod r) (commute sect a) - = ap g (right_inverse_dom a) ⬝ (right_inverse_cod (g a))⁻¹) - - definition retraction_on_fiber [reducible] (r : arrow_hom f g) [H : is_retraction r] - (b : cod g) : fiber f (on_cod (is_retraction.sect r) b) → fiber g b := - fiber.rec (λx q, fiber.mk (on_dom r x) (commute r x ⬝ ap (on_cod r) q ⬝ is_retraction.right_inverse_cod r b)) - - definition retraction_on_fiber_right_inverse' (r : arrow_hom f g) [H : is_retraction r] - (a : dom g) (b : cod g) (p : g a = b) - : retraction_on_fiber r b (on_fiber (is_retraction.sect r) b (fiber.mk a p)) = fiber.mk a p := - begin - induction p, unfold on_fiber, unfold retraction_on_fiber, - apply @fiber.fiber_eq _ _ g (g a) - (fiber.mk - (on_dom r (on_dom (is_retraction.sect r) a)) - (commute r (on_dom (is_retraction.sect r) a) - ⬝ ap (on_cod r) (commute (is_retraction.sect r) a) - ⬝ is_retraction.right_inverse_cod r (g a))) - (fiber.mk a (refl (g a))) - (is_retraction.right_inverse_dom r a), -- everything but this field should be inferred - unfold fiber.point_eq, - rewrite [is_retraction.cohere r a], - apply inv_con_cancel_right - end - - definition retraction_on_fiber_right_inverse (r : arrow_hom f g) [H : is_retraction r] - : Π(b : cod g), Π(z : fiber g b), retraction_on_fiber r b (on_fiber (is_retraction.sect r) b z) = z := - λb, fiber.rec (λa p, retraction_on_fiber_right_inverse' r a b p) - - -- Lemma 4.7.3 - definition retraction_on_fiber_is_retraction [instance] (r : arrow_hom f g) [H : is_retraction r] - (b : cod g) : _root_.is_retraction (retraction_on_fiber r b) := - _root_.is_retraction.mk (on_fiber (is_retraction.sect r) b) (retraction_on_fiber_right_inverse r b) - - -- Theorem 4.7.4 - definition retract_of_equivalence_is_equivalence (r : arrow_hom f g) [H : is_retraction r] - [K : is_equiv f] : is_equiv g := - begin - apply @is_equiv_of_is_contr_fun _ _ g, - intro b, - apply is_contr_retract (retraction_on_fiber r b), - exact is_contr_fun_of_is_equiv f (on_cod (is_retraction.sect r) b) - end - -end arrow - -namespace arrow - variables {A B : Type} {f g : A → B} (p : f ~ g) - - definition arrow_hom_of_homotopy : arrow_hom (arrow_of_fn f) (arrow_of_fn g) := - arrow_hom.mk id id (λx, (p x)⁻¹) - - definition is_retraction_arrow_hom_of_homotopy [instance] - : is_retraction (arrow_hom_of_homotopy p) := - is_retraction.mk - (arrow_hom_of_homotopy (λx, (p x)⁻¹)) - (λa, idp) - (λb, idp) - (λa, con_eq_of_eq_inv_con (ap_id _)) - -end arrow diff --git a/hott/types/bool.hlean b/hott/types/bool.hlean deleted file mode 100644 index f11b82261d..0000000000 --- a/hott/types/bool.hlean +++ /dev/null @@ -1,173 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura, Floris van Doorn - -Partially ported from the standard library --/ - -open eq eq.ops decidable - -namespace bool - local attribute bor [reducible] - local attribute band [reducible] - - theorem dichotomy (b : bool) : b = ff ⊎ b = tt := - bool.cases_on b (sum.inl rfl) (sum.inr rfl) - - theorem cond_ff {A : Type} (t e : A) : cond ff t e = e := - rfl - - theorem cond_tt {A : Type} (t e : A) : cond tt t e = t := - rfl - - theorem eq_tt_of_ne_ff : Π {a : bool}, a ≠ ff → a = tt - | @eq_tt_of_ne_ff tt H := rfl - | @eq_tt_of_ne_ff ff H := absurd rfl H - - theorem eq_ff_of_ne_tt : Π {a : bool}, a ≠ tt → a = ff - | @eq_ff_of_ne_tt tt H := absurd rfl H - | @eq_ff_of_ne_tt ff H := rfl - - theorem absurd_of_eq_ff_of_eq_tt {B : Type} {a : bool} (H₁ : a = ff) (H₂ : a = tt) : B := - absurd (H₁⁻¹ ⬝ H₂) ff_ne_tt - - theorem tt_bor (a : bool) : bor tt a = tt := - rfl - - notation a || b := bor a b - - theorem bor_tt (a : bool) : a || tt = tt := - bool.cases_on a rfl rfl - - theorem ff_bor (a : bool) : ff || a = a := - bool.cases_on a rfl rfl - - theorem bor_ff (a : bool) : a || ff = a := - bool.cases_on a rfl rfl - - theorem bor_self (a : bool) : a || a = a := - bool.cases_on a rfl rfl - - theorem bor.comm (a b : bool) : a || b = b || a := - by cases a; repeat (cases b | reflexivity) - - theorem bor.assoc (a b c : bool) : (a || b) || c = a || (b || c) := - match a with - | ff := by rewrite *ff_bor - | tt := by rewrite *tt_bor - end - - theorem or_of_bor_eq {a b : bool} : a || b = tt → a = tt ⊎ b = tt := - bool.rec_on a - (suppose ff || b = tt, - have b = tt, from !ff_bor ▸ this, - sum.inr this) - (suppose tt || b = tt, - sum.inl rfl) - - theorem bor_inl {a b : bool} (H : a = tt) : a || b = tt := - by rewrite H - - theorem bor_inr {a b : bool} (H : b = tt) : a || b = tt := - bool.rec_on a (by rewrite H) (by rewrite H) - - theorem ff_band (a : bool) : ff && a = ff := - rfl - - theorem tt_band (a : bool) : tt && a = a := - bool.cases_on a rfl rfl - - theorem band_ff (a : bool) : a && ff = ff := - bool.cases_on a rfl rfl - - theorem band_tt (a : bool) : a && tt = a := - bool.cases_on a rfl rfl - - theorem band_self (a : bool) : a && a = a := - bool.cases_on a rfl rfl - - theorem band.comm (a b : bool) : a && b = b && a := - bool.cases_on a - (bool.cases_on b rfl rfl) - (bool.cases_on b rfl rfl) - - theorem band.assoc (a b c : bool) : (a && b) && c = a && (b && c) := - match a with - | ff := by rewrite *ff_band - | tt := by rewrite *tt_band - end - - theorem band_elim_left {a b : bool} (H : a && b = tt) : a = tt := - sum.elim (dichotomy a) - (suppose a = ff, - absurd - (calc ff = ff && b : ff_band - ... = a && b : this - ... = tt : H) - ff_ne_tt) - (suppose a = tt, this) - - theorem band_intro {a b : bool} (H₁ : a = tt) (H₂ : b = tt) : a && b = tt := - by rewrite [H₁, H₂] - - theorem band_elim_right {a b : bool} (H : a && b = tt) : b = tt := - band_elim_left (!band.comm ⬝ H) - - theorem bnot_bnot (a : bool) : bnot (bnot a) = a := - bool.cases_on a rfl rfl - - theorem bnot_empty : bnot ff = tt := - rfl - - theorem bnot_unit : bnot tt = ff := - rfl - - theorem eq_tt_of_bnot_eq_ff {a : bool} : bnot a = ff → a = tt := - bool.cases_on a (by contradiction) (λ h, rfl) - - theorem eq_ff_of_bnot_eq_tt {a : bool} : bnot a = tt → a = ff := - bool.cases_on a (λ h, rfl) (by contradiction) - - definition bxor (x:bool) (y:bool) := cond x (bnot y) y - - /- HoTT-related stuff -/ - open is_equiv equiv function is_trunc option unit decidable - - - definition is_equiv_bnot [constructor] [instance] [priority 500] : is_equiv bnot := - begin - fapply is_equiv.mk, - exact bnot, - all_goals (intro b;cases b), do 6 reflexivity - -- all_goals (focus (intro b;cases b;all_goals reflexivity)), - end - - definition bnot_ne : Π(b : bool), bnot b ≠ b - | bnot_ne tt := ff_ne_tt - | bnot_ne ff := ne.symm ff_ne_tt - - definition equiv_bnot [constructor] : bool ≃ bool := equiv.mk bnot _ - definition eq_bnot : bool = bool := ua equiv_bnot - - definition eq_bnot_ne_idp : eq_bnot ≠ idp := - assume H : eq_bnot = idp, - have H2 : bnot = id, from !cast_ua_fn⁻¹ ⬝ ap cast H, - absurd (ap10 H2 tt) ff_ne_tt - - theorem is_set_bool : is_set bool := _ - theorem not_is_prop_bool_eq_bool : ¬ is_prop (bool = bool) := - λ H, eq_bnot_ne_idp !is_prop.elim - - definition bool_equiv_option_unit [constructor] : bool ≃ option unit := - begin - fapply equiv.MK, - { intro b, cases b, exact none, exact some star}, - { intro u, cases u, exact ff, exact tt}, - { intro u, cases u with u, reflexivity, cases u, reflexivity}, - { intro b, cases b, reflexivity, reflexivity}, - end - - definition tbool [constructor] : Set := trunctype.mk bool _ - -end bool diff --git a/hott/types/default.hlean b/hott/types/default.hlean deleted file mode 100644 index cc59ea54bc..0000000000 --- a/hott/types/default.hlean +++ /dev/null @@ -1,9 +0,0 @@ -/- -Copyright (c) 2015 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn --/ - -import .bool .prod .sigma .pi .arrow .pointed .fiber -import .nat .int -import .eq .equiv .trunc diff --git a/hott/types/eq.hlean b/hott/types/eq.hlean deleted file mode 100644 index bb6f04be5d..0000000000 --- a/hott/types/eq.hlean +++ /dev/null @@ -1,497 +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 - -Partially ported from Coq HoTT -Theorems about path types (identity types) --/ - -import types.sigma -open eq sigma sigma.ops equiv is_equiv is_trunc - --- TODO: Rename transport_eq_... and pathover_eq_... to eq_transport_... and eq_pathover_... - -namespace eq - /- Path spaces -/ - section - variables {A B : Type} {a a₁ a₂ a₃ a₄ a' : A} {b b1 b2 : B} {f g : A → B} {h : B → A} - {p p' p'' : a₁ = a₂} - - /- The path spaces of a path space are not, of course, determined; they are just the - higher-dimensional structure of the original space. -/ - - /- some lemmas about whiskering or other higher paths -/ - - theorem whisker_left_con_right (p : a₁ = a₂) {q q' q'' : a₂ = a₃} (r : q = q') (s : q' = q'') - : whisker_left p (r ⬝ s) = whisker_left p r ⬝ whisker_left p s := - begin - induction p, induction r, induction s, reflexivity - end - - theorem whisker_right_con_right (q : a₂ = a₃) (r : p = p') (s : p' = p'') - : whisker_right (r ⬝ s) q = whisker_right r q ⬝ whisker_right s q := - begin - induction q, induction r, induction s, reflexivity - end - - theorem whisker_left_con_left (p : a₁ = a₂) (p' : a₂ = a₃) {q q' : a₃ = a₄} (r : q = q') - : whisker_left (p ⬝ p') r = !con.assoc ⬝ whisker_left p (whisker_left p' r) ⬝ !con.assoc' := - begin - induction p', induction p, induction r, induction q, reflexivity - end - - theorem whisker_right_con_left {p p' : a₁ = a₂} (q : a₂ = a₃) (q' : a₃ = a₄) (r : p = p') - : whisker_right r (q ⬝ q') = !con.assoc' ⬝ whisker_right (whisker_right r q) q' ⬝ !con.assoc := - begin - induction q', induction q, induction r, induction p, reflexivity - end - - theorem whisker_left_inv_left (p : a₂ = a₁) {q q' : a₂ = a₃} (r : q = q') - : !con_inv_cancel_left⁻¹ ⬝ whisker_left p (whisker_left p⁻¹ r) ⬝ !con_inv_cancel_left = r := - begin - induction p, induction r, induction q, reflexivity - end - - theorem whisker_left_inv (p : a₁ = a₂) {q q' : a₂ = a₃} (r : q = q') - : whisker_left p r⁻¹ = (whisker_left p r)⁻¹ := - by induction r; reflexivity - - theorem whisker_right_inv {p p' : a₁ = a₂} (q : a₂ = a₃) (r : p = p') - : whisker_right r⁻¹ q = (whisker_right r q)⁻¹ := - by induction r; reflexivity - - theorem ap_eq_ap10 {f g : A → B} (p : f = g) (a : A) : ap (λh, h a) p = ap10 p a := - by induction p;reflexivity - - theorem inverse2_right_inv (r : p = p') : r ◾ inverse2 r ⬝ con.right_inv p' = con.right_inv p := - by induction r;induction p;reflexivity - - theorem inverse2_left_inv (r : p = p') : inverse2 r ◾ r ⬝ con.left_inv p' = con.left_inv p := - by induction r;induction p;reflexivity - - theorem ap_con_right_inv (f : A → B) (p : a₁ = a₂) - : ap_con f p p⁻¹ ⬝ whisker_left _ (ap_inv f p) ⬝ con.right_inv (ap f p) - = ap (ap f) (con.right_inv p) := - by induction p;reflexivity - - theorem ap_con_left_inv (f : A → B) (p : a₁ = a₂) - : ap_con f p⁻¹ p ⬝ whisker_right (ap_inv f p) _ ⬝ con.left_inv (ap f p) - = ap (ap f) (con.left_inv p) := - by induction p;reflexivity - - theorem idp_con_whisker_left {q q' : a₂ = a₃} (r : q = q') : - !idp_con⁻¹ ⬝ whisker_left idp r = r ⬝ !idp_con⁻¹ := - by induction r;induction q;reflexivity - - theorem whisker_left_idp_con {q q' : a₂ = a₃} (r : q = q') : - whisker_left idp r ⬝ !idp_con = !idp_con ⬝ r := - by induction r;induction q;reflexivity - - theorem idp_con_idp {p : a = a} (q : p = idp) : idp_con p ⬝ q = ap (λp, idp ⬝ p) q := - by cases q;reflexivity - - definition ap_is_constant [unfold 8] {A B : Type} {f : A → B} {b : B} (p : Πx, f x = b) - {x y : A} (q : x = y) : ap f q = p x ⬝ (p y)⁻¹ := - by induction q;exact !con.right_inv⁻¹ - - definition inv2_inv {p q : a = a'} (r : p = q) : inverse2 r⁻¹ = (inverse2 r)⁻¹ := - by induction r;reflexivity - - definition inv2_con {p p' p'' : a = a'} (r : p = p') (r' : p' = p'') - : inverse2 (r ⬝ r') = inverse2 r ⬝ inverse2 r' := - by induction r';induction r;reflexivity - - definition con2_inv {p₁ q₁ : a₁ = a₂} {p₂ q₂ : a₂ = a₃} (r₁ : p₁ = q₁) (r₂ : p₂ = q₂) - : (r₁ ◾ r₂)⁻¹ = r₁⁻¹ ◾ r₂⁻¹ := - by induction r₁;induction r₂;reflexivity - - theorem eq_con_inv_of_con_eq_whisker_left {A : Type} {a a₂ a₃ : A} - {p : a = a₂} {q q' : a₂ = a₃} {r : a = a₃} (s' : q = q') (s : p ⬝ q' = r) : - eq_con_inv_of_con_eq (whisker_left p s' ⬝ s) - = eq_con_inv_of_con_eq s ⬝ whisker_left r (inverse2 s')⁻¹ := - by induction s';induction q;induction s;reflexivity - - theorem right_inv_eq_idp {A : Type} {a : A} {p : a = a} (r : p = idpath a) : - con.right_inv p = r ◾ inverse2 r := - by cases r;reflexivity - - /- Transporting in path spaces. - - There are potentially a lot of these lemmas, so we adopt a uniform naming scheme: - - - `l` means the left endpoint varies - - `r` means the right endpoint varies - - `F` means application of a function to that (varying) endpoint. - -/ - - definition transport_eq_l (p : a₁ = a₂) (q : a₁ = a₃) - : transport (λx, x = a₃) p q = p⁻¹ ⬝ q := - by induction p; induction q; reflexivity - - definition transport_eq_r (p : a₂ = a₃) (q : a₁ = a₂) - : transport (λx, a₁ = x) p q = q ⬝ p := - by induction p; induction q; reflexivity - - definition transport_eq_lr (p : a₁ = a₂) (q : a₁ = a₁) - : transport (λx, x = x) p q = p⁻¹ ⬝ q ⬝ p := - by induction p; rewrite [▸*,idp_con] - - definition transport_eq_Fl (p : a₁ = a₂) (q : f a₁ = b) - : transport (λx, f x = b) p q = (ap f p)⁻¹ ⬝ q := - by induction p; induction q; reflexivity - - definition transport_eq_Fr (p : a₁ = a₂) (q : b = f a₁) - : transport (λx, b = f x) p q = q ⬝ (ap f p) := - by induction p; reflexivity - - definition transport_eq_FlFr (p : a₁ = a₂) (q : f a₁ = g a₁) - : transport (λx, f x = g x) p q = (ap f p)⁻¹ ⬝ q ⬝ (ap g p) := - by induction p; rewrite [▸*,idp_con] - - definition transport_eq_FlFr_D {B : A → Type} {f g : Πa, B a} - (p : a₁ = a₂) (q : f a₁ = g a₁) - : transport (λx, f x = g x) p q = (apd f p)⁻¹ ⬝ ap (transport B p) q ⬝ (apd g p) := - by induction p; rewrite [▸*,idp_con,ap_id] - - definition transport_eq_FFlr (p : a₁ = a₂) (q : h (f a₁) = a₁) - : transport (λx, h (f x) = x) p q = (ap h (ap f p))⁻¹ ⬝ q ⬝ p := - by induction p; rewrite [▸*,idp_con] - - definition transport_eq_lFFr (p : a₁ = a₂) (q : a₁ = h (f a₁)) - : transport (λx, x = h (f x)) p q = p⁻¹ ⬝ q ⬝ (ap h (ap f p)) := - by induction p; rewrite [▸*,idp_con] - - /- Pathovers -/ - - -- In the comment we give the fibration of the pathover - - -- we should probably try to do everything just with pathover_eq (defined in cubical.square), - -- the following definitions may be removed in future. - - definition pathover_eq_l (p : a₁ = a₂) (q : a₁ = a₃) : q =[p] p⁻¹ ⬝ q := /-(λx, x = a₃)-/ - by induction p; induction q; exact idpo - - definition pathover_eq_r (p : a₂ = a₃) (q : a₁ = a₂) : q =[p] q ⬝ p := /-(λx, a₁ = x)-/ - by induction p; induction q; exact idpo - - definition pathover_eq_lr (p : a₁ = a₂) (q : a₁ = a₁) : q =[p] p⁻¹ ⬝ q ⬝ p := /-(λx, x = x)-/ - by induction p; rewrite [▸*,idp_con]; exact idpo - - definition pathover_eq_Fl (p : a₁ = a₂) (q : f a₁ = b) : q =[p] (ap f p)⁻¹ ⬝ q := /-(λx, f x = b)-/ - by induction p; induction q; exact idpo - - definition pathover_eq_Fr (p : a₁ = a₂) (q : b = f a₁) : q =[p] q ⬝ (ap f p) := /-(λx, b = f x)-/ - by induction p; exact idpo - - definition pathover_eq_FlFr (p : a₁ = a₂) (q : f a₁ = g a₁) : q =[p] (ap f p)⁻¹ ⬝ q ⬝ (ap g p) := - /-(λx, f x = g x)-/ - by induction p; rewrite [▸*,idp_con]; exact idpo - - definition pathover_eq_FlFr_D {B : A → Type} {f g : Πa, B a} (p : a₁ = a₂) (q : f a₁ = g a₁) - : q =[p] (apd f p)⁻¹ ⬝ ap (transport B p) q ⬝ (apd g p) := /-(λx, f x = g x)-/ - by induction p; rewrite [▸*,idp_con,ap_id];exact idpo - - definition pathover_eq_FFlr (p : a₁ = a₂) (q : h (f a₁) = a₁) : q =[p] (ap h (ap f p))⁻¹ ⬝ q ⬝ p := - /-(λx, h (f x) = x)-/ - by induction p; rewrite [▸*,idp_con];exact idpo - - definition pathover_eq_lFFr (p : a₁ = a₂) (q : a₁ = h (f a₁)) : q =[p] p⁻¹ ⬝ q ⬝ (ap h (ap f p)) := - /-(λx, x = h (f x))-/ - by induction p; rewrite [▸*,idp_con];exact idpo - - definition pathover_eq_r_idp (p : a₁ = a₂) : idp =[p] p := /-(λx, a₁ = x)-/ - by induction p; exact idpo - - definition pathover_eq_l_idp (p : a₁ = a₂) : idp =[p] p⁻¹ := /-(λx, x = a₁)-/ - by induction p; exact idpo - - definition pathover_eq_l_idp' (p : a₁ = a₂) : idp =[p⁻¹] p := /-(λx, x = a₂)-/ - by induction p; exact idpo - - -- The Functorial action of paths is [ap]. - - /- Equivalences between path spaces -/ - - /- [ap_closed] is in init.equiv -/ - - definition equiv_ap (f : A → B) [H : is_equiv f] (a₁ a₂ : A) - : (a₁ = a₂) ≃ (f a₁ = f a₂) := - equiv.mk (ap f) _ - - /- Path operations are equivalences -/ - - definition is_equiv_eq_inverse (a₁ a₂ : A) : is_equiv (inverse : a₁ = a₂ → a₂ = a₁) := - is_equiv.mk inverse inverse inv_inv inv_inv (λp, eq.rec_on p idp) - local attribute is_equiv_eq_inverse [instance] - - definition eq_equiv_eq_symm (a₁ a₂ : A) : (a₁ = a₂) ≃ (a₂ = a₁) := - equiv.mk inverse _ - - definition is_equiv_concat_left [constructor] [instance] (p : a₁ = a₂) (a₃ : A) - : is_equiv (concat p : a₂ = a₃ → a₁ = a₃) := - is_equiv.mk (concat p) (concat p⁻¹) - (con_inv_cancel_left p) - (inv_con_cancel_left p) - abstract (λq, by induction p;induction q;reflexivity) end - local attribute is_equiv_concat_left [instance] - - definition equiv_eq_closed_left [constructor] (a₃ : A) (p : a₁ = a₂) : (a₁ = a₃) ≃ (a₂ = a₃) := - equiv.mk (concat p⁻¹) _ - - definition is_equiv_concat_right [constructor] [instance] (p : a₂ = a₃) (a₁ : A) - : is_equiv (λq : a₁ = a₂, q ⬝ p) := - is_equiv.mk (λq, q ⬝ p) (λq, q ⬝ p⁻¹) - (λq, inv_con_cancel_right q p) - (λq, con_inv_cancel_right q p) - (λq, by induction p;induction q;reflexivity) - local attribute is_equiv_concat_right [instance] - - definition equiv_eq_closed_right [constructor] (a₁ : A) (p : a₂ = a₃) : (a₁ = a₂) ≃ (a₁ = a₃) := - equiv.mk (λq, q ⬝ p) _ - - definition eq_equiv_eq_closed [constructor] (p : a₁ = a₂) (q : a₃ = a₄) : (a₁ = a₃) ≃ (a₂ = a₄) := - equiv.trans (equiv_eq_closed_left a₃ p) (equiv_eq_closed_right a₂ q) - - definition is_equiv_whisker_left [constructor] (p : a₁ = a₂) (q r : a₂ = a₃) - : is_equiv (whisker_left p : q = r → p ⬝ q = p ⬝ r) := - begin - fapply adjointify, - {intro s, apply (!cancel_left s)}, - {intro s, - apply concat, {apply whisker_left_con_right}, - apply concat, rotate_left 1, apply (whisker_left_inv_left p s), - apply concat2, - {apply concat, {apply whisker_left_con_right}, - apply concat2, - {induction p, induction q, reflexivity}, - {reflexivity}}, - {induction p, induction r, reflexivity}}, - {intro s, induction s, induction q, induction p, reflexivity} - end - - definition eq_equiv_con_eq_con_left [constructor] (p : a₁ = a₂) (q r : a₂ = a₃) - : (q = r) ≃ (p ⬝ q = p ⬝ r) := - equiv.mk _ !is_equiv_whisker_left - - definition is_equiv_whisker_right [constructor] {p q : a₁ = a₂} (r : a₂ = a₃) - : is_equiv (λs, whisker_right s r : p = q → p ⬝ r = q ⬝ r) := - begin - fapply adjointify, - {intro s, apply (!cancel_right s)}, - {intro s, induction r, cases s, induction q, reflexivity}, - {intro s, induction s, induction r, induction p, reflexivity} - end - - definition eq_equiv_con_eq_con_right [constructor] (p q : a₁ = a₂) (r : a₂ = a₃) - : (p = q) ≃ (p ⬝ r = q ⬝ r) := - equiv.mk _ !is_equiv_whisker_right - - /- - The following proofs can be simplified a bit by concatenating previous equivalences. - However, these proofs have the advantage that the inverse is definitionally equal to - what we would expect - -/ - definition is_equiv_con_eq_of_eq_inv_con [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (con_eq_of_eq_inv_con : p = r⁻¹ ⬝ q → r ⬝ p = q) := - begin - fapply adjointify, - { apply eq_inv_con_of_con_eq}, - { intro s, induction r, rewrite [↑[con_eq_of_eq_inv_con,eq_inv_con_of_con_eq], - con.assoc,con.assoc,con.left_inv,▸*,-con.assoc,con.right_inv,▸* at *,idp_con s]}, - { intro s, induction r, rewrite [↑[con_eq_of_eq_inv_con,eq_inv_con_of_con_eq], - con.assoc,con.assoc,con.right_inv,▸*,-con.assoc,con.left_inv,▸* at *,idp_con s] }, - end - - definition eq_inv_con_equiv_con_eq [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : (p = r⁻¹ ⬝ q) ≃ (r ⬝ p = q) := - equiv.mk _ !is_equiv_con_eq_of_eq_inv_con - - definition is_equiv_con_eq_of_eq_con_inv [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (con_eq_of_eq_con_inv : r = q ⬝ p⁻¹ → r ⬝ p = q) := - begin - fapply adjointify, - { apply eq_con_inv_of_con_eq}, - { intro s, induction p, rewrite [↑[con_eq_of_eq_con_inv,eq_con_inv_of_con_eq]]}, - { intro s, induction p, rewrite [↑[con_eq_of_eq_con_inv,eq_con_inv_of_con_eq]] }, - end - - definition eq_con_inv_equiv_con_eq [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : (r = q ⬝ p⁻¹) ≃ (r ⬝ p = q) := - equiv.mk _ !is_equiv_con_eq_of_eq_con_inv - - definition is_equiv_inv_con_eq_of_eq_con [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₁ = a₂) - : is_equiv (inv_con_eq_of_eq_con : p = r ⬝ q → r⁻¹ ⬝ p = q) := - begin - fapply adjointify, - { apply eq_con_of_inv_con_eq}, - { intro s, induction r, rewrite [↑[inv_con_eq_of_eq_con,eq_con_of_inv_con_eq], - con.assoc,con.assoc,con.left_inv,▸*,-con.assoc,con.right_inv,▸* at *,idp_con s]}, - { intro s, induction r, rewrite [↑[inv_con_eq_of_eq_con,eq_con_of_inv_con_eq], - con.assoc,con.assoc,con.right_inv,▸*,-con.assoc,con.left_inv,▸* at *,idp_con s] }, - end - - definition eq_con_equiv_inv_con_eq [constructor] (p : a₁ = a₃) (q : a₂ = a₃) (r : a₁ = a₂) - : (p = r ⬝ q) ≃ (r⁻¹ ⬝ p = q) := - equiv.mk _ !is_equiv_inv_con_eq_of_eq_con - - definition is_equiv_con_inv_eq_of_eq_con [constructor] (p : a₃ = a₁) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (con_inv_eq_of_eq_con : r = q ⬝ p → r ⬝ p⁻¹ = q) := - begin - fapply adjointify, - { apply eq_con_of_con_inv_eq}, - { intro s, induction p, rewrite [↑[con_inv_eq_of_eq_con,eq_con_of_con_inv_eq]]}, - { intro s, induction p, rewrite [↑[con_inv_eq_of_eq_con,eq_con_of_con_inv_eq]] }, - end - - definition eq_con_equiv_con_inv_eq (p : a₃ = a₁) (q : a₂ = a₃) (r : a₂ = a₁) - : (r = q ⬝ p) ≃ (r ⬝ p⁻¹ = q) := - equiv.mk _ !is_equiv_con_inv_eq_of_eq_con - - local attribute is_equiv_inv_con_eq_of_eq_con - is_equiv_con_inv_eq_of_eq_con - is_equiv_con_eq_of_eq_con_inv - is_equiv_con_eq_of_eq_inv_con [instance] - - definition is_equiv_eq_con_of_inv_con_eq (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (eq_con_of_inv_con_eq : r⁻¹ ⬝ q = p → q = r ⬝ p) := - is_equiv_inv inv_con_eq_of_eq_con - - definition is_equiv_eq_con_of_con_inv_eq (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (eq_con_of_con_inv_eq : q ⬝ p⁻¹ = r → q = r ⬝ p) := - is_equiv_inv con_inv_eq_of_eq_con - - definition is_equiv_eq_con_inv_of_con_eq (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (eq_con_inv_of_con_eq : r ⬝ p = q → r = q ⬝ p⁻¹) := - is_equiv_inv con_eq_of_eq_con_inv - - definition is_equiv_eq_inv_con_of_con_eq (p : a₁ = a₃) (q : a₂ = a₃) (r : a₂ = a₁) - : is_equiv (eq_inv_con_of_con_eq : r ⬝ p = q → p = r⁻¹ ⬝ q) := - is_equiv_inv con_eq_of_eq_inv_con - - definition is_equiv_con_inv_eq_idp [constructor] (p q : a₁ = a₂) - : is_equiv (con_inv_eq_idp : p = q → p ⬝ q⁻¹ = idp) := - begin - fapply adjointify, - { apply eq_of_con_inv_eq_idp}, - { intro s, induction q, esimp at *, cases s, reflexivity}, - { intro s, induction s, induction p, reflexivity}, - end - - definition is_equiv_inv_con_eq_idp [constructor] (p q : a₁ = a₂) - : is_equiv (inv_con_eq_idp : p = q → q⁻¹ ⬝ p = idp) := - begin - fapply adjointify, - { apply eq_of_inv_con_eq_idp}, - { intro s, induction q, esimp [eq_of_inv_con_eq_idp] at *, - eapply is_equiv_rect (eq_equiv_con_eq_con_left idp p idp), clear s, - intro s, cases s, reflexivity}, - { intro s, induction s, induction p, reflexivity}, - end - - definition eq_equiv_con_inv_eq_idp [constructor] (p q : a₁ = a₂) : (p = q) ≃ (p ⬝ q⁻¹ = idp) := - equiv.mk _ !is_equiv_con_inv_eq_idp - - definition eq_equiv_inv_con_eq_idp [constructor] (p q : a₁ = a₂) : (p = q) ≃ (q⁻¹ ⬝ p = idp) := - equiv.mk _ !is_equiv_inv_con_eq_idp - - /- Pathover Equivalences -/ - - definition pathover_eq_equiv_l (p : a₁ = a₂) (q : a₁ = a₃) (r : a₂ = a₃) : q =[p] r ≃ q = p ⬝ r := - /-(λx, x = a₃)-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - definition pathover_eq_equiv_r (p : a₂ = a₃) (q : a₁ = a₂) (r : a₁ = a₃) : q =[p] r ≃ q ⬝ p = r := - /-(λx, a₁ = x)-/ - by induction p; apply pathover_idp - - definition pathover_eq_equiv_lr (p : a₁ = a₂) (q : a₁ = a₁) (r : a₂ = a₂) - : q =[p] r ≃ q ⬝ p = p ⬝ r := /-(λx, x = x)-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - definition pathover_eq_equiv_Fl (p : a₁ = a₂) (q : f a₁ = b) (r : f a₂ = b) - : q =[p] r ≃ q = ap f p ⬝ r := /-(λx, f x = b)-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - definition pathover_eq_equiv_Fr (p : a₁ = a₂) (q : b = f a₁) (r : b = f a₂) - : q =[p] r ≃ q ⬝ ap f p = r := /-(λx, b = f x)-/ - by induction p; apply pathover_idp - - definition pathover_eq_equiv_FlFr (p : a₁ = a₂) (q : f a₁ = g a₁) (r : f a₂ = g a₂) - : q =[p] r ≃ q ⬝ ap g p = ap f p ⬝ r := /-(λx, f x = g x)-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - definition pathover_eq_equiv_FFlr (p : a₁ = a₂) (q : h (f a₁) = a₁) (r : h (f a₂) = a₂) - : q =[p] r ≃ q ⬝ p = ap h (ap f p) ⬝ r := - /-(λx, h (f x) = x)-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - definition pathover_eq_equiv_lFFr (p : a₁ = a₂) (q : a₁ = h (f a₁)) (r : a₂ = h (f a₂)) - : q =[p] r ≃ q ⬝ ap h (ap f p) = p ⬝ r := - /-(λx, x = h (f x))-/ - by induction p; exact !pathover_idp ⬝e !equiv_eq_closed_right !idp_con⁻¹ - - -- a lot of this library still needs to be ported from Coq HoTT - - -- the behavior of equality in other types is described in the corresponding type files - - -- encode decode method - - open is_trunc - definition encode_decode_method' (a₀ a : A) (code : A → Type) (c₀ : code a₀) - (decode : Π(a : A) (c : code a), a₀ = a) - (encode_decode : Π(a : A) (c : code a), c₀ =[decode a c] c) - (decode_encode : decode a₀ c₀ = idp) : (a₀ = a) ≃ code a := - begin - fapply equiv.MK, - { intro p, exact p ▸ c₀}, - { apply decode}, - { intro c, apply tr_eq_of_pathover, apply encode_decode}, - { intro p, induction p, apply decode_encode}, - end - - end - - section - parameters {A : Type} (a₀ : A) (code : A → Type) (H : is_contr (Σa, code a)) - (p : (center (Σa, code a)).1 = a₀) - include p - definition encode {a : A} (q : a₀ = a) : code a := - (p ⬝ q) ▸ (center (Σa, code a)).2 - - definition decode' {a : A} (c : code a) : a₀ = a := - (is_prop.elim ⟨a₀, encode idp⟩ ⟨a, c⟩)..1 - - definition decode {a : A} (c : code a) : a₀ = a := - (decode' (encode idp))⁻¹ ⬝ decode' c - - definition total_space_method (a : A) : (a₀ = a) ≃ code a := - begin - fapply equiv.MK, - { exact encode}, - { exact decode}, - { intro c, - unfold [encode, decode, decode'], - induction p, esimp, rewrite [is_prop_elim_self,▸*,+idp_con], apply tr_eq_of_pathover, - eapply @sigma.rec_on _ _ (λx, x.2 =[(is_prop.elim ⟨x.1, x.2⟩ ⟨a, c⟩)..1] c) - (center (sigma code)), -- BUG(?): induction fails - intro a c, apply eq_pr2}, - { intro q, induction q, esimp, apply con.left_inv, }, - end - end - - definition encode_decode_method {A : Type} (a₀ a : A) (code : A → Type) (c₀ : code a₀) - (decode : Π(a : A) (c : code a), a₀ = a) - (encode_decode : Π(a : A) (c : code a), c₀ =[decode a c] c) : (a₀ = a) ≃ code a := - begin - fapply total_space_method, - { fapply @is_contr.mk, - { exact ⟨a₀, c₀⟩}, - { intro p, fapply sigma_eq, - apply decode, exact p.2, - apply encode_decode}}, - { reflexivity} - end - - -end eq diff --git a/hott/types/equiv.hlean b/hott/types/equiv.hlean deleted file mode 100644 index a7f122714d..0000000000 --- a/hott/types/equiv.hlean +++ /dev/null @@ -1,202 +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 - -Ported from Coq HoTT -Theorems about the types equiv and is_equiv --/ - -import .fiber .arrow arity ..prop_trunc - -open eq is_trunc sigma sigma.ops pi fiber function equiv - -namespace is_equiv - variables {A B : Type} (f : A → B) [H : is_equiv f] - include H - /- is_equiv f is a mere proposition -/ - definition is_contr_fiber_of_is_equiv [instance] (b : B) : is_contr (fiber f b) := - is_contr.mk - (fiber.mk (f⁻¹ b) (right_inv f b)) - (λz, fiber.rec_on z (λa p, - fiber_eq ((ap f⁻¹ p)⁻¹ ⬝ left_inv f a) (calc - right_inv f b = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ ((ap (f ∘ f⁻¹) p) ⬝ right_inv f b) - : by rewrite inv_con_cancel_left - ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ (right_inv f (f a) ⬝ p) : by rewrite ap_con_eq_con - ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ (ap f (left_inv f a) ⬝ p) : by rewrite [adj f] - ... = (ap (f ∘ f⁻¹) p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p : by rewrite con.assoc - ... = (ap f (ap f⁻¹ p))⁻¹ ⬝ ap f (left_inv f a) ⬝ p : by rewrite ap_compose - ... = ap f (ap f⁻¹ p)⁻¹ ⬝ ap f (left_inv f a) ⬝ p : by rewrite ap_inv - ... = ap f ((ap f⁻¹ p)⁻¹ ⬝ left_inv f a) ⬝ p : by rewrite ap_con))) - - definition is_contr_right_inverse : is_contr (Σ(g : B → A), f ∘ g ~ id) := - begin - 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, - apply (to_is_equiv (arrow_equiv_arrow_right B (equiv.mk f H))), - end - - definition is_contr_right_coherence (u : Σ(g : B → A), f ∘ g ~ id) - : is_contr (Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) := - begin - fapply is_trunc_equiv_closed, - {apply equiv.symm, apply sigma_pi_equiv_pi_sigma}, - fapply is_trunc_equiv_closed, - {apply pi_equiv_pi_right, intro a, - apply (fiber_eq_equiv (fiber.mk (u.1 (f a)) (u.2 (f a))) (fiber.mk a idp))}, - end - - omit H - - protected definition sigma_char : (is_equiv f) ≃ - (Σ(g : B → A) (ε : f ∘ g ~ id) (η : g ∘ f ~ id), Π(a : A), ε (f a) = ap f (η a)) := - equiv.MK (λH, ⟨inv f, right_inv f, left_inv f, adj f⟩) - (λp, is_equiv.mk f p.1 p.2.1 p.2.2.1 p.2.2.2) - (λp, begin - induction p with p1 p2, - induction p2 with p21 p22, - induction p22 with p221 p222, - reflexivity - end) - (λH, by induction H; reflexivity) - - protected definition sigma_char' : (is_equiv f) ≃ - (Σ(u : Σ(g : B → A), f ∘ g ~ id), Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) := - calc - (is_equiv f) ≃ - (Σ(g : B → A) (ε : f ∘ g ~ id) (η : g ∘ f ~ id), Π(a : A), ε (f a) = ap f (η a)) - : is_equiv.sigma_char - ... ≃ (Σ(u : Σ(g : B → A), f ∘ g ~ id), Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a)) - : {sigma_assoc_equiv (λu, Σ(η : u.1 ∘ f ~ id), Π(a : A), u.2 (f a) = ap f (η a))} - - local attribute is_contr_right_inverse [instance] [priority 1600] - local attribute is_contr_right_coherence [instance] [priority 1600] - - theorem is_prop_is_equiv [instance] : is_prop (is_equiv f) := - is_prop_of_imp_is_contr - (λ(H : is_equiv f), is_trunc_equiv_closed -2 (equiv.symm !is_equiv.sigma_char')) - - definition inv_eq_inv {A B : Type} {f f' : A → B} {Hf : is_equiv f} {Hf' : is_equiv f'} - (p : f = f') : f⁻¹ = f'⁻¹ := - apd011 inv p !is_prop.elim - - /- contractible fibers -/ - definition is_contr_fun_of_is_equiv [H : is_equiv f] : is_contr_fun f := - is_contr_fiber_of_is_equiv f - - definition is_prop_is_contr_fun (f : A → B) : is_prop (is_contr_fun f) := _ - - definition is_equiv_of_is_contr_fun [H : is_contr_fun f] : is_equiv f := - adjointify _ (λb, point (center (fiber f b))) - (λb, point_eq (center (fiber f b))) - (λa, ap point (center_eq (fiber.mk a idp))) - - definition is_equiv_of_imp_is_equiv (H : B → is_equiv f) : is_equiv f := - @is_equiv_of_is_contr_fun _ _ f (λb, @is_contr_fiber_of_is_equiv _ _ _ (H b) _) - - definition is_equiv_equiv_is_contr_fun : is_equiv f ≃ is_contr_fun f := - equiv_of_is_prop _ (λH, !is_equiv_of_is_contr_fun) - -end is_equiv - -namespace is_equiv - - /- Theorem 4.7.7 -/ - variables {A : Type} {P Q : A → Type} - variable (f : Πa, P a → Q a) - - definition is_fiberwise_equiv [reducible] := Πa, is_equiv (f a) - - definition is_equiv_total_of_is_fiberwise_equiv [H : is_fiberwise_equiv f] : is_equiv (total f) := - is_equiv_sigma_functor id f - - definition is_fiberwise_equiv_of_is_equiv_total [H : is_equiv (total f)] - : is_fiberwise_equiv f := - begin - intro a, - apply is_equiv_of_is_contr_fun, intro q, - apply @is_contr_equiv_closed _ _ (fiber_total_equiv f q) - end - -end is_equiv - -namespace equiv - open is_equiv - variables {A B C : Type} - - definition equiv_mk_eq {f f' : A → B} [H : is_equiv f] [H' : is_equiv f'] (p : f = f') - : equiv.mk f H = equiv.mk f' H' := - apd011 equiv.mk p !is_prop.elim - - definition equiv_eq {f f' : A ≃ B} (p : to_fun f = to_fun f') : f = f' := - by (cases f; cases f'; apply (equiv_mk_eq p)) - - definition equiv_eq' {f f' : A ≃ B} (p : to_fun f ~ to_fun f') : f = f' := - by apply equiv_eq;apply eq_of_homotopy p - - definition trans_symm (f : A ≃ B) (g : B ≃ C) : (f ⬝e g)⁻¹ᵉ = g⁻¹ᵉ ⬝e f⁻¹ᵉ :> (C ≃ A) := - equiv_eq idp - - definition symm_symm (f : A ≃ B) : f⁻¹ᵉ⁻¹ᵉ = f :> (A ≃ B) := - equiv_eq idp - - protected definition equiv.sigma_char [constructor] - (A B : Type) : (A ≃ B) ≃ Σ(f : A → B), is_equiv f := - begin - fapply equiv.MK, - {intro F, exact ⟨to_fun F, to_is_equiv F⟩}, - {intro p, cases p with f H, exact (equiv.mk f H)}, - {intro p, cases p, exact idp}, - {intro F, cases F, exact idp}, - end - - definition equiv_eq_char (f f' : A ≃ B) : (f = f') ≃ (to_fun f = to_fun f') := - calc - (f = f') ≃ (to_fun !equiv.sigma_char f = to_fun !equiv.sigma_char f') - : eq_equiv_fn_eq (to_fun !equiv.sigma_char) - ... ≃ ((to_fun !equiv.sigma_char f).1 = (to_fun !equiv.sigma_char f').1 ) : equiv_subtype - ... ≃ (to_fun f = to_fun f') : equiv.refl - - definition is_equiv_ap_to_fun (f f' : A ≃ B) - : is_equiv (ap to_fun : f = f' → to_fun f = to_fun f') := - begin - fapply adjointify, - {intro p, cases f with f H, cases f' with f' H', cases p, apply ap (mk f'), apply is_prop.elim}, - {intro p, cases f with f H, cases f' with f' H', cases p, - apply @concat _ _ (ap to_fun (ap (equiv.mk f') (is_prop.elim H H'))), {apply idp}, - generalize is_prop.elim H H', intro q, cases q, apply idp}, - {intro p, cases p, cases f with f H, apply ap (ap (equiv.mk f)), apply is_set.elim} - end - - definition equiv_pathover {A : Type} {a a' : A} (p : a = a') - {B : A → Type} {C : A → Type} (f : B a ≃ C a) (g : B a' ≃ C a') - (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[p] g b') : f =[p] g := - begin - fapply pathover_of_fn_pathover_fn, - { intro a, apply equiv.sigma_char}, - { fapply sigma_pathover, - esimp, apply arrow_pathover, exact r, - apply is_prop.elimo} - end - - definition is_contr_equiv (A B : Type) [HA : is_contr A] [HB : is_contr B] : is_contr (A ≃ B) := - begin - apply @is_contr_of_inhabited_prop, apply is_prop.mk, - intro x y, cases x with fx Hx, cases y with fy Hy, generalize Hy, - apply (eq_of_homotopy (λ a, !eq_of_is_contr)) ▸ (λ Hy, !is_prop.elim ▸ rfl), - apply equiv_of_is_contr_of_is_contr - end - - definition is_trunc_succ_equiv (n : trunc_index) (A B : Type) - [HA : is_trunc n.+1 A] [HB : is_trunc n.+1 B] : is_trunc n.+1 (A ≃ B) := - @is_trunc_equiv_closed _ _ n.+1 (equiv.symm !equiv.sigma_char) - (@is_trunc_sigma _ _ _ _ (λ f, !is_trunc_succ_of_is_prop)) - - definition is_trunc_equiv (n : trunc_index) (A B : Type) - [HA : is_trunc n A] [HB : is_trunc n B] : is_trunc n (A ≃ B) := - by cases n; apply !is_contr_equiv; apply !is_trunc_succ_equiv - -end equiv diff --git a/hott/types/fiber.hlean b/hott/types/fiber.hlean deleted file mode 100644 index 377c2ec179..0000000000 --- a/hott/types/fiber.hlean +++ /dev/null @@ -1,170 +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 fibers --/ - -import .sigma .eq .pi .pointed -open equiv sigma sigma.ops eq pi - -structure fiber {A B : Type} (f : A → B) (b : B) := - (point : A) - (point_eq : f point = b) - -namespace fiber - variables {A B : Type} {f : A → B} {b : B} - - protected definition sigma_char [constructor] - (f : A → B) (b : B) : fiber f b ≃ (Σ(a : A), f a = b) := - begin - fapply equiv.MK, - {intro x, exact ⟨point x, point_eq x⟩}, - {intro x, exact (fiber.mk x.1 x.2)}, - {intro x, exact abstract begin cases x, apply idp end end}, - {intro x, exact abstract begin cases x, apply idp end end}, - end - - definition fiber_eq_equiv (x y : fiber f b) - : (x = y) ≃ (Σ(p : point x = point y), point_eq x = ap f p ⬝ point_eq y) := - begin - apply equiv.trans, - apply eq_equiv_fn_eq_of_equiv, apply fiber.sigma_char, - apply equiv.trans, - apply sigma_eq_equiv, - apply sigma_equiv_sigma_right, - intro p, - apply pathover_eq_equiv_Fl, - end - - definition fiber_eq {x y : fiber f b} (p : point x = point y) - (q : point_eq x = ap f p ⬝ point_eq y) : x = y := - to_inv !fiber_eq_equiv ⟨p, q⟩ - - open is_trunc - definition fiber_pr1 (B : A → Type) (a : A) : fiber (pr1 : (Σa, B a) → A) a ≃ B a := - calc - fiber pr1 a ≃ Σu, u.1 = a : fiber.sigma_char - ... ≃ Σa' (b : B a'), a' = a : sigma_assoc_equiv - ... ≃ Σa' (p : a' = a), B a' : sigma_equiv_sigma_right (λa', !comm_equiv_nondep) - ... ≃ Σu, B u.1 : sigma_assoc_equiv - ... ≃ B a : !sigma_equiv_of_is_contr_left - - definition sigma_fiber_equiv (f : A → B) : (Σb, fiber f b) ≃ A := - calc - (Σb, fiber f b) ≃ Σb a, f a = b : sigma_equiv_sigma_right (λb, !fiber.sigma_char) - ... ≃ Σa b, f a = b : sigma_comm_equiv - ... ≃ A : sigma_equiv_of_is_contr_right - - definition is_pointed_fiber [instance] [constructor] (f : A → B) (a : A) - : pointed (fiber f (f a)) := - pointed.mk (fiber.mk a idp) - - definition pointed_fiber [constructor] (f : A → B) (a : A) : Type* := - pointed.Mk (fiber.mk a (idpath (f a))) - - definition is_trunc_fun [reducible] (n : trunc_index) (f : A → B) := - Π(b : B), is_trunc n (fiber f b) - - definition is_contr_fun [reducible] (f : A → B) := is_trunc_fun -2 f - - -- pre and post composition with equivalences - open function - protected definition equiv_postcompose {B' : Type} (g : B → B') [H : is_equiv g] - : fiber (g ∘ f) (g b) ≃ fiber f b := - calc - fiber (g ∘ f) (g b) ≃ Σa : A, g (f a) = g b : fiber.sigma_char - ... ≃ Σa : A, f a = b : begin - apply sigma_equiv_sigma_right, intro a, - apply equiv.symm, apply eq_equiv_fn_eq - end - ... ≃ fiber f b : fiber.sigma_char - - protected definition equiv_precompose {A' : Type} (g : A' → A) [H : is_equiv g] - : fiber (f ∘ g) b ≃ fiber f b := - calc - fiber (f ∘ g) b ≃ Σa' : A', f (g a') = b : fiber.sigma_char - ... ≃ Σa : A, f a = b : begin - apply sigma_equiv_sigma (equiv.mk g H), - intro a', apply erfl - end - ... ≃ fiber f b : fiber.sigma_char - -end fiber - -open unit is_trunc pointed - -namespace fiber - - definition fiber_star_equiv (A : Type) : fiber (λx : A, star) star ≃ A := - begin - fapply equiv.MK, - { intro f, cases f with a H, exact a }, - { intro a, apply fiber.mk a, reflexivity }, - { intro a, reflexivity }, - { intro f, cases f with a H, change fiber.mk a (refl star) = fiber.mk a H, - rewrite [is_set.elim H (refl star)] } - end - - definition fiber_const_equiv (A : Type) (a₀ : A) (a : A) - : fiber (λz : unit, a₀) a ≃ a₀ = a := - calc - fiber (λz : unit, a₀) a - ≃ Σz : unit, a₀ = a : fiber.sigma_char - ... ≃ a₀ = a : sigma_unit_left - - -- the pointed fiber of a pointed map, which is the fiber over the basepoint - definition pfiber [constructor] {X Y : Type*} (f : X →* Y) : Type* := - pointed.MK (fiber f pt) (fiber.mk pt !respect_pt) - - definition ppoint [constructor] {X Y : Type*} (f : X →* Y) : pfiber f →* X := - pmap.mk point idp - -end fiber - -open function is_equiv - -namespace fiber - /- Theorem 4.7.6 -/ - variables {A : Type} {P Q : A → Type} - variable (f : Πa, P a → Q a) - - definition fiber_total_equiv {a : A} (q : Q a) - : fiber (total f) ⟨a , q⟩ ≃ fiber (f a) q := - calc - fiber (total f) ⟨a , q⟩ - ≃ Σ(w : Σx, P x), ⟨w.1 , f w.1 w.2 ⟩ = ⟨a , q⟩ - : fiber.sigma_char - ... ≃ Σ(x : A), Σ(p : P x), ⟨x , f x p⟩ = ⟨a , q⟩ - : sigma_assoc_equiv - ... ≃ Σ(x : A), Σ(p : P x), Σ(H : x = a), f x p =[H] q - : - begin - apply sigma_equiv_sigma_right, intro x, - apply sigma_equiv_sigma_right, intro p, - apply sigma_eq_equiv - end - ... ≃ Σ(x : A), Σ(H : x = a), Σ(p : P x), f x p =[H] q - : - begin - apply sigma_equiv_sigma_right, intro x, - apply sigma_comm_equiv - end - ... ≃ Σ(w : Σx, x = a), Σ(p : P w.1), f w.1 p =[w.2] q - : sigma_assoc_equiv - ... ≃ Σ(p : P (center (Σx, x=a)).1), f (center (Σx, x=a)).1 p =[(center (Σx, x=a)).2] q - : sigma_equiv_of_is_contr_left - ... ≃ Σ(p : P a), f a p =[idpath a] q - : equiv_of_eq idp - ... ≃ Σ(p : P a), f a p = q - : - begin - apply sigma_equiv_sigma_right, intro p, - apply pathover_idp - end - ... ≃ fiber (f a) q - : fiber.sigma_char - -end fiber diff --git a/hott/types/fin.hlean b/hott/types/fin.hlean deleted file mode 100644 index 595cf985cf..0000000000 --- a/hott/types/fin.hlean +++ /dev/null @@ -1,580 +0,0 @@ -/- -Copyright (c) 2015 Haitao Zhang. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Haitao Zhang, Leonardo de Moura, Jakob von Raumer - -Finite ordinal types. --/ -import types.list algebra.group function logic types.prod types.sum types.nat.div -open eq nat function list equiv is_trunc algebra sigma sum - -structure fin (n : nat) := (val : nat) (is_lt : val < n) - -definition less_than [reducible] := fin - -namespace fin - -attribute fin.val [coercion] - -section def_equal -variable {n : nat} - -definition sigma_char : fin n ≃ Σ (val : nat), val < n := -begin - fapply equiv.MK, - intro i, cases i with i ilt, apply dpair i ilt, - intro s, cases s with i ilt, apply fin.mk i ilt, - intro s, cases s with i ilt, reflexivity, - intro i, cases i with i ilt, reflexivity -end - -definition is_set_fin [instance] : is_set (fin n) := -begin - apply is_trunc_equiv_closed, apply equiv.symm, apply sigma_char, -end - -definition eq_of_veq : Π {i j : fin n}, (val i) = j → i = j := -begin - intro i j, cases i with i ilt, cases j with j jlt, esimp, - intro p, induction p, apply ap (mk i), apply !is_prop.elim -end - -definition eq_of_veq_refl (i : fin n) : eq_of_veq (refl (val i)) = idp := -!is_prop.elim - -definition veq_of_eq : Π {i j : fin n}, i = j → (val i) = j := -by intro i j P; apply ap val; exact P - - -definition eq_iff_veq {i j : fin n} : (val i) = j ↔ i = j := -pair eq_of_veq veq_of_eq - -definition val_inj := @eq_of_veq n - -end def_equal - -section decidable -open decidable - -protected definition has_decidable_eq [instance] (n : nat) : - Π (i j : fin n), decidable (i = j) := -begin - intros i j, apply decidable_of_decidable_of_iff, - apply nat.has_decidable_eq i j, apply eq_iff_veq, -end - -end decidable - -/-lemma dinj_lt (n : nat) : dinj (λ i, i < n) fin.mk := -take a1 a2 Pa1 Pa2 Pmkeq, fin.no_confusion Pmkeq (λ Pe Pqe, Pe) - -lemma val_mk (n i : nat) (Plt : i < n) : fin.val (fin.mk i Plt) = i := rfl - -definition upto [reducible] (n : nat) : list (fin n) := -dmap (λ i, i < n) fin.mk (list.upto n) - -lemma nodup_upto (n : nat) : nodup (upto n) := -dmap_nodup_of_dinj (dinj_lt n) (list.nodup_upto n) - -lemma mem_upto (n : nat) : Π (i : fin n), i ∈ upto n := -take i, fin.destruct i - (take ival Piltn, - have ival ∈ list.upto n, from mem_upto_of_lt Piltn, - mem_dmap Piltn this) - -lemma upto_zero : upto 0 = [] := -by rewrite [↑upto, list.upto_nil, dmap_nil] - -lemma map_val_upto (n : nat) : map fin.val (upto n) = list.upto n := -map_dmap_of_inv_of_pos (val_mk n) (@lt_of_mem_upto n) - -lemma length_upto (n : nat) : length (upto n) = n := -calc - length (upto n) = length (list.upto n) : (map_val_upto n ▸ length_map fin.val (upto n))⁻¹ - ... = n : list.length_upto n - -definition is_fintype [instance] (n : nat) : fintype (fin n) := -fintype.mk (upto n) (nodup_upto n) (mem_upto n) - -section pigeonhole -open fintype - -lemma card_fin (n : nat) : card (fin n) = n := length_upto n - -theorem pigeonhole {n m : nat} (Pmltn : m < n) : ¬Σ f : fin n → fin m, injective f := -assume Pex, absurd Pmltn (not_lt_of_ge - (calc - n = card (fin n) : card_fin - ... ≤ card (fin m) : card_le_of_inj (fin n) (fin m) Pex - ... = m : card_fin)) - -end pigeonhole-/ - -protected definition zero [constructor] (n : nat) : fin (succ n) := -mk 0 !zero_lt_succ - -definition fin_has_zero [instance] (n : nat) : has_zero (fin (succ n)) := -has_zero.mk (fin.zero n) - -definition val_zero (n : nat) : val (0 : fin (succ n)) = 0 := rfl - -definition mk_mod [reducible] (n i : nat) : fin (succ n) := -mk (i % (succ n)) (mod_lt _ !zero_lt_succ) - -theorem mk_mod_zero_eq (n : nat) : mk_mod n 0 = 0 := -apd011 fin.mk rfl !is_prop.elim - -variable {n : nat} - -theorem val_lt : Π i : fin n, val i < n -| (mk v h) := h - -lemma max_lt (i j : fin n) : max i j < n := -max_lt (is_lt i) (is_lt j) - -definition lift [constructor] : fin n → Π m : nat, fin (n + m) -| (mk v h) m := mk v (lt_add_of_lt_right h m) - -definition lift_succ [constructor] (i : fin n) : fin (nat.succ n) := -have r : fin (n+1), from lift i 1, -r - -definition maxi [reducible] : fin (succ n) := -mk n !lt_succ_self - -definition val_lift : Π (i : fin n) (m : nat), val i = val (lift i m) -| (mk v h) m := rfl - -lemma mk_succ_ne_zero {i : nat} : Π {P}, mk (succ i) P ≠ (0 : fin (succ n)) := -assume P Pe, absurd (veq_of_eq Pe) !succ_ne_zero - -lemma mk_mod_eq {i : fin (succ n)} : i = mk_mod n i := -eq_of_veq begin rewrite [↑mk_mod, mod_eq_of_lt !is_lt] end - -lemma mk_mod_of_lt {i : nat} (Plt : i < succ n) : mk_mod n i = mk i Plt := -begin esimp [mk_mod], congruence, exact mod_eq_of_lt Plt end - -section lift_lower - -lemma lift_zero : lift_succ (0 : fin (succ n)) = (0 : fin (succ (succ n))) := -by apply eq_of_veq; reflexivity - -lemma ne_max_of_lt_max {i : fin (succ n)} : i < n → i ≠ maxi := -begin - intro hlt he, - have he' : maxi = i, by apply he⁻¹, - induction he', apply nat.lt_irrefl n hlt, -end - -lemma lt_max_of_ne_max {i : fin (succ n)} : i ≠ maxi → i < n := -assume hne : i ≠ maxi, -have vne : val i ≠ n, from - assume he, - have val (@maxi n) = n, from rfl, - have val i = val (@maxi n), from he ⬝ this⁻¹, - absurd (eq_of_veq this) hne, -have val i < nat.succ n, from val_lt i, -lt_of_le_of_ne (le_of_lt_succ this) vne - -lemma lift_succ_ne_max {i : fin n} : lift_succ i ≠ maxi := -begin - cases i with v hlt, esimp [lift_succ, lift, max], intro he, - injection he, substvars, - exact absurd hlt (lt.irrefl v) -end - -lemma lift_succ_inj [instance] : is_embedding (@lift_succ n) := -begin - apply is_embedding_of_is_injective, intro i j, - induction i with iv ilt, induction j with jv jlt, intro Pmkeq, - apply eq_of_veq, apply veq_of_eq Pmkeq -end - -definition lt_of_inj_of_max (f : fin (succ n) → fin (succ n)) : - is_embedding f → (f maxi = maxi) → Π i : fin (succ n), i < n → f i < n := -assume Pinj Peq, take i, assume Pilt, -have P1 : f i = f maxi → i = maxi, from assume Peq, is_injective_of_is_embedding Peq, -have f i ≠ maxi, from - begin rewrite -Peq, intro P2, apply absurd (P1 P2) (ne_max_of_lt_max Pilt) end, -lt_max_of_ne_max this - -definition lift_fun : (fin n → fin n) → (fin (succ n) → fin (succ n)) := -λ f i, dite (i = maxi) (λ Pe, maxi) (λ Pne, lift_succ (f (mk i (lt_max_of_ne_max Pne)))) - -definition lower_inj (f : fin (succ n) → fin (succ n)) (inj : is_embedding f) : - f maxi = maxi → fin n → fin n := -assume Peq, take i, mk (f (lift_succ i)) (lt_of_inj_of_max f inj Peq (lift_succ i) (lt_max_of_ne_max lift_succ_ne_max)) - -lemma lift_fun_max {f : fin n → fin n} : lift_fun f maxi = maxi := -begin rewrite [↑lift_fun, dif_pos rfl] end - -lemma lift_fun_of_ne_max {f : fin n → fin n} {i} (Pne : i ≠ maxi) : - lift_fun f i = lift_succ (f (mk i (lt_max_of_ne_max Pne))) := -begin rewrite [↑lift_fun, dif_neg Pne] end - -lemma lift_fun_eq {f : fin n → fin n} {i : fin n} : - lift_fun f (lift_succ i) = lift_succ (f i) := -begin - rewrite [lift_fun_of_ne_max lift_succ_ne_max], do 2 congruence, - apply eq_of_veq, esimp, rewrite -val_lift, -end - -lemma lift_fun_of_inj {f : fin n → fin n} : is_embedding f → is_embedding (lift_fun f) := -begin - intro Pemb, apply is_embedding_of_is_injective, intro i j, - have Pdi : decidable (i = maxi), by apply _, - have Pdj : decidable (j = maxi), by apply _, - cases Pdi with Pimax Pinmax, - cases Pdj with Pjmax Pjnmax, - substvars, intros, reflexivity, - substvars, rewrite [lift_fun_max, lift_fun_of_ne_max Pjnmax], - intro Plmax, apply absurd Plmax⁻¹ lift_succ_ne_max, - cases Pdj with Pjmax Pjnmax, - substvars, rewrite [lift_fun_max, lift_fun_of_ne_max Pinmax], - intro Plmax, apply absurd Plmax lift_succ_ne_max, - rewrite [lift_fun_of_ne_max Pinmax, lift_fun_of_ne_max Pjnmax], - intro Peq, apply eq_of_veq, - cases i with i ilt, cases j with j jlt, esimp at *, - fapply veq_of_eq, apply is_injective_of_is_embedding, - apply @is_injective_of_is_embedding _ _ lift_succ _ _ _ Peq, -end - -lemma lift_fun_inj : is_embedding (@lift_fun n) := -begin - apply is_embedding_of_is_injective, intro f f' Peq, apply eq_of_homotopy, intro i, - have H : lift_fun f (lift_succ i) = lift_fun f' (lift_succ i), by apply congr_fun Peq _, - revert H, rewrite [*lift_fun_eq], apply is_injective_of_is_embedding, -end - -lemma lower_inj_apply {f Pinj Pmax} (i : fin n) : - val (lower_inj f Pinj Pmax i) = val (f (lift_succ i)) := -by rewrite [↑lower_inj] - -end lift_lower - -section madd - -definition madd (i j : fin (succ n)) : fin (succ n) := -mk ((i + j) % (succ n)) (mod_lt _ !zero_lt_succ) - -definition minv : Π i : fin (succ n), fin (succ n) -| (mk iv ilt) := mk ((succ n - iv) % succ n) (mod_lt _ !zero_lt_succ) - -lemma val_madd : Π i j : fin (succ n), val (madd i j) = (i + j) % (succ n) -| (mk iv ilt) (mk jv jlt) := by esimp - -lemma madd_inj : Π {i : fin (succ n)}, is_embedding (madd i) -| (mk iv ilt) := is_embedding_of_is_injective -(take j₁ j₂, fin.destruct j₁ (fin.destruct j₂ (λ jv₁ jlt₁ jv₂ jlt₂, begin - rewrite [↑madd], - intro Peq', note Peq := ap val Peq', congruence, - rewrite [-(mod_eq_of_lt jlt₁), -(mod_eq_of_lt jlt₂)], - apply mod_eq_mod_of_add_mod_eq_add_mod_left Peq -end))) - -lemma madd_mk_mod {i j : nat} : madd (mk_mod n i) (mk_mod n j) = mk_mod n (i+j) := -eq_of_veq begin esimp [madd, mk_mod], rewrite [ mod_add_mod, add_mod_mod ] end - -lemma val_mod : Π i : fin (succ n), (val i) % (succ n) = val i -| (mk iv ilt) := by esimp; rewrite [(mod_eq_of_lt ilt)] - -lemma madd_comm (i j : fin (succ n)) : madd i j = madd j i := -by apply eq_of_veq; rewrite [*val_madd, add.comm (val i)] - -lemma zero_madd (i : fin (succ n)) : madd 0 i = i := -have H : madd (fin.zero n) i = i, - by apply eq_of_veq; rewrite [val_madd, ↑fin.zero, nat.zero_add, mod_eq_of_lt (is_lt i)], -H - -lemma madd_zero (i : fin (succ n)) : madd i (fin.zero n) = i := -!madd_comm ▸ zero_madd i - -lemma madd_assoc (i j k : fin (succ n)) : madd (madd i j) k = madd i (madd j k) := -by apply eq_of_veq; rewrite [*val_madd, mod_add_mod, add_mod_mod, add.assoc (val i)] - -lemma madd_left_inv : Π i : fin (succ n), madd (minv i) i = fin.zero n -| (mk iv ilt) := eq_of_veq (by - rewrite [val_madd, ↑minv, mod_add_mod, nat.sub_add_cancel (le_of_lt ilt), mod_self]) - -definition madd_is_comm_group [instance] : add_comm_group (fin (succ n)) := -add_comm_group.mk madd _ madd_assoc (fin.zero n) zero_madd madd_zero minv madd_left_inv madd_comm - -end madd - -definition pred [constructor] : fin n → fin n -| (mk v h) := mk (nat.pred v) (pre_lt_of_lt h) - -lemma val_pred : Π (i : fin n), val (pred i) = nat.pred (val i) -| (mk v h) := rfl - -lemma pred_zero : pred (fin.zero n) = fin.zero n := -begin - induction n, reflexivity, apply eq_of_veq, reflexivity, -end - -definition mk_pred (i : nat) (h : succ i < succ n) : fin n := -mk i (lt_of_succ_lt_succ h) - -definition succ : fin n → fin (succ n) -| (mk v h) := mk (nat.succ v) (succ_lt_succ h) - -lemma val_succ : Π (i : fin n), val (succ i) = nat.succ (val i) -| (mk v h) := rfl - -lemma succ_max : fin.succ maxi = (@maxi (nat.succ n)) := rfl - -lemma lift_succ.comm : lift_succ ∘ (@succ n) = succ ∘ lift_succ := -eq_of_homotopy take i, - eq_of_veq (begin rewrite [↑lift_succ, -val_lift, *val_succ, -val_lift] end) - -definition elim0 {C : fin 0 → Type} : Π i : fin 0, C i -| (mk v h) := absurd h !not_lt_zero - -definition zero_succ_cases {C : fin (nat.succ n) → Type} : - C (fin.zero n) → (Π j : fin n, C (succ j)) → (Π k : fin (nat.succ n), C k) := -begin - intros CO CS k, - induction k with [vk, pk], - induction (nat.decidable_lt 0 vk) with [HT, HF], - { show C (mk vk pk), from - let vj := nat.pred vk in - have vk = nat.succ vj, from - inverse (succ_pred_of_pos HT), - have vj < n, from - lt_of_succ_lt_succ (eq.subst `vk = nat.succ vj` pk), - have succ (mk vj `vj < n`) = mk vk pk, by apply val_inj; apply (succ_pred_of_pos HT), - eq.rec_on this (CS (mk vj `vj < n`)) }, - { show C (mk vk pk), from - have vk = 0, from - eq_zero_of_le_zero (le_of_not_gt HF), - have fin.zero n = mk vk pk, from - val_inj (inverse this), - eq.rec_on this CO } -end - -definition succ_maxi_cases {C : fin (nat.succ n) → Type} : - (Π j : fin n, C (lift_succ j)) → C maxi → (Π k : fin (nat.succ n), C k) := -begin - intros CL CM k, - induction k with [vk, pk], - induction (nat.decidable_lt vk n) with [HT, HF], - { show C (mk vk pk), from - have HL : lift_succ (mk vk HT) = mk vk pk, from - val_inj rfl, - eq.rec_on HL (CL (mk vk HT)) }, - { show C (mk vk pk), from - have HMv : vk = n, from - le.antisymm (le_of_lt_succ pk) (le_of_not_gt HF), - have HM : maxi = mk vk pk, from - val_inj (inverse HMv), - eq.rec_on HM CM } -end - -open decidable - --- TODO there has to be a less painful way to do this -definition elim_succ_maxi_cases_lift_succ {C : fin (nat.succ n) → Type} - {Cls : Π j : fin n, C (lift_succ j)} {Cm : C maxi} (i : fin n) : - succ_maxi_cases Cls Cm (lift_succ i) = Cls i := -begin - esimp[succ_maxi_cases], cases i with i ilt, esimp, - apply decidable.rec, - { intro ilt', esimp[val_inj], apply concat, - apply ap (λ x, eq.rec_on x _), esimp[eq_of_veq, rfl], reflexivity, - have H : ilt = ilt', by apply is_prop.elim, cases H, - have H' : is_prop.elim (lt_add_of_lt_right ilt 1) (lt_add_of_lt_right ilt 1) = idp, - by apply is_prop.elim, - krewrite H' }, - { intro a, exact absurd ilt a }, -end - -definition elim_succ_maxi_cases_maxi {C : fin (nat.succ n) → Type} - {Cls : Π j : fin n, C (lift_succ j)} {Cm : C maxi} : - succ_maxi_cases Cls Cm maxi = Cm := -begin - esimp[succ_maxi_cases, maxi], - apply decidable.rec, - { intro a, apply absurd a !nat.lt_irrefl }, - { intro a, esimp[val_inj], apply concat, - have H : (le.antisymm (le_of_lt_succ (lt_succ_self n)) (le_of_not_gt a))⁻¹ = idp, - by apply is_prop.elim, - apply ap _ H, krewrite eq_of_veq_refl }, -end - -definition foldr {A B : Type} (m : A → B → B) (b : B) : Π {n : nat}, (fin n → A) → B := - nat.rec (λ f, b) (λ n IH f, m (f (fin.zero n)) (IH (λ i : fin n, f (succ i)))) - -definition foldl {A B : Type} (m : B → A → B) (b : B) : Π {n : nat}, (fin n → A) → B := - nat.rec (λ f, b) (λ n IH f, m (IH (λ i : fin n, f (lift_succ i))) (f maxi)) - -theorem choice {C : fin n → Type} : - (Π i : fin n, nonempty (C i)) → nonempty (Π i : fin n, C i) := -begin - revert C, - induction n with [n, IH], - { intros C H, - apply nonempty.intro, - exact elim0 }, - { intros C H, - fapply nonempty.elim (H (fin.zero n)), - intro CO, - fapply nonempty.elim (IH (λ i, C (succ i)) (λ i, H (succ i))), - intro CS, - apply nonempty.intro, - exact zero_succ_cases CO CS } -end - -/-section -open list -local postfix `+1`:100 := nat.succ - -lemma dmap_map_lift {n : nat} : Π l : list nat, (Π i, i ∈ l → i < n) → dmap (λ i, i < n +1) mk l = map lift_succ (dmap (λ i, i < n) mk l) -| [] := assume Plt, rfl -| (i::l) := assume Plt, begin - rewrite [@dmap_cons_of_pos _ _ (λ i, i < n +1) _ _ _ (lt_succ_of_lt (Plt i !mem_cons)), @dmap_cons_of_pos _ _ (λ i, i < n) _ _ _ (Plt i !mem_cons), map_cons], - congruence, - apply dmap_map_lift, - intro j Pjinl, apply Plt, apply mem_cons_of_mem, assumption end - -lemma upto_succ (n : nat) : upto (n +1) = maxi :: map lift_succ (upto n) := -begin - rewrite [↑fin.upto, list.upto_succ, @dmap_cons_of_pos _ _ (λ i, i < n +1) _ _ _ (nat.self_lt_succ n)], - congruence, - apply dmap_map_lift, apply @list.lt_of_mem_upto -end - -definition upto_step : Π {n : nat}, fin.upto (n +1) = (map succ (upto n))++[0] -| 0 := rfl -| (i +1) := begin rewrite [upto_succ i, map_cons, append_cons, succ_max, upto_succ, -lift_zero], - congruence, rewrite [map_map, -lift_succ.comm, -map_map, -(map_singleton _ 0), -map_append, -upto_step] end -end-/ - -open sum equiv decidable - -definition fin_zero_equiv_empty : fin 0 ≃ empty := -begin - fapply equiv.MK, rotate 1, do 2 (intro x; contradiction), - rotate 1, do 2 (intro x; apply elim0 x) -end - -definition is_contr_fin_one [instance] : is_contr (fin 1) := -begin - fapply is_contr.mk, exact 0, - intro x, induction x with v vlt, - apply eq_of_veq, rewrite val_zero, - apply inverse, apply eq_zero_of_le_zero, apply le_of_succ_le_succ, exact vlt, -end - -definition fin_sum_equiv (n m : nat) : (fin n + fin m) ≃ fin (n+m) := -begin - fapply equiv.MK, - { intro s, induction s with l r, - induction l with v vlt, apply mk v, apply lt_add_of_lt_right, exact vlt, - induction r with v vlt, apply mk (v + n), rewrite {n + m}add.comm, - apply add_lt_add_of_lt_of_le vlt, apply nat.le_refl }, - { intro f, induction f with v vlt, - exact if h : v < n - then sum.inl (mk v h) - else sum.inr (mk (v-n) (nat.sub_lt_of_lt_add vlt (le_of_not_gt h))) }, - { intro f, cases f with v vlt, esimp, apply @by_cases (v < n), - intro vltn, rewrite [dif_pos vltn], apply eq_of_veq, reflexivity, - intro nvltn, rewrite [dif_neg nvltn], apply eq_of_veq, esimp, - apply nat.sub_add_cancel, apply le_of_not_gt, apply nvltn }, - { intro s, cases s with f g, - cases f with v vlt, rewrite [dif_pos vlt], - cases g with v vlt, esimp, have ¬ v + n < n, from - suppose v + n < n, - have v < n - n, from nat.lt_sub_of_add_lt this !le.refl, - have v < 0, by rewrite [nat.sub_self at this]; exact this, - absurd this !not_lt_zero, - apply concat, apply dif_neg this, apply ap inr, apply eq_of_veq, esimp, - apply nat.add_sub_cancel }, -end - -definition fin_succ_equiv (n : nat) : fin (n + 1) ≃ fin n + unit := -begin - fapply equiv.MK, - { apply succ_maxi_cases, esimp, apply inl, apply inr unit.star }, - { intro d, cases d, apply lift_succ a, apply maxi }, - { intro d, cases d, - cases a with a alt, esimp, apply elim_succ_maxi_cases_lift_succ, - cases a, apply elim_succ_maxi_cases_maxi }, - { intro a, apply succ_maxi_cases, esimp, - intro j, krewrite elim_succ_maxi_cases_lift_succ, - krewrite elim_succ_maxi_cases_maxi }, -end - -open prod - -definition fin_prod_equiv (n m : nat) : (fin n × fin m) ≃ fin (n*m) := -begin - induction n, - { krewrite nat.zero_mul, - calc fin 0 × fin m ≃ empty × fin m : fin_zero_equiv_empty - ... ≃ fin m × empty : prod_comm_equiv - ... ≃ empty : prod_empty_equiv - ... ≃ fin 0 : fin_zero_equiv_empty }, - { have H : (a + 1) * m = a * m + m, by rewrite [nat.right_distrib, one_mul], - calc fin (a + 1) × fin m - ≃ (fin a + unit) × fin m : prod.prod_equiv_prod_right !fin_succ_equiv - ... ≃ (fin a × fin m) + (unit × fin m) : sum_prod_right_distrib - ... ≃ (fin a × fin m) + (fin m × unit) : prod_comm_equiv - ... ≃ fin (a * m) + (fin m × unit) : v_0 - ... ≃ fin (a * m) + fin m : prod_unit_equiv - ... ≃ fin (a * m + m) : fin_sum_equiv - ... ≃ fin ((a + 1) * m) : equiv_of_eq (ap fin H⁻¹) }, -end - -definition fin_two_equiv_bool : fin 2 ≃ bool := -let H := equiv_unit_of_is_contr (fin 1) in -calc - fin 2 ≃ fin (1 + 1) : equiv.refl - ... ≃ fin 1 + fin 1 : fin_sum_equiv - ... ≃ unit + unit : H - ... ≃ bool : bool_equiv_unit_sum_unit - -definition fin_sum_unit_equiv (n : nat) : fin n + unit ≃ fin (nat.succ n) := -let H := equiv_unit_of_is_contr (fin 1) in -calc - fin n + unit ≃ fin n + fin 1 : H - ... ≃ fin (nat.succ n) : fin_sum_equiv - -definition fin_sum_equiv_cancel {n : nat} {A B : Type} (H : (fin n) + A ≃ (fin n) + B) : - A ≃ B := -begin - induction n with n IH, - { calc A ≃ A + empty : sum_empty_equiv - ... ≃ empty + A : sum_comm_equiv - ... ≃ fin 0 + A : fin_zero_equiv_empty - ... ≃ fin 0 + B : H - ... ≃ empty + B : fin_zero_equiv_empty - ... ≃ B + empty : sum_comm_equiv - ... ≃ B : sum_empty_equiv }, - { apply IH, apply unit_sum_equiv_cancel, - calc unit + (fin n + A) ≃ (unit + fin n) + A : sum_assoc_equiv - ... ≃ (fin n + unit) + A : sum_comm_equiv - ... ≃ fin (nat.succ n) + A : fin_sum_unit_equiv - ... ≃ fin (nat.succ n) + B : H - ... ≃ (fin n + unit) + B : fin_sum_unit_equiv - ... ≃ (unit + fin n) + B : sum_comm_equiv - ... ≃ unit + (fin n + B) : sum_assoc_equiv }, -end - - -definition eq_of_fin_equiv {m n : nat} (H :fin m ≃ fin n) : m = n := -begin - revert n H, induction m with m IH IH, - { intro n H, cases n, reflexivity, exfalso, - apply to_fun fin_zero_equiv_empty, apply to_inv H, apply fin.zero }, - { intro n H, cases n with n, exfalso, - apply to_fun fin_zero_equiv_empty, apply to_fun H, apply fin.zero, - have unit + fin m ≃ unit + fin n, from - calc unit + fin m ≃ fin m + unit : sum_comm_equiv - ... ≃ fin (nat.succ m) : fin_succ_equiv - ... ≃ fin (nat.succ n) : H - ... ≃ fin n + unit : fin_succ_equiv - ... ≃ unit + fin n : sum_comm_equiv, - have fin m ≃ fin n, from unit_sum_equiv_cancel this, - apply ap nat.succ, apply IH _ this }, -end -end fin diff --git a/hott/types/int/basic.hlean b/hott/types/int/basic.hlean deleted file mode 100644 index d07d1fe5bd..0000000000 --- a/hott/types/int/basic.hlean +++ /dev/null @@ -1,628 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn, Jeremy Avigad - -The integers, with addition, multiplication, and subtraction. The representation of the integers is -chosen to compute efficiently. - -To faciliate proving things about these operations, we show that the integers are a quotient of -ℕ × ℕ with the usual equivalence relation, ≡, and functions - - abstr : ℕ × ℕ → ℤ - repr : ℤ → ℕ × ℕ - -satisfying: - - abstr_repr (a : ℤ) : abstr (repr a) = a - repr_abstr (p : ℕ × ℕ) : repr (abstr p) ≡ p - abstr_eq (p q : ℕ × ℕ) : p ≡ q → abstr p = abstr q - -For example, to "lift" statements about add to statements about padd, we need to prove the -following: - - repr_add (a b : ℤ) : repr (a + b) = padd (repr a) (repr b) - padd_congr (p p' q q' : ℕ × ℕ) (H1 : p ≡ p') (H2 : q ≡ q') : padd p q ≡ p' q' - --/ -import types.nat.sub algebra.relation types.prod -open prod relation nat -open decidable binary -open algebra eq lift - -/- the type of integers -/ - -inductive int : Type := -| of_nat : nat → int -| neg_succ_of_nat : nat → int - -notation `ℤ` := int -definition int.of_num [coercion] [reducible] [constructor] (n : num) : ℤ := -int.of_nat (nat.of_num n) - -namespace int - -attribute int.of_nat [coercion] - -notation `-[1+ ` n `]` := int.neg_succ_of_nat n -- for pretty-printing output - -protected definition prio : num := num.pred nat.prio - -definition int_has_zero [instance] [priority int.prio] : has_zero int := -has_zero.mk (of_nat 0) - -definition int_has_one [instance] [priority int.prio] : has_one int := -has_one.mk (of_nat 1) - -theorem of_nat_zero : of_nat (0:nat) = (0:int) := -rfl - -theorem of_nat_one : of_nat (1:nat) = (1:int) := -rfl - -/- definitions of basic functions -/ - -definition neg_of_nat : ℕ → ℤ -| 0 := 0 -| (succ m) := -[1+ m] - -definition sub_nat_nat (m n : ℕ) : ℤ := -match (n - m : nat) with - | 0 := of_nat (m - n) -- m ≥ n - | (succ k) := -[1+ k] -- m < n, and n - m = succ k -end - -protected definition neg (a : ℤ) : ℤ := -int.cases_on a neg_of_nat succ - -protected definition add : ℤ → ℤ → ℤ -| (of_nat m) (of_nat n) := _root_.add m n -| (of_nat m) -[1+ n] := sub_nat_nat m (succ n) -| -[1+ m] (of_nat n) := sub_nat_nat n (succ m) -| -[1+ m] -[1+ n] := neg_of_nat (succ m + succ n) - -protected definition mul : ℤ → ℤ → ℤ -| (of_nat m) (of_nat n) := m * n -| (of_nat m) -[1+ n] := neg_of_nat (m * succ n) -| -[1+ m] (of_nat n) := neg_of_nat (succ m * n) -| -[1+ m] -[1+ n] := succ m * succ n - -/- notation -/ - -definition int_has_add [instance] [priority int.prio] : has_add int := has_add.mk int.add -definition int_has_neg [instance] [priority int.prio] : has_neg int := has_neg.mk int.neg -definition int_has_mul [instance] [priority int.prio] : has_mul int := has_mul.mk int.mul - -lemma mul_of_nat_of_nat (m n : nat) : of_nat m * of_nat n = of_nat (m * n) := -rfl - -lemma mul_of_nat_neg_succ_of_nat (m n : nat) : of_nat m * -[1+ n] = neg_of_nat (m * succ n) := -rfl - -lemma mul_neg_succ_of_nat_of_nat (m n : nat) : -[1+ m] * of_nat n = neg_of_nat (succ m * n) := -rfl - -lemma mul_neg_succ_of_nat_neg_succ_of_nat (m n : nat) : -[1+ m] * -[1+ n] = succ m * succ n := -rfl - -/- some basic functions and properties -/ - -theorem of_nat.inj {m n : ℕ} (H : of_nat m = of_nat n) : m = n := -down (int.no_confusion H imp.id) - -theorem eq_of_of_nat_eq_of_nat {m n : ℕ} (H : of_nat m = of_nat n) : m = n := -of_nat.inj H - -theorem of_nat_eq_of_nat_iff (m n : ℕ) : of_nat m = of_nat n ↔ m = n := -iff.intro of_nat.inj !ap - -theorem neg_succ_of_nat.inj {m n : ℕ} (H : neg_succ_of_nat m = neg_succ_of_nat n) : m = n := -down (int.no_confusion H imp.id) - -theorem neg_succ_of_nat_eq (n : ℕ) : -[1+ n] = -(n + 1) := rfl - -private definition has_decidable_eq₂ : Π (a b : ℤ), decidable (a = b) -| (of_nat m) (of_nat n) := decidable_of_decidable_of_iff - (nat.has_decidable_eq m n) (iff.symm (of_nat_eq_of_nat_iff m n)) -| (of_nat m) -[1+ n] := inr (by contradiction) -| -[1+ m] (of_nat n) := inr (by contradiction) -| -[1+ m] -[1+ n] := if H : m = n then - inl (ap neg_succ_of_nat H) else inr (not.mto neg_succ_of_nat.inj H) - -definition has_decidable_eq [instance] [priority int.prio] : decidable_eq ℤ := has_decidable_eq₂ - -theorem of_nat_add (n m : nat) : of_nat (n + m) = of_nat n + of_nat m := rfl - -theorem of_nat_succ (n : ℕ) : of_nat (succ n) = of_nat n + 1 := rfl - -theorem of_nat_mul (n m : ℕ) : of_nat (n * m) = of_nat n * of_nat m := rfl - -theorem sub_nat_nat_of_ge {m n : ℕ} (H : m ≥ n) : sub_nat_nat m n = of_nat (m - n) := -show sub_nat_nat m n = nat.cases_on 0 (m -[nat] n) _, from (sub_eq_zero_of_le H) ▸ rfl - -section -local attribute sub_nat_nat [reducible] -theorem sub_nat_nat_of_lt {m n : ℕ} (H : m < n) : sub_nat_nat m n = -[1+ pred (n - m)] := -have H1 : n - m = succ (pred (n - m)), from inverse (succ_pred_of_pos (nat.sub_pos_of_lt H)), -show sub_nat_nat m n = nat.cases_on (succ (nat.pred (n - m))) (m -[nat] n) _, from H1 ▸ rfl -end - -definition nat_abs (a : ℤ) : ℕ := int.cases_on a id succ - -theorem nat_abs_of_nat (n : ℕ) : nat_abs n = n := rfl - -theorem eq_zero_of_nat_abs_eq_zero : Π {a : ℤ}, nat_abs a = 0 → a = 0 -| (of_nat m) H := ap of_nat H -| -[1+ m'] H := absurd H !succ_ne_zero - -theorem nat_abs_zero : nat_abs (0:int) = (0:nat) := -rfl - -theorem nat_abs_one : nat_abs (1:int) = (1:nat) := -rfl - -/- int is a quotient of ordered pairs of natural numbers -/ - -protected definition equiv (p q : ℕ × ℕ) : Type₀ := pr1 p + pr2 q = pr2 p + pr1 q - -local infix ≡ := int.equiv - -protected theorem equiv.refl [refl] {p : ℕ × ℕ} : p ≡ p := !add.comm - -protected theorem equiv.symm [symm] {p q : ℕ × ℕ} (H : p ≡ q) : q ≡ p := -calc - pr1 q + pr2 p = pr2 p + pr1 q : by rewrite add.comm - ... = pr1 p + pr2 q : H⁻¹ - ... = pr2 q + pr1 p : by rewrite add.comm - -protected theorem equiv.trans [trans] {p q r : ℕ × ℕ} (H1 : p ≡ q) (H2 : q ≡ r) : p ≡ r := -add.right_cancel (calc - pr1 p + pr2 r + pr2 q = pr1 p + pr2 q + pr2 r : by rewrite add.right_comm - ... = pr2 p + pr1 q + pr2 r : {H1} - ... = pr2 p + (pr1 q + pr2 r) : by rewrite add.assoc - ... = pr2 p + (pr2 q + pr1 r) : {H2} - ... = pr2 p + pr2 q + pr1 r : by rewrite add.assoc - ... = pr2 p + pr1 r + pr2 q : by rewrite add.right_comm) - -protected theorem equiv_equiv : is_equivalence int.equiv := -is_equivalence.mk @equiv.refl @equiv.symm @equiv.trans - -protected theorem equiv_cases {p q : ℕ × ℕ} (H : p ≡ q) : - (pr1 p ≥ pr2 p × pr1 q ≥ pr2 q) ⊎ (pr1 p < pr2 p × pr1 q < pr2 q) := -sum.elim (@le_sum_gt _ _ (pr2 p) (pr1 p)) - (suppose pr1 p ≥ pr2 p, - have pr2 p + pr1 q ≥ pr2 p + pr2 q, from H ▸ add_le_add_right this (pr2 q), - sum.inl (pair `pr1 p ≥ pr2 p` (le_of_add_le_add_left this))) - (suppose H₁ : pr1 p < pr2 p, - have pr2 p + pr1 q < pr2 p + pr2 q, from H ▸ add_lt_add_right H₁ (pr2 q), - sum.inr (pair H₁ (lt_of_add_lt_add_left this))) - -protected theorem equiv_of_eq {p q : ℕ × ℕ} (H : p = q) : p ≡ q := H ▸ equiv.refl - -/- the representation and abstraction functions -/ - -definition abstr (a : ℕ × ℕ) : ℤ := sub_nat_nat (pr1 a) (pr2 a) - -theorem abstr_of_ge {p : ℕ × ℕ} (H : pr1 p ≥ pr2 p) : abstr p = of_nat (pr1 p - pr2 p) := -sub_nat_nat_of_ge H - -theorem abstr_of_lt {p : ℕ × ℕ} (H : pr1 p < pr2 p) : - abstr p = -[1+ pred (pr2 p - pr1 p)] := -sub_nat_nat_of_lt H - -definition repr : ℤ → ℕ × ℕ -| (of_nat m) := (m, 0) -| -[1+ m] := (0, succ m) - -theorem abstr_repr : Π (a : ℤ), abstr (repr a) = a -| (of_nat m) := (sub_nat_nat_of_ge (zero_le m)) -| -[1+ m] := rfl - -theorem repr_sub_nat_nat (m n : ℕ) : repr (sub_nat_nat m n) ≡ (m, n) := -nat.lt_ge_by_cases - (take H : m < n, - have H1 : repr (sub_nat_nat m n) = (0, n - m), by - rewrite [sub_nat_nat_of_lt H, -(succ_pred_of_pos (nat.sub_pos_of_lt H))], - H1⁻¹ ▸ (!zero_add ⬝ (nat.sub_add_cancel (le_of_lt H))⁻¹)) - (take H : m ≥ n, - have H1 : repr (sub_nat_nat m n) = (m - n, 0), from sub_nat_nat_of_ge H ▸ rfl, - H1⁻¹ ▸ ((nat.sub_add_cancel H) ⬝ !zero_add⁻¹)) - -theorem repr_abstr (p : ℕ × ℕ) : repr (abstr p) ≡ p := -!prod.eta ▸ !repr_sub_nat_nat - -theorem abstr_eq {p q : ℕ × ℕ} (Hequiv : p ≡ q) : abstr p = abstr q := -sum.elim (int.equiv_cases Hequiv) - (prod.rec (assume (Hp : pr1 p ≥ pr2 p) (Hq : pr1 q ≥ pr2 q), - have H : pr1 p - pr2 p = pr1 q - pr2 q, from - calc pr1 p - pr2 p - = pr1 p + pr2 q - pr2 q - pr2 p : by rewrite nat.add_sub_cancel - ... = pr2 p + pr1 q - pr2 q - pr2 p : Hequiv - ... = pr2 p + (pr1 q - pr2 q) - pr2 p : nat.add_sub_assoc Hq - ... = pr1 q - pr2 q + pr2 p - pr2 p : by rewrite add.comm - ... = pr1 q - pr2 q : by rewrite nat.add_sub_cancel, - abstr_of_ge Hp ⬝ (H ▸ rfl) ⬝ (abstr_of_ge Hq)⁻¹)) - (prod.rec (assume (Hp : pr1 p < pr2 p) (Hq : pr1 q < pr2 q), - have H : pr2 p - pr1 p = pr2 q - pr1 q, from - calc pr2 p - pr1 p - = pr2 p + pr1 q - pr1 q - pr1 p : by rewrite nat.add_sub_cancel - ... = pr1 p + pr2 q - pr1 q - pr1 p : Hequiv - ... = pr1 p + (pr2 q - pr1 q) - pr1 p : nat.add_sub_assoc (le_of_lt Hq) - ... = pr2 q - pr1 q + pr1 p - pr1 p : by rewrite add.comm - ... = pr2 q - pr1 q : by rewrite nat.add_sub_cancel, - abstr_of_lt Hp ⬝ (H ▸ rfl) ⬝ (abstr_of_lt Hq)⁻¹)) - -theorem equiv_iff (p q : ℕ × ℕ) : (p ≡ q) ↔ (abstr p = abstr q) := -iff.intro abstr_eq (assume H, equiv.trans (H ▸ equiv.symm (repr_abstr p)) (repr_abstr q)) - -theorem equiv_iff3 (p q : ℕ × ℕ) : (p ≡ q) ↔ ((p ≡ p) × (q ≡ q) × (abstr p = abstr q)) := -iff.trans !equiv_iff (iff.symm - (iff.trans (prod_iff_right !equiv.refl) (prod_iff_right !equiv.refl))) - -theorem eq_abstr_of_equiv_repr {a : ℤ} {p : ℕ × ℕ} (Hequiv : repr a ≡ p) : a = abstr p := -!abstr_repr⁻¹ ⬝ abstr_eq Hequiv - -theorem eq_of_repr_equiv_repr {a b : ℤ} (H : repr a ≡ repr b) : a = b := -eq_abstr_of_equiv_repr H ⬝ !abstr_repr - -section -local attribute abstr [reducible] -local attribute dist [reducible] -theorem nat_abs_abstr : Π (p : ℕ × ℕ), nat_abs (abstr p) = dist (pr1 p) (pr2 p) -| (m, n) := nat.lt_ge_by_cases - (assume H : m < n, - calc - nat_abs (abstr (m, n)) = nat_abs (-[1+ pred (n - m)]) : int.abstr_of_lt H - ... = n - m : succ_pred_of_pos (nat.sub_pos_of_lt H) - ... = dist m n : dist_eq_sub_of_le (le_of_lt H)) - (assume H : m ≥ n, (abstr_of_ge H)⁻¹ ▸ (dist_eq_sub_of_ge H)⁻¹) -end - -theorem cases_of_nat_succ (a : ℤ) : (Σn : ℕ, a = of_nat n) ⊎ (Σn : ℕ, a = - (of_nat (succ n))) := -int.cases_on a (take m, sum.inl (sigma.mk _ rfl)) (take m, sum.inr (sigma.mk _ rfl)) - -theorem cases_of_nat (a : ℤ) : (Σn : ℕ, a = of_nat n) ⊎ (Σn : ℕ, a = - of_nat n) := -sum.imp_right (sigma.rec (take n, (sigma.mk _))) !cases_of_nat_succ - -theorem by_cases_of_nat {P : ℤ → Type} (a : ℤ) - (H1 : Πn : ℕ, P (of_nat n)) (H2 : Πn : ℕ, P (- of_nat n)) : - P a := -sum.elim (cases_of_nat a) - (assume H, obtain (n : ℕ) (H3 : a = n), from H, H3⁻¹ ▸ H1 n) - (assume H, obtain (n : ℕ) (H3 : a = -n), from H, H3⁻¹ ▸ H2 n) - -theorem by_cases_of_nat_succ {P : ℤ → Type} (a : ℤ) - (H1 : Πn : ℕ, P (of_nat n)) (H2 : Πn : ℕ, P (- of_nat (succ n))) : - P a := -sum.elim (cases_of_nat_succ a) - (assume H, obtain (n : ℕ) (H3 : a = n), from H, H3⁻¹ ▸ H1 n) - (assume H, obtain (n : ℕ) (H3 : a = -(succ n)), from H, H3⁻¹ ▸ H2 n) - -/- - int is a ring --/ - -/- addition -/ - -definition padd (p q : ℕ × ℕ) : ℕ × ℕ := (pr1 p + pr1 q, pr2 p + pr2 q) - -theorem repr_add : Π (a b : ℤ), repr (add a b) ≡ padd (repr a) (repr b) -| (of_nat m) (of_nat n) := !equiv.refl -| (of_nat m) -[1+ n] := - begin - change repr (sub_nat_nat m (succ n)) ≡ (m + 0, 0 + succ n), - rewrite [zero_add, add_zero], - apply repr_sub_nat_nat - end -| -[1+ m] (of_nat n) := - begin - change repr (-[1+ m] + n) ≡ (0 + n, succ m + 0), - rewrite [zero_add, add_zero], - apply repr_sub_nat_nat - end -| -[1+ m] -[1+ n] := !repr_sub_nat_nat - -theorem padd_congr {p p' q q' : ℕ × ℕ} (Ha : p ≡ p') (Hb : q ≡ q') : padd p q ≡ padd p' q' := -calc pr1 p + pr1 q + (pr2 p' + pr2 q') - = pr1 p + pr2 p' + (pr1 q + pr2 q') : add.comm4 - ... = pr2 p + pr1 p' + (pr1 q + pr2 q') : {Ha} - ... = pr2 p + pr1 p' + (pr2 q + pr1 q') : {Hb} - ... = pr2 p + pr2 q + (pr1 p' + pr1 q') : add.comm4 - -theorem padd_comm (p q : ℕ × ℕ) : padd p q = padd q p := -calc (pr1 p + pr1 q, pr2 p + pr2 q) - = (pr1 q + pr1 p, pr2 p + pr2 q) : by rewrite add.comm - ... = (pr1 q + pr1 p, pr2 q + pr2 p) : by rewrite (add.comm (pr2 p) (pr2 q)) - -theorem padd_assoc (p q r : ℕ × ℕ) : padd (padd p q) r = padd p (padd q r) := -calc (pr1 p + pr1 q + pr1 r, pr2 p + pr2 q + pr2 r) - = (pr1 p + (pr1 q + pr1 r), pr2 p + pr2 q + pr2 r) : by rewrite add.assoc - ... = (pr1 p + (pr1 q + pr1 r), pr2 p + (pr2 q + pr2 r)) : by rewrite add.assoc - -protected theorem add_comm (a b : ℤ) : a + b = b + a := -eq_of_repr_equiv_repr (equiv.trans !repr_add - (equiv.symm (!padd_comm ▸ !repr_add))) - -protected theorem add_assoc (a b c : ℤ) : a + b + c = a + (b + c) := -eq_of_repr_equiv_repr (calc - repr (a + b + c) - ≡ padd (repr (a + b)) (repr c) : repr_add - ... ≡ padd (padd (repr a) (repr b)) (repr c) : padd_congr !repr_add !equiv.refl - ... = padd (repr a) (padd (repr b) (repr c)) : !padd_assoc - ... ≡ padd (repr a) (repr (b + c)) : padd_congr !equiv.refl !repr_add - ... ≡ repr (a + (b + c)) : repr_add) - -protected theorem add_zero : Π (a : ℤ), a + 0 = a := int.rec (λm, rfl) (λm, rfl) - -protected theorem zero_add (a : ℤ) : 0 + a = a := !int.add_comm ▸ !int.add_zero - -/- negation -/ - -definition pneg (p : ℕ × ℕ) : ℕ × ℕ := (pr2 p, pr1 p) - --- note: this is =, not just ≡ -theorem repr_neg : Π (a : ℤ), repr (- a) = pneg (repr a) -| 0 := rfl -| (succ m) := rfl -| -[1+ m] := rfl - -theorem pneg_congr {p p' : ℕ × ℕ} (H : p ≡ p') : pneg p ≡ pneg p' := inverse H - -theorem pneg_pneg (p : ℕ × ℕ) : pneg (pneg p) = p := !prod.eta - -theorem nat_abs_neg (a : ℤ) : nat_abs (-a) = nat_abs a := -calc - nat_abs (-a) = nat_abs (abstr (repr (-a))) : abstr_repr - ... = nat_abs (abstr (pneg (repr a))) : repr_neg - ... = dist (pr1 (pneg (repr a))) (pr2 (pneg (repr a))) : nat_abs_abstr - ... = dist (pr2 (pneg (repr a))) (pr1 (pneg (repr a))) : dist.comm - ... = nat_abs (abstr (repr a)) : nat_abs_abstr - ... = nat_abs a : abstr_repr - -theorem padd_pneg (p : ℕ × ℕ) : padd p (pneg p) ≡ (0, 0) := -show pr1 p + pr2 p + 0 = pr2 p + pr1 p + 0, -by rewrite [nat.add_comm (pr1 p)] - -theorem padd_padd_pneg (p q : ℕ × ℕ) : padd (padd p q) (pneg q) ≡ p := -calc pr1 p + pr1 q + pr2 q + pr2 p - = pr1 p + (pr1 q + pr2 q) + pr2 p : add.assoc - ... = pr1 p + (pr1 q + pr2 q + pr2 p) : add.assoc - ... = pr1 p + (pr2 q + pr1 q + pr2 p) : add.comm - ... = pr1 p + (pr2 q + pr2 p + pr1 q) : add.right_comm - ... = pr1 p + (pr2 p + pr2 q + pr1 q) : add.comm - ... = pr2 p + pr2 q + pr1 q + pr1 p : add.comm - -protected theorem add_left_inv (a : ℤ) : -a + a = 0 := -have H : repr (-a + a) ≡ repr 0, from - calc - repr (-a + a) ≡ padd (repr (neg a)) (repr a) : repr_add - ... = padd (pneg (repr a)) (repr a) : repr_neg - ... ≡ repr 0 : padd_pneg, -eq_of_repr_equiv_repr H - -/- nat abs -/ - -definition pabs (p : ℕ × ℕ) : ℕ := dist (pr1 p) (pr2 p) - -theorem pabs_congr {p q : ℕ × ℕ} (H : p ≡ q) : pabs p = pabs q := -calc - pabs p = nat_abs (abstr p) : nat_abs_abstr - ... = nat_abs (abstr q) : abstr_eq H - ... = pabs q : nat_abs_abstr - -theorem nat_abs_eq_pabs_repr (a : ℤ) : nat_abs a = pabs (repr a) := -calc - nat_abs a = nat_abs (abstr (repr a)) : abstr_repr - ... = pabs (repr a) : nat_abs_abstr - -theorem nat_abs_add_le (a b : ℤ) : nat_abs (a + b) ≤ nat_abs a + nat_abs b := -calc - nat_abs (a + b) = pabs (repr (a + b)) : nat_abs_eq_pabs_repr - ... = pabs (padd (repr a) (repr b)) : pabs_congr !repr_add - ... ≤ pabs (repr a) + pabs (repr b) : dist_add_add_le_add_dist_dist - ... = pabs (repr a) + nat_abs b : nat_abs_eq_pabs_repr - ... = nat_abs a + nat_abs b : nat_abs_eq_pabs_repr - -theorem nat_abs_neg_of_nat (n : nat) : nat_abs (neg_of_nat n) = n := -begin cases n, reflexivity, reflexivity end - -section -local attribute nat_abs [reducible] -theorem nat_abs_mul : Π (a b : ℤ), nat_abs (a * b) = (nat_abs a) * (nat_abs b) -| (of_nat m) (of_nat n) := rfl -| (of_nat m) -[1+ n] := by rewrite [mul_of_nat_neg_succ_of_nat, nat_abs_neg_of_nat] -| -[1+ m] (of_nat n) := by rewrite [mul_neg_succ_of_nat_of_nat, nat_abs_neg_of_nat] -| -[1+ m] -[1+ n] := rfl -end - -/- multiplication -/ - -definition pmul (p q : ℕ × ℕ) : ℕ × ℕ := - (pr1 p * pr1 q + pr2 p * pr2 q, pr1 p * pr2 q + pr2 p * pr1 q) - -theorem repr_neg_of_nat (m : ℕ) : repr (neg_of_nat m) = (0, m) := -nat.cases_on m rfl (take m', rfl) - --- note: we have =, not just ≡ -theorem repr_mul : Π (a b : ℤ), repr (a * b) = pmul (repr a) (repr b) -| (of_nat m) (of_nat n) := calc - (m * n + 0 * 0, m * 0 + 0) = (m * n + 0 * 0, m * 0 + 0 * n) : by rewrite *zero_mul -| (of_nat m) -[1+ n] := calc - repr ((m : int) * -[1+ n]) = (m * 0 + 0, m * succ n + 0 * 0) : repr_neg_of_nat - ... = (m * 0 + 0 * succ n, m * succ n + 0 * 0) : by rewrite *zero_mul -| -[1+ m] (of_nat n) := calc - repr (-[1+ m] * (n:int)) = (0 + succ m * 0, succ m * n) : repr_neg_of_nat - ... = (0 + succ m * 0, 0 + succ m * n) : nat.zero_add - ... = (0 * n + succ m * 0, 0 + succ m * n) : by rewrite zero_mul -| -[1+ m] -[1+ n] := calc - (succ m * succ n, 0) = (succ m * succ n, 0 * succ n) : by rewrite zero_mul - ... = (0 + succ m * succ n, 0 * succ n) : nat.zero_add - -theorem equiv_mul_prep {xa ya xb yb xn yn xm ym : ℕ} - (H1 : xa + yb = ya + xb) (H2 : xn + ym = yn + xm) -: xa*xn+ya*yn+(xb*ym+yb*xm) = xa*yn+ya*xn+(xb*xm+yb*ym) := -nat.add_right_cancel (calc - xa*xn+ya*yn + (xb*ym+yb*xm) + (yb*xn+xb*yn + (xb*xn+yb*yn)) - = xa*xn+ya*yn + (yb*xn+xb*yn) + (xb*ym+yb*xm + (xb*xn+yb*yn)) : by rewrite add.comm4 - ... = xa*xn+ya*yn + (yb*xn+xb*yn) + (xb*xn+yb*yn + (xb*ym+yb*xm)) : by rewrite {xb*ym+yb*xm +_}nat.add_comm - ... = xa*xn+yb*xn + (ya*yn+xb*yn) + (xb*xn+xb*ym + (yb*yn+yb*xm)) : by exact !congr_arg2 !add.comm4 !add.comm4 - ... = ya*xn+xb*xn + (xa*yn+yb*yn) + (xb*yn+xb*xm + (yb*xn+yb*ym)) : by rewrite[-+left_distrib,-+right_distrib]; exact H1 ▸ H2 ▸ rfl - ... = ya*xn+xa*yn + (xb*xn+yb*yn) + (xb*yn+yb*xn + (xb*xm+yb*ym)) : by exact !congr_arg2 !add.comm4 !add.comm4 - ... = xa*yn+ya*xn + (xb*xn+yb*yn) + (xb*yn+yb*xn + (xb*xm+yb*ym)) : by rewrite {xa*yn + _}nat.add_comm - ... = xa*yn+ya*xn + (xb*xn+yb*yn) + (yb*xn+xb*yn + (xb*xm+yb*ym)) : by rewrite {xb*yn + _}nat.add_comm - ... = xa*yn+ya*xn + (yb*xn+xb*yn) + (xb*xn+yb*yn + (xb*xm+yb*ym)) : by rewrite (!add.comm4) - ... = xa*yn+ya*xn + (yb*xn+xb*yn) + (xb*xm+yb*ym + (xb*xn+yb*yn)) : by rewrite {xb*xn+yb*yn + _}nat.add_comm - ... = xa*yn+ya*xn + (xb*xm+yb*ym) + (yb*xn+xb*yn + (xb*xn+yb*yn)) : by rewrite add.comm4) - -theorem pmul_congr {p p' q q' : ℕ × ℕ} : p ≡ p' → q ≡ q' → pmul p q ≡ pmul p' q' := equiv_mul_prep - -theorem pmul_comm (p q : ℕ × ℕ) : pmul p q = pmul q p := -show (_,_) = (_,_), -begin - congruence, - { congruence, repeat rewrite mul.comm }, - { rewrite add.comm, congruence, repeat rewrite mul.comm } -end - -protected theorem mul_comm (a b : ℤ) : a * b = b * a := -eq_of_repr_equiv_repr - ((calc - repr (a * b) = pmul (repr a) (repr b) : repr_mul - ... = pmul (repr b) (repr a) : pmul_comm - ... = repr (b * a) : repr_mul) ▸ !equiv.refl) - -private theorem pmul_assoc_prep {p1 p2 q1 q2 r1 r2 : ℕ} : - ((p1*q1+p2*q2)*r1+(p1*q2+p2*q1)*r2, (p1*q1+p2*q2)*r2+(p1*q2+p2*q1)*r1) = - (p1*(q1*r1+q2*r2)+p2*(q1*r2+q2*r1), p1*(q1*r2+q2*r1)+p2*(q1*r1+q2*r2)) := -begin - rewrite [+left_distrib, +right_distrib, *mul.assoc], - rewrite (add.comm4 (p1 * (q1 * r1)) (p2 * (q2 * r1)) (p1 * (q2 * r2)) (p2 * (q1 * r2))), - rewrite (add.comm (p2 * (q2 * r1)) (p2 * (q1 * r2))), - rewrite (add.comm4 (p1 * (q1 * r2)) (p2 * (q2 * r2)) (p1 * (q2 * r1)) (p2 * (q1 * r1))), - rewrite (add.comm (p2 * (q2 * r2)) (p2 * (q1 * r1))) -end - -theorem pmul_assoc (p q r: ℕ × ℕ) : pmul (pmul p q) r = pmul p (pmul q r) := pmul_assoc_prep - -protected theorem mul_assoc (a b c : ℤ) : (a * b) * c = a * (b * c) := -eq_of_repr_equiv_repr - ((calc - repr (a * b * c) = pmul (repr (a * b)) (repr c) : repr_mul - ... = pmul (pmul (repr a) (repr b)) (repr c) : repr_mul - ... = pmul (repr a) (pmul (repr b) (repr c)) : pmul_assoc - ... = pmul (repr a) (repr (b * c)) : repr_mul - ... = repr (a * (b * c)) : repr_mul) ▸ !equiv.refl) - -protected theorem mul_one : Π (a : ℤ), a * 1 = a -| (of_nat m) := !int.zero_add -- zero_add happens to be def. = to this thm -| -[1+ m] := !nat.zero_add ▸ rfl - -protected theorem one_mul (a : ℤ) : 1 * a = a := -int.mul_comm a 1 ▸ int.mul_one a - -private theorem mul_distrib_prep {a1 a2 b1 b2 c1 c2 : ℕ} : - ((a1+b1)*c1+(a2+b2)*c2, (a1+b1)*c2+(a2+b2)*c1) = - (a1*c1+a2*c2+(b1*c1+b2*c2), a1*c2+a2*c1+(b1*c2+b2*c1)) := -begin - rewrite +right_distrib, congruence, - {rewrite add.comm4}, - {rewrite add.comm4} -end - -protected theorem right_distrib (a b c : ℤ) : (a + b) * c = a * c + b * c := -eq_of_repr_equiv_repr - (calc - repr ((a + b) * c) = pmul (repr (a + b)) (repr c) : repr_mul - ... ≡ pmul (padd (repr a) (repr b)) (repr c) : pmul_congr !repr_add equiv.refl - ... = padd (pmul (repr a) (repr c)) (pmul (repr b) (repr c)) : mul_distrib_prep - ... = padd (repr (a * c)) (pmul (repr b) (repr c)) : repr_mul - ... = padd (repr (a * c)) (repr (b * c)) : repr_mul - ... ≡ repr (a * c + b * c) : repr_add) - -protected theorem left_distrib (a b c : ℤ) : a * (b + c) = a * b + a * c := -calc - a * (b + c) = (b + c) * a : int.mul_comm - ... = b * a + c * a : int.right_distrib - ... = a * b + c * a : int.mul_comm - ... = a * b + a * c : int.mul_comm - -protected theorem zero_ne_one : (0 : int) ≠ 1 := -assume H : 0 = 1, !succ_ne_zero (of_nat.inj H)⁻¹ - -protected theorem eq_zero_sum_eq_zero_of_mul_eq_zero {a b : ℤ} (H : a * b = 0) : a = 0 ⊎ b = 0 := -sum.imp eq_zero_of_nat_abs_eq_zero eq_zero_of_nat_abs_eq_zero - (eq_zero_sum_eq_zero_of_mul_eq_zero (by rewrite [-nat_abs_mul, H])) - -protected definition integral_domain [trans_instance] : integral_domain int := -⦃integral_domain, - add := int.add, - add_assoc := int.add_assoc, - zero := 0, - zero_add := int.zero_add, - add_zero := int.add_zero, - neg := int.neg, - add_left_inv := int.add_left_inv, - add_comm := int.add_comm, - mul := int.mul, - mul_assoc := int.mul_assoc, - one := 1, - one_mul := int.one_mul, - mul_one := int.mul_one, - left_distrib := int.left_distrib, - right_distrib := int.right_distrib, - mul_comm := int.mul_comm, - zero_ne_one := int.zero_ne_one, - eq_zero_sum_eq_zero_of_mul_eq_zero := @int.eq_zero_sum_eq_zero_of_mul_eq_zero, - is_set_carrier := is_set_of_decidable_eq⦄ - -definition int_has_sub [instance] [priority int.prio] : has_sub int := -has_sub.mk has_sub.sub - -definition int_has_dvd [instance] [priority int.prio] : has_dvd int := -has_dvd.mk has_dvd.dvd - -/- additional properties -/ -theorem of_nat_sub {m n : ℕ} (H : m ≥ n) : of_nat (m - n) = of_nat m - of_nat n := -have m - n + n = m, from nat.sub_add_cancel H, -begin - symmetry, - apply sub_eq_of_eq_add, - rewrite [-of_nat_add, this] -end - -theorem neg_succ_of_nat_eq' (m : ℕ) : -[1+ m] = -m - 1 := -by rewrite [neg_succ_of_nat_eq, neg_add] - -definition succ (a : ℤ) := a + (succ zero) -definition pred (a : ℤ) := a - (succ zero) -definition nat_succ_eq_int_succ (n : ℕ) : nat.succ n = int.succ n := idp -theorem pred_succ (a : ℤ) : pred (succ a) = a := !sub_add_cancel -theorem succ_pred (a : ℤ) : succ (pred a) = a := !add_sub_cancel - -theorem neg_succ (a : ℤ) : -succ a = pred (-a) := -by rewrite [↑succ,neg_add] - -theorem succ_neg_succ (a : ℤ) : succ (-succ a) = -a := -by rewrite [neg_succ,succ_pred] - -theorem neg_pred (a : ℤ) : -pred a = succ (-a) := -by rewrite [↑pred,neg_sub,sub_eq_add_neg,add.comm] - -theorem pred_neg_pred (a : ℤ) : pred (-pred a) = -a := -by rewrite [neg_pred,pred_succ] - -theorem pred_nat_succ (n : ℕ) : pred (nat.succ n) = n := pred_succ n -theorem neg_nat_succ (n : ℕ) : -nat.succ n = pred (-n) := !neg_succ -theorem succ_neg_nat_succ (n : ℕ) : succ (-nat.succ n) = -n := !succ_neg_succ - -definition rec_nat_on [unfold 2] {P : ℤ → Type} (z : ℤ) (H0 : P 0) - (Hsucc : Π⦃n : ℕ⦄, P n → P (succ n)) (Hpred : Π⦃n : ℕ⦄, P (-n) → P (-nat.succ n)) : P z := -int.rec (nat.rec H0 Hsucc) (λn, nat.rec H0 Hpred (nat.succ n)) z - ---the only computation rule of rec_nat_on which is not definitional -theorem rec_nat_on_neg {P : ℤ → Type} (n : ℕ) (H0 : P zero) - (Hsucc : Π⦃n : ℕ⦄, P n → P (succ n)) (Hpred : Π⦃n : ℕ⦄, P (-n) → P (-nat.succ n)) - : rec_nat_on (-nat.succ n) H0 Hsucc Hpred = Hpred (rec_nat_on (-n) H0 Hsucc Hpred) := -nat.rec rfl (λn H, rfl) n - -end int diff --git a/hott/types/int/default.hlean b/hott/types/int/default.hlean deleted file mode 100644 index 10147301ea..0000000000 --- a/hott/types/int/default.hlean +++ /dev/null @@ -1,7 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn --/ - -import .basic .hott diff --git a/hott/types/int/hott.hlean b/hott/types/int/hott.hlean deleted file mode 100644 index 7507c5604f..0000000000 --- a/hott/types/int/hott.hlean +++ /dev/null @@ -1,149 +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 the integers specific to HoTT --/ - -import .basic types.eq arity algebra.bundled -open core eq is_equiv equiv algebra is_trunc -open nat (hiding pred) - -namespace int - - section - open algebra - definition group_integers : Group := - Group.mk ℤ (group_of_add_group _) - end - - definition is_equiv_succ [instance] : is_equiv succ := - adjointify succ pred (λa, !add_sub_cancel) (λa, !sub_add_cancel) - definition equiv_succ : ℤ ≃ ℤ := equiv.mk succ _ - - definition is_equiv_neg [instance] : is_equiv (neg : ℤ → ℤ) := - adjointify neg neg (λx, !neg_neg) (λa, !neg_neg) - definition equiv_neg : ℤ ≃ ℤ := equiv.mk neg _ - - definition iterate {A : Type} (f : A ≃ A) (a : ℤ) : A ≃ A := - rec_nat_on a erfl - (λb g, f ⬝e g) - (λb g, g ⬝e f⁻¹ᵉ) - - -- definition iterate_trans {A : Type} (f : A ≃ A) (a : ℤ) - -- : iterate f a ⬝e f = iterate f (a + 1) := - -- sorry - - -- definition trans_iterate {A : Type} (f : A ≃ A) (a : ℤ) - -- : f ⬝e iterate f a = iterate f (a + 1) := - -- sorry - - -- definition iterate_trans_symm {A : Type} (f : A ≃ A) (a : ℤ) - -- : iterate f a ⬝e f⁻¹e = iterate f (a - 1) := - -- sorry - - -- definition symm_trans_iterate {A : Type} (f : A ≃ A) (a : ℤ) - -- : f⁻¹e ⬝e iterate f a = iterate f (a - 1) := - -- sorry - - -- definition iterate_neg {A : Type} (f : A ≃ A) (a : ℤ) - -- : iterate f (-a) = (iterate f a)⁻¹e := - -- rec_nat_on a idp - -- (λn p, calc - -- iterate f (-succ n) = iterate f (-n) ⬝e f⁻¹e : rec_nat_on_neg - -- ... = (iterate f n)⁻¹e ⬝e f⁻¹e : by rewrite p - -- ... = (f ⬝e iterate f n)⁻¹e : sorry - -- ... = (iterate f (succ n))⁻¹e : idp) - -- sorry - - -- definition iterate_add {A : Type} (f : A ≃ A) (a b : ℤ) - -- : iterate f (a + b) = equiv.trans (iterate f a) (iterate f b) := - -- sorry - - -- definition iterate_sub {A : Type} (f : A ≃ A) (a b : ℤ) - -- : iterate f (a - b) = equiv.trans (iterate f a) (equiv.symm (iterate f b)) := - -- sorry - - -- definition iterate_mul {A : Type} (f : A ≃ A) (a b : ℤ) - -- : iterate f (a * b) = iterate (iterate f a) b := - -- sorry - -end int open int - - - -namespace eq - variables {A : Type} {a : A} (p : a = a) (b c : ℤ) (n : ℕ) - definition power : a = a := - rec_nat_on b idp - (λc q, q ⬝ p) - (λc q, q ⬝ p⁻¹) - --iterate (equiv_eq_closed_right p a) b idp - - -- definition power_neg_succ (n : ℕ) : power p (-succ n) = power p (-n) ⬝ p⁻¹ := - -- !rec_nat_on_neg - - -- local attribute nat.add int.add int.of_num nat.of_num int.succ [constructor] - - definition power_con : power p b ⬝ p = power p (succ b) := - rec_nat_on b - idp - (λn IH, idp) - (λn IH, calc - power p (-succ n) ⬝ p - = (power p (-int.of_nat n) ⬝ p⁻¹) ⬝ p : by rewrite [↑power,-rec_nat_on_neg] - ... = power p (-int.of_nat n) : inv_con_cancel_right - ... = power p (succ (-succ n)) : by rewrite -succ_neg_succ) - - definition power_con_inv : power p b ⬝ p⁻¹ = power p (pred b) := - rec_nat_on b - idp - (λn IH, calc - power p (succ n) ⬝ p⁻¹ = power p n : by apply con_inv_cancel_right - ... = power p (pred (succ n)) : by rewrite pred_nat_succ) - (λn IH, calc - power p (-int.of_nat (succ n)) ⬝ p⁻¹ - = power p (-int.of_nat (succ (succ n))) : by rewrite [↑power,-rec_nat_on_neg] - ... = power p (pred (-succ n)) : by rewrite -neg_succ) - - definition con_power : p ⬝ power p b = power p (succ b) := - rec_nat_on b - ( by rewrite ↑[power];exact !idp_con⁻¹) - ( λn IH, proof calc - p ⬝ power p (succ n) = (p ⬝ power p n) ⬝ p : con.assoc p _ p - ... = power p (succ (succ n)) : by rewrite IH qed) - ( λn IH, calc - p ⬝ power p (-int.of_nat (succ n)) - = p ⬝ (power p (-int.of_nat n) ⬝ p⁻¹) : by rewrite [↑power, rec_nat_on_neg] - ... = (p ⬝ power p (-int.of_nat n)) ⬝ p⁻¹ : con.assoc - ... = power p (succ (-int.of_nat n)) ⬝ p⁻¹ : by rewrite IH - ... = power p (pred (succ (-int.of_nat n))) : power_con_inv - ... = power p (succ (-int.of_nat (succ n))) : by rewrite [succ_neg_nat_succ,int.pred_succ]) - - definition inv_con_power : p⁻¹ ⬝ power p b = power p (pred b) := - rec_nat_on b - ( by rewrite ↑[power];exact !idp_con⁻¹) - (λn IH, calc - p⁻¹ ⬝ power p (succ n) = p⁻¹ ⬝ power p n ⬝ p : con.assoc - ... = power p (pred n) ⬝ p : by rewrite IH - ... = power p (succ (pred n)) : power_con - ... = power p (pred (succ n)) : by rewrite [succ_pred,-int.pred_succ n]) - ( λn IH, calc - p⁻¹ ⬝ power p (-int.of_nat (succ n)) - = p⁻¹ ⬝ (power p (-int.of_nat n) ⬝ p⁻¹) : by rewrite [↑power,rec_nat_on_neg] - ... = (p⁻¹ ⬝ power p (-int.of_nat n)) ⬝ p⁻¹ : con.assoc - ... = power p (pred (-int.of_nat n)) ⬝ p⁻¹ : by rewrite IH - ... = power p (-int.of_nat (succ n)) ⬝ p⁻¹ : by rewrite -neg_succ - ... = power p (-succ (succ n)) : by rewrite [↑power,-rec_nat_on_neg] - ... = power p (pred (-succ n)) : by rewrite -neg_succ) - - definition power_con_power : Π(b : ℤ), power p b ⬝ power p c = power p (b + c) := - rec_nat_on c - (λb, by rewrite int.add_zero) - (λn IH b, by rewrite [-con_power,-con.assoc,power_con,IH,↑succ,add.assoc, - add.comm (int.of_nat n)]) - (λn IH b, by rewrite [neg_nat_succ,-inv_con_power,-con.assoc,power_con_inv,IH,↑pred, - +sub_eq_add_neg,add.assoc,add.comm (-n)]) - -end eq diff --git a/hott/types/int/int.md b/hott/types/int/int.md deleted file mode 100644 index 5fe34add5b..0000000000 --- a/hott/types/int/int.md +++ /dev/null @@ -1,7 +0,0 @@ -types.int -========= - -The integers. Note: most of these files are ported 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)). - -* [basic](basic.hlean) : the integers, with basic operations -* [hott](hott.hlean) : facts about the integers specific to the HoTT library diff --git a/hott/types/lift.hlean b/hott/types/lift.hlean deleted file mode 100644 index 86f90da02b..0000000000 --- a/hott/types/lift.hlean +++ /dev/null @@ -1,150 +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 lift --/ - -import ..function -open eq equiv is_equiv is_trunc pointed - -namespace lift - - universe variables u v - variables {A : Type.{u}} (z z' : lift.{u v} A) - - protected definition eta : up (down z) = z := - by induction z; reflexivity - - protected definition code [unfold 2 3] : lift A → lift A → Type - | code (up a) (up a') := a = a' - - protected definition decode [unfold 2 3] : Π(z z' : lift A), lift.code z z' → z = z' - | decode (up a) (up a') := λc, ap up c - - variables {z z'} - protected definition encode [unfold 3 4 5] (p : z = z') : lift.code z z' := - by induction p; induction z; esimp - - variables (z z') - definition lift_eq_equiv : (z = z') ≃ lift.code z z' := - equiv.MK lift.encode - !lift.decode - abstract begin - intro c, induction z with a, induction z' with a', esimp at *, induction c, - reflexivity - end end - abstract begin - intro p, induction p, induction z, reflexivity - end end - - - section - variables {a a' : A} - definition eq_of_up_eq_up [unfold 4] (p : up a = up a') : a = a' := - lift.encode p - - definition lift_transport {P : A → Type} (p : a = a') (z : lift (P a)) - : p ▸ z = up (p ▸ down z) := - by induction p; induction z; reflexivity - end - - variables {A' : Type} (f : A → A') (g : lift A → lift A') - definition lift_functor [unfold 4] : lift A → lift A' - | lift_functor (up a) := up (f a) - - definition is_equiv_lift_functor [constructor] [Hf : is_equiv f] : is_equiv (lift_functor f) := - adjointify (lift_functor f) - (lift_functor f⁻¹) - abstract begin - intro z', induction z' with a', - esimp, exact ap up !right_inv - end end - abstract begin - intro z, induction z with a, - esimp, exact ap up !left_inv - end end - - definition lift_equiv_lift_of_is_equiv [constructor] [Hf : is_equiv f] : lift A ≃ lift A' := - equiv.mk _ (is_equiv_lift_functor f) - - definition lift_equiv_lift [constructor] (f : A ≃ A') : lift A ≃ lift A' := - equiv.mk _ (is_equiv_lift_functor f) - - definition lift_equiv_lift_refl (A : Type) : lift_equiv_lift (erfl : A ≃ A) = erfl := - by apply equiv_eq'; intro z; induction z with a; reflexivity - - definition lift_inv_functor [unfold_full] (a : A) : A' := - down (g (up a)) - - definition is_equiv_lift_inv_functor [constructor] [Hf : is_equiv g] - : is_equiv (lift_inv_functor g) := - adjointify (lift_inv_functor g) - (lift_inv_functor g⁻¹) - abstract begin - intro z', rewrite [▸*,lift.eta,right_inv g], - end end - abstract begin - intro z', rewrite [▸*,lift.eta,left_inv g], - end end - - definition equiv_of_lift_equiv_lift [constructor] (g : lift A ≃ lift A') : A ≃ A' := - equiv.mk _ (is_equiv_lift_inv_functor g) - - definition lift_functor_left_inv : lift_inv_functor (lift_functor f) = f := - eq_of_homotopy (λa, idp) - - definition lift_functor_right_inv : lift_functor (lift_inv_functor g) = g := - begin - apply eq_of_homotopy, intro z, induction z with a, esimp, apply lift.eta - end - - variables (A A') - definition is_equiv_lift_functor_fn [constructor] - : is_equiv (lift_functor : (A → A') → (lift A → lift A')) := - adjointify lift_functor - lift_inv_functor - lift_functor_right_inv - lift_functor_left_inv - - definition lift_imp_lift_equiv [constructor] : (lift A → lift A') ≃ (A → A') := - (equiv.mk _ (is_equiv_lift_functor_fn A A'))⁻¹ᵉ - - -- can we deduce this from lift_imp_lift_equiv? - definition lift_equiv_lift_equiv [constructor] : (lift A ≃ lift A') ≃ (A ≃ A') := - equiv.MK equiv_of_lift_equiv_lift - lift_equiv_lift - abstract begin - intro f, apply equiv_eq, reflexivity - end end - abstract begin - intro g, apply equiv_eq, esimp, apply eq_of_homotopy, intro z, - induction z with a, esimp, apply lift.eta - end end - - definition lift_eq_lift_equiv.{u1 u2} (A A' : Type.{u1}) - : (lift.{u1 u2} A = lift.{u1 u2} A') ≃ (A = A') := - !eq_equiv_equiv ⬝e !lift_equiv_lift_equiv ⬝e !eq_equiv_equiv⁻¹ᵉ - - definition is_embedding_lift [instance] : is_embedding lift := - begin - intro A A', fapply is_equiv.homotopy_closed, - exact to_inv !lift_eq_lift_equiv, - exact _, - { intro p, induction p, - esimp [lift_eq_lift_equiv,equiv.trans,equiv.symm,eq_equiv_equiv], - rewrite [equiv_of_eq_refl,lift_equiv_lift_refl], - apply ua_refl} - end - - definition plift [constructor] (A : pType.{u}) : pType.{max u v} := - pType.mk (lift A) (up pt) - - definition plift_functor [constructor] {A B : Type*} (f : A →* B) : plift A →* plift B := - pmap.mk (lift_functor f) (ap up (respect_pt f)) - - -- is_trunc_lift is defined in init.trunc - - -end lift diff --git a/hott/types/list.hlean b/hott/types/list.hlean deleted file mode 100644 index 5380b4bf97..0000000000 --- a/hott/types/list.hlean +++ /dev/null @@ -1,927 +0,0 @@ -/- -Copyright (c) 2014 Parikshit Khanna. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn - -Basic properties of lists. -Ported from the standard library (list.basic and list.comb) -Some lemmas are commented out, their proofs need to be repaired when needed --/ - -import .pointed .nat .pi - -open eq lift nat is_trunc pi pointed sum function prod option sigma algebra - -inductive list (T : Type) : Type := -| nil {} : list T -| cons : T → list T → list T - -definition pointed_list [instance] (A : Type) : pointed (list A) := -pointed.mk list.nil - -namespace list -notation h :: t := cons h t -notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l - -universe variable u -variable {T : Type.{u}} - -lemma cons_ne_nil (a : T) (l : list T) : a::l ≠ [] := -by contradiction - -lemma head_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : list A} : - (h₁::t₁) = (h₂::t₂) → h₁ = h₂ := -assume Peq, down (list.no_confusion Peq (assume Pheq Pteq, Pheq)) - -lemma tail_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : list A} : - (h₁::t₁) = (h₂::t₂) → t₁ = t₂ := -assume Peq, down (list.no_confusion Peq (assume Pheq Pteq, Pteq)) - -/- append -/ - -definition append : list T → list T → list T -| [] l := l -| (h :: s) t := h :: (append s t) - -notation l₁ ++ l₂ := append l₁ l₂ - -theorem append_nil_left (t : list T) : [] ++ t = t := idp - -theorem append_cons (x : T) (s t : list T) : (x::s) ++ t = x :: (s ++ t) := idp - -theorem append_nil_right : ∀ (t : list T), t ++ [] = t -| [] := rfl -| (a :: l) := calc - (a :: l) ++ [] = a :: (l ++ []) : rfl - ... = a :: l : append_nil_right l - -theorem append.assoc : ∀ (s t u : list T), s ++ t ++ u = s ++ (t ++ u) -| [] t u := rfl -| (a :: l) t u := - show a :: (l ++ t ++ u) = (a :: l) ++ (t ++ u), - by rewrite (append.assoc l t u) - -/- length -/ -definition length : list T → nat -| [] := 0 -| (a :: l) := length l + 1 - -theorem length_nil : length (@nil T) = 0 := idp - -theorem length_cons (x : T) (t : list T) : length (x::t) = length t + 1 := idp - -theorem length_append : ∀ (s t : list T), length (s ++ t) = length s + length t -| [] t := calc - length ([] ++ t) = length t : rfl - ... = length [] + length t : by rewrite [length_nil, zero_add] -| (a :: s) t := calc - length (a :: s ++ t) = length (s ++ t) + 1 : rfl - ... = length s + length t + 1 : length_append - ... = (length s + 1) + length t : succ_add - ... = length (a :: s) + length t : rfl - -theorem eq_nil_of_length_eq_zero : ∀ {l : list T}, length l = 0 → l = [] -| [] H := rfl -| (a::s) H := by contradiction - -theorem ne_nil_of_length_eq_succ : ∀ {l : list T} {n : nat}, length l = succ n → l ≠ [] -| [] n h := by contradiction -| (a::l) n h := by contradiction - --- add_rewrite length_nil length_cons - -/- concat -/ - -definition concat : Π (x : T), list T → list T -| a [] := [a] -| a (b :: l) := b :: concat a l - -theorem concat_nil (x : T) : concat x [] = [x] := idp - -theorem concat_cons (x y : T) (l : list T) : concat x (y::l) = y::(concat x l) := idp - -theorem concat_eq_append (a : T) : ∀ (l : list T), concat a l = l ++ [a] -| [] := rfl -| (b :: l) := - show b :: (concat a l) = (b :: l) ++ (a :: []), - by rewrite concat_eq_append - -theorem concat_ne_nil (a : T) : ∀ (l : list T), concat a l ≠ [] := -by intro l; induction l; repeat contradiction - -theorem length_concat (a : T) : ∀ (l : list T), length (concat a l) = length l + 1 -| [] := rfl -| (x::xs) := by rewrite [concat_cons, *length_cons, length_concat] - -theorem concat_append (a : T) : ∀ (l₁ l₂ : list T), concat a l₁ ++ l₂ = l₁ ++ a :: l₂ -| [] := λl₂, rfl -| (x::xs) := λl₂, begin rewrite [concat_cons,append_cons, concat_append] end - -theorem append_concat (a : T) : ∀(l₁ l₂ : list T), l₁ ++ concat a l₂ = concat a (l₁ ++ l₂) -| [] := λl₂, rfl -| (x::xs) := λl₂, begin rewrite [+append_cons, concat_cons, append_concat] end - -/- last -/ - -definition last : Π l : list T, l ≠ [] → T -| [] h := absurd rfl h -| [a] h := a -| (a₁::a₂::l) h := last (a₂::l) !cons_ne_nil - -lemma last_singleton (a : T) (h : [a] ≠ []) : last [a] h = a := -rfl - -lemma last_cons_cons (a₁ a₂ : T) (l : list T) (h : a₁::a₂::l ≠ []) - : last (a₁::a₂::l) h = last (a₂::l) !cons_ne_nil := -rfl - -theorem last_congr {l₁ l₂ : list T} (h₁ : l₁ ≠ []) (h₂ : l₂ ≠ []) (h₃ : l₁ = l₂) - : last l₁ h₁ = last l₂ h₂ := -apd011 last h₃ !is_prop.elim - -theorem last_concat {x : T} : ∀ {l : list T} (h : concat x l ≠ []), last (concat x l) h = x -| [] h := rfl -| [a] h := rfl -| (a₁::a₂::l) h := - begin - change last (a₁::a₂::concat x l) !cons_ne_nil = x, - rewrite last_cons_cons, - change last (concat x (a₂::l)) (cons_ne_nil a₂ (concat x l)) = x, - apply last_concat - end - --- add_rewrite append_nil append_cons - -/- reverse -/ - -definition reverse : list T → list T -| [] := [] -| (a :: l) := concat a (reverse l) - -theorem reverse_nil : reverse (@nil T) = [] := idp - -theorem reverse_cons (x : T) (l : list T) : reverse (x::l) = concat x (reverse l) := idp - -theorem reverse_singleton (x : T) : reverse [x] = [x] := idp - -theorem reverse_append : ∀ (s t : list T), reverse (s ++ t) = (reverse t) ++ (reverse s) -| [] t2 := calc - reverse ([] ++ t2) = reverse t2 : rfl - ... = (reverse t2) ++ [] : append_nil_right - ... = (reverse t2) ++ (reverse []) : by rewrite reverse_nil -| (a2 :: s2) t2 := calc - reverse ((a2 :: s2) ++ t2) = concat a2 (reverse (s2 ++ t2)) : rfl - ... = concat a2 (reverse t2 ++ reverse s2) : reverse_append - ... = (reverse t2 ++ reverse s2) ++ [a2] : concat_eq_append - ... = reverse t2 ++ (reverse s2 ++ [a2]) : append.assoc - ... = reverse t2 ++ concat a2 (reverse s2) : concat_eq_append - ... = reverse t2 ++ reverse (a2 :: s2) : rfl - -theorem reverse_reverse : ∀ (l : list T), reverse (reverse l) = l -| [] := rfl -| (a :: l) := calc - reverse (reverse (a :: l)) = reverse (concat a (reverse l)) : rfl - ... = reverse (reverse l ++ [a]) : concat_eq_append - ... = reverse [a] ++ reverse (reverse l) : reverse_append - ... = reverse [a] ++ l : reverse_reverse - ... = a :: l : rfl - -theorem concat_eq_reverse_cons (x : T) (l : list T) : concat x l = reverse (x :: reverse l) := -calc - concat x l = concat x (reverse (reverse l)) : reverse_reverse - ... = reverse (x :: reverse l) : rfl - -theorem length_reverse : ∀ (l : list T), length (reverse l) = length l -| [] := rfl -| (x::xs) := begin unfold reverse, rewrite [length_concat, length_cons, length_reverse] end - -/- head and tail -/ - -definition head [h : pointed T] : list T → T -| [] := pt -| (a :: l) := a - -theorem head_cons [h : pointed T] (a : T) (l : list T) : head (a::l) = a := idp - -theorem head_append [h : pointed T] (t : list T) : ∀ {s : list T}, s ≠ [] → head (s ++ t) = head s -| [] H := absurd rfl H -| (a :: s) H := - show head (a :: (s ++ t)) = head (a :: s), - by rewrite head_cons - -definition tail : list T → list T -| [] := [] -| (a :: l) := l - -theorem tail_nil : tail (@nil T) = [] := idp - -theorem tail_cons (a : T) (l : list T) : tail (a::l) = l := idp - -theorem cons_head_tail [h : pointed T] {l : list T} : l ≠ [] → (head l)::(tail l) = l := -list.cases_on l - (suppose [] ≠ [], absurd rfl this) - (take x l, suppose x::l ≠ [], rfl) - -/- list membership -/ - -definition mem : T → list T → Type.{u} -| a [] := lift empty -| a (b :: l) := a = b ⊎ mem a l - -notation e ∈ s := mem e s -notation e ∉ s := ¬ e ∈ s - -theorem mem_nil_iff (x : T) : x ∈ [] ↔ empty := -iff.intro down up - -theorem not_mem_nil (x : T) : x ∉ [] := -iff.mp !mem_nil_iff - -theorem mem_cons (x : T) (l : list T) : x ∈ x :: l := -sum.inl rfl - -theorem mem_cons_of_mem (y : T) {x : T} {l : list T} : x ∈ l → x ∈ y :: l := -assume H, sum.inr H - -theorem mem_cons_iff (x y : T) (l : list T) : x ∈ y::l ↔ (x = y ⊎ x ∈ l) := -iff.rfl - -theorem eq_or_mem_of_mem_cons {x y : T} {l : list T} : x ∈ y::l → x = y ⊎ x ∈ l := -assume h, h - -theorem mem_singleton {x a : T} : x ∈ [a] → x = a := -suppose x ∈ [a], sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose x = a, this) - (suppose x ∈ [], absurd this !not_mem_nil) - -theorem mem_of_mem_cons_of_mem {a b : T} {l : list T} : a ∈ b::l → b ∈ l → a ∈ l := -assume ainbl binl, sum.rec_on (eq_or_mem_of_mem_cons ainbl) - (suppose a = b, by substvars; exact binl) - (suppose a ∈ l, this) - -theorem mem_or_mem_of_mem_append {x : T} {s t : list T} : x ∈ s ++ t → x ∈ s ⊎ x ∈ t := -list.rec_on s sum.inr - (take y s, - assume IH : x ∈ s ++ t → x ∈ s ⊎ x ∈ t, - suppose x ∈ y::s ++ t, - have x = y ⊎ x ∈ s ++ t, from this, - have x = y ⊎ x ∈ s ⊎ x ∈ t, from sum_of_sum_of_imp_right this IH, - iff.elim_right sum.assoc this) - -theorem mem_append_of_mem_or_mem {x : T} {s t : list T} : (x ∈ s ⊎ x ∈ t) → x ∈ s ++ t := -list.rec_on s - (take H, sum.rec_on H (empty.elim ∘ down) (assume H, H)) - (take y s, - assume IH : (x ∈ s ⊎ x ∈ t) → x ∈ s ++ t, - suppose x ∈ y::s ⊎ x ∈ t, - sum.rec_on this - (suppose x ∈ y::s, - sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose x = y, sum.inl this) - (suppose x ∈ s, sum.inr (IH (sum.inl this)))) - (suppose x ∈ t, sum.inr (IH (sum.inr this)))) - -theorem mem_append_iff (x : T) (s t : list T) : x ∈ s ++ t ↔ x ∈ s ⊎ x ∈ t := -iff.intro mem_or_mem_of_mem_append mem_append_of_mem_or_mem - -theorem not_mem_of_not_mem_append_left {x : T} {s t : list T} : x ∉ s++t → x ∉ s := -λ nxinst xins, absurd (mem_append_of_mem_or_mem (sum.inl xins)) nxinst - -theorem not_mem_of_not_mem_append_right {x : T} {s t : list T} : x ∉ s++t → x ∉ t := -λ nxinst xint, absurd (mem_append_of_mem_or_mem (sum.inr xint)) nxinst - -theorem not_mem_append {x : T} {s t : list T} : x ∉ s → x ∉ t → x ∉ s++t := -λ nxins nxint xinst, sum.rec_on (mem_or_mem_of_mem_append xinst) - (λ xins, by contradiction) - (λ xint, by contradiction) - -lemma length_pos_of_mem {a : T} : ∀ {l : list T}, a ∈ l → 0 < length l -| [] := assume Pinnil, by induction Pinnil; contradiction -| (b::l) := assume Pin, !zero_lt_succ - -local attribute mem [reducible] -local attribute append [reducible] -theorem mem_split {x : T} {l : list T} : x ∈ l → Σs t : list T, l = s ++ (x::t) := -list.rec_on l - (suppose x ∈ [], empty.elim (iff.elim_left !mem_nil_iff this)) - (take y l, - assume IH : x ∈ l → Σs t : list T, l = s ++ (x::t), - suppose x ∈ y::l, - sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose x = y, - sigma.mk [] (!sigma.mk (this ▸ rfl))) - (suppose x ∈ l, - obtain s (H2 : Σt : list T, l = s ++ (x::t)), from IH this, - obtain t (H3 : l = s ++ (x::t)), from H2, - have y :: l = (y::s) ++ (x::t), - from H3 ▸ rfl, - !sigma.mk (!sigma.mk this))) - -theorem mem_append_left {a : T} {l₁ : list T} (l₂ : list T) : a ∈ l₁ → a ∈ l₁ ++ l₂ := -assume ainl₁, mem_append_of_mem_or_mem (sum.inl ainl₁) - -theorem mem_append_right {a : T} (l₁ : list T) {l₂ : list T} : a ∈ l₂ → a ∈ l₁ ++ l₂ := -assume ainl₂, mem_append_of_mem_or_mem (sum.inr ainl₂) - -definition decidable_mem [instance] [H : decidable_eq T] (x : T) (l : list T) : decidable (x ∈ l) := -list.rec_on l - (decidable.inr begin intro x, induction x, contradiction end) - (take (h : T) (l : list T) (iH : decidable (x ∈ l)), - show decidable (x ∈ h::l), from - decidable.rec_on iH - (assume Hp : x ∈ l, - decidable.rec_on (H x h) - (suppose x = h, - decidable.inl (sum.inl this)) - (suppose x ≠ h, - decidable.inl (sum.inr Hp))) - (suppose ¬x ∈ l, - decidable.rec_on (H x h) - (suppose x = h, decidable.inl (sum.inl this)) - (suppose x ≠ h, - have ¬(x = h ⊎ x ∈ l), from - suppose x = h ⊎ x ∈ l, sum.rec_on this - (suppose x = h, by contradiction) - (suppose x ∈ l, by contradiction), - have ¬x ∈ h::l, from - iff.elim_right (not_iff_not_of_iff !mem_cons_iff) this, - decidable.inr this))) - -theorem mem_of_ne_of_mem {x y : T} {l : list T} (H₁ : x ≠ y) (H₂ : x ∈ y :: l) : x ∈ l := -sum.rec_on (eq_or_mem_of_mem_cons H₂) (λe, absurd e H₁) (λr, r) - -theorem ne_of_not_mem_cons {a b : T} {l : list T} : a ∉ b::l → a ≠ b := -assume nin aeqb, absurd (sum.inl aeqb) nin - -theorem not_mem_of_not_mem_cons {a b : T} {l : list T} : a ∉ b::l → a ∉ l := -assume nin nainl, absurd (sum.inr nainl) nin - -lemma not_mem_cons_of_ne_of_not_mem {x y : T} {l : list T} : x ≠ y → x ∉ l → x ∉ y::l := -assume P1 P2, not.intro (assume Pxin, absurd (eq_or_mem_of_mem_cons Pxin) (not_sum P1 P2)) - -lemma ne_and_not_mem_of_not_mem_cons {x y : T} {l : list T} : x ∉ y::l → x ≠ y × x ∉ l := -assume P, prod.mk (ne_of_not_mem_cons P) (not_mem_of_not_mem_cons P) - -definition sublist (l₁ l₂ : list T) := ∀ ⦃a : T⦄, a ∈ l₁ → a ∈ l₂ - -infix ⊆ := sublist - -theorem nil_sub (l : list T) : [] ⊆ l := -λ b i, empty.elim (iff.mp (mem_nil_iff b) i) - -theorem sub.refl (l : list T) : l ⊆ l := -λ b i, i - -theorem sub.trans {l₁ l₂ l₃ : list T} (H₁ : l₁ ⊆ l₂) (H₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ := -λ b i, H₂ (H₁ i) - -theorem sub_cons (a : T) (l : list T) : l ⊆ a::l := -λ b i, sum.inr i - -theorem sub_of_cons_sub {a : T} {l₁ l₂ : list T} : a::l₁ ⊆ l₂ → l₁ ⊆ l₂ := -λ s b i, s b (mem_cons_of_mem _ i) - -theorem cons_sub_cons {l₁ l₂ : list T} (a : T) (s : l₁ ⊆ l₂) : (a::l₁) ⊆ (a::l₂) := -λ b Hin, sum.rec_on (eq_or_mem_of_mem_cons Hin) - (λ e : b = a, sum.inl e) - (λ i : b ∈ l₁, sum.inr (s i)) - -theorem sub_append_left (l₁ l₂ : list T) : l₁ ⊆ l₁++l₂ := -λ b i, iff.mpr (mem_append_iff b l₁ l₂) (sum.inl i) - -theorem sub_append_right (l₁ l₂ : list T) : l₂ ⊆ l₁++l₂ := -λ b i, iff.mpr (mem_append_iff b l₁ l₂) (sum.inr i) - -theorem sub_cons_of_sub (a : T) {l₁ l₂ : list T} : l₁ ⊆ l₂ → l₁ ⊆ (a::l₂) := -λ (s : l₁ ⊆ l₂) (x : T) (i : x ∈ l₁), sum.inr (s i) - -theorem sub_app_of_sub_left (l l₁ l₂ : list T) : l ⊆ l₁ → l ⊆ l₁++l₂ := -λ (s : l ⊆ l₁) (x : T) (xinl : x ∈ l), - have x ∈ l₁, from s xinl, - mem_append_of_mem_or_mem (sum.inl this) - -theorem sub_app_of_sub_right (l l₁ l₂ : list T) : l ⊆ l₂ → l ⊆ l₁++l₂ := -λ (s : l ⊆ l₂) (x : T) (xinl : x ∈ l), - have x ∈ l₂, from s xinl, - mem_append_of_mem_or_mem (sum.inr this) - -theorem cons_sub_of_sub_of_mem {a : T} {l m : list T} : a ∈ m → l ⊆ m → a::l ⊆ m := -λ (ainm : a ∈ m) (lsubm : l ⊆ m) (x : T) (xinal : x ∈ a::l), sum.rec_on (eq_or_mem_of_mem_cons xinal) - (suppose x = a, by substvars; exact ainm) - (suppose x ∈ l, lsubm this) - -theorem app_sub_of_sub_of_sub {l₁ l₂ l : list T} : l₁ ⊆ l → l₂ ⊆ l → l₁++l₂ ⊆ l := -λ (l₁subl : l₁ ⊆ l) (l₂subl : l₂ ⊆ l) (x : T) (xinl₁l₂ : x ∈ l₁++l₂), - sum.rec_on (mem_or_mem_of_mem_append xinl₁l₂) - (suppose x ∈ l₁, l₁subl this) - (suppose x ∈ l₂, l₂subl this) - -/- find -/ -section -variable [H : decidable_eq T] -include H - -definition find : T → list T → nat -| a [] := 0 -| a (b :: l) := if a = b then 0 else succ (find a l) - -theorem find_nil (x : T) : find x [] = 0 := idp - -theorem find_cons (x y : T) (l : list T) : find x (y::l) = if x = y then 0 else succ (find x l) := -idp - -theorem find_cons_of_eq {x y : T} (l : list T) : x = y → find x (y::l) = 0 := -assume e, if_pos e - -theorem find_cons_of_ne {x y : T} (l : list T) : x ≠ y → find x (y::l) = succ (find x l) := -assume n, if_neg n - -/-theorem find_of_not_mem {l : list T} {x : T} : ¬x ∈ l → find x l = length l := -list.rec_on l - (suppose ¬x ∈ [], _) - (take y l, - assume iH : ¬x ∈ l → find x l = length l, - suppose ¬x ∈ y::l, - have ¬(x = y ⊎ x ∈ l), from iff.elim_right (not_iff_not_of_iff !mem_cons_iff) this, - have ¬x = y × ¬x ∈ l, from (iff.elim_left not_sum_iff_not_prod_not this), - calc - find x (y::l) = if x = y then 0 else succ (find x l) : !find_cons - ... = succ (find x l) : if_neg (prod.pr1 this) - ... = succ (length l) : {iH (prod.pr2 this)} - ... = length (y::l) : !length_cons⁻¹)-/ - -lemma find_le_length : ∀ {a} {l : list T}, find a l ≤ length l -| a [] := !le.refl -| a (b::l) := decidable.rec_on (H a b) - (assume Peq, by rewrite [find_cons_of_eq l Peq]; exact !zero_le) - (assume Pne, - begin - rewrite [find_cons_of_ne l Pne, length_cons], - apply succ_le_succ, apply find_le_length - end) - -/-lemma not_mem_of_find_eq_length : ∀ {a} {l : list T}, find a l = length l → a ∉ l -| a [] := assume Peq, !not_mem_nil -| a (b::l) := decidable.rec_on (H a b) - (assume Peq, by rewrite [find_cons_of_eq l Peq, length_cons]; contradiction) - (assume Pne, - begin - rewrite [find_cons_of_ne l Pne, length_cons, mem_cons_iff], - intro Plen, apply (not_or Pne), - exact not_mem_of_find_eq_length (succ.inj Plen) - end)-/ - -/-lemma find_lt_length {a} {l : list T} (Pin : a ∈ l) : find a l < length l := -begin - apply nat.lt_of_le_prod_ne, - apply find_le_length, - apply not.intro, intro Peq, - exact absurd Pin (not_mem_of_find_eq_length Peq) -end-/ - -end - -/- nth element -/ -section nth -definition nth : list T → nat → option T -| [] n := none -| (a :: l) 0 := some a -| (a :: l) (n+1) := nth l n - -theorem nth_zero (a : T) (l : list T) : nth (a :: l) 0 = some a := idp - -theorem nth_succ (a : T) (l : list T) (n : nat) : nth (a::l) (succ n) = nth l n := idp - -theorem nth_eq_some : ∀ {l : list T} {n : nat}, n < length l → Σ a : T, nth l n = some a -| [] n h := absurd h !not_lt_zero -| (a::l) 0 h := ⟨a, rfl⟩ -| (a::l) (succ n) h := - have n < length l, from lt_of_succ_lt_succ h, - obtain (r : T) (req : nth l n = some r), from nth_eq_some this, - ⟨r, by rewrite [nth_succ, req]⟩ - -open decidable -theorem find_nth [h : decidable_eq T] {a : T} : ∀ {l}, a ∈ l → nth l (find a l) = some a -| [] ain := absurd ain !not_mem_nil -| (b::l) ainbl := by_cases - (λ aeqb : a = b, by rewrite [find_cons_of_eq _ aeqb, nth_zero, aeqb]) - (λ aneb : a ≠ b, sum.rec_on (eq_or_mem_of_mem_cons ainbl) - (λ aeqb : a = b, absurd aeqb aneb) - (λ ainl : a ∈ l, by rewrite [find_cons_of_ne _ aneb, nth_succ, find_nth ainl])) - -definition inth [h : pointed T] (l : list T) (n : nat) : T := -match nth l n with -| some a := a -| none := pt -end - -theorem inth_zero [h : pointed T] (a : T) (l : list T) : inth (a :: l) 0 = a := idp - -theorem inth_succ [h : pointed T] (a : T) (l : list T) (n : nat) : inth (a::l) (n+1) = inth l n := -idp -end nth - -section ith -definition ith : Π (l : list T) (i : nat), i < length l → T -| nil i h := absurd h !not_lt_zero -| (x::xs) 0 h := x -| (x::xs) (succ i) h := ith xs i (lt_of_succ_lt_succ h) - -lemma ith_zero (a : T) (l : list T) (h : 0 < length (a::l)) : ith (a::l) 0 h = a := -rfl - -lemma ith_succ (a : T) (l : list T) (i : nat) (h : succ i < length (a::l)) - : ith (a::l) (succ i) h = ith l i (lt_of_succ_lt_succ h) := -rfl -end ith - -open decidable -definition has_decidable_eq {A : Type} [H : decidable_eq A] : ∀ l₁ l₂ : list A, decidable (l₁ = l₂) -| [] [] := inl rfl -| [] (b::l₂) := inr (by contradiction) -| (a::l₁) [] := inr (by contradiction) -| (a::l₁) (b::l₂) := - match H a b with - | inl Hab := - match has_decidable_eq l₁ l₂ with - | inl He := inl (by congruence; repeat assumption) - | inr Hn := inr (by intro H; injection H; contradiction) - end - | inr Hnab := inr (by intro H; injection H; contradiction) - end - -/- quasiequal a l l' means that l' is exactly l, with a added - once somewhere -/ -section qeq -variable {A : Type.{u}} -inductive qeq (a : A) : list A → list A → Type.{u} := -| qhead : ∀ l, qeq a l (a::l) -| qcons : ∀ (b : A) {l l' : list A}, qeq a l l' → qeq a (b::l) (b::l') - -open qeq - -notation l' `≈`:50 a `|` l:50 := qeq a l l' - -theorem qeq_app : ∀ (l₁ : list A) (a : A) (l₂ : list A), l₁++(a::l₂) ≈ a|l₁++l₂ -| [] a l₂ := qhead a l₂ -| (x::xs) a l₂ := qcons x (qeq_app xs a l₂) - -theorem mem_head_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → a ∈ l₁ := -take q, qeq.rec_on q - (λ l, !mem_cons) - (λ b l l' q r, sum.inr r) - -theorem mem_tail_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → ∀ x, x ∈ l₂ → x ∈ l₁ := -take q, qeq.rec_on q - (λ l x i, sum.inr i) - (λ b l l' q r x xinbl, sum.rec_on (eq_or_mem_of_mem_cons xinbl) - (λ xeqb : x = b, xeqb ▸ mem_cons x l') - (λ xinl : x ∈ l, sum.inr (r x xinl))) - -/- -theorem mem_cons_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → ∀ x, x ∈ l₁ → x ∈ a::l₂ := -take q, qeq.rec_on q - (λ l x i, i) - (λ b l l' q r x xinbl', sum.elim_on (eq_or_mem_of_mem_cons xinbl') - (λ xeqb : x = b, xeqb ▸ sum.inr (mem_cons x l)) - (λ xinl' : x ∈ l', sum.rec_on (eq_or_mem_of_mem_cons (r x xinl')) - (λ xeqa : x = a, xeqa ▸ mem_cons x (b::l)) - (λ xinl : x ∈ l, sum.inr (sum.inr xinl))))-/ - -theorem length_eq_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → length l₁ = succ (length l₂) := -take q, qeq.rec_on q - (λ l, rfl) - (λ b l l' q r, by rewrite [*length_cons, r]) - -theorem qeq_of_mem {a : A} {l : list A} : a ∈ l → (Σl', l≈a|l') := -list.rec_on l - (λ h : a ∈ nil, absurd h (not_mem_nil a)) - (λ x xs r ainxxs, sum.rec_on (eq_or_mem_of_mem_cons ainxxs) - (λ aeqx : a = x, - have aux : Σ l, x::xs≈x|l, from - sigma.mk xs (qhead x xs), - by rewrite aeqx; exact aux) - (λ ainxs : a ∈ xs, - have Σl', xs ≈ a|l', from r ainxs, - obtain (l' : list A) (q : xs ≈ a|l'), from this, - have x::xs ≈ a | x::l', from qcons x q, - sigma.mk (x::l') this)) - -theorem qeq_split {a : A} {l l' : list A} : l'≈a|l → Σl₁ l₂, l = l₁++l₂ × l' = l₁++(a::l₂) := -take q, qeq.rec_on q - (λ t, - have t = []++t × a::t = []++(a::t), from prod.mk rfl rfl, - sigma.mk [] (sigma.mk t this)) - (λ b t t' q r, - obtain (l₁ l₂ : list A) (h : t = l₁++l₂ × t' = l₁++(a::l₂)), from r, - have b::t = (b::l₁)++l₂ × b::t' = (b::l₁)++(a::l₂), - begin - rewrite [prod.pr2 h, prod.pr1 h], - constructor, repeat reflexivity - end, - sigma.mk (b::l₁) (sigma.mk l₂ this)) - -/-theorem sub_of_mem_of_sub_of_qeq {a : A} {l : list A} {u v : list A} : a ∉ l → a::l ⊆ v → v≈a|u → l ⊆ u := -λ (nainl : a ∉ l) (s : a::l ⊆ v) (q : v≈a|u) (x : A) (xinl : x ∈ l), - have x ∈ v, from s (sum.inr xinl), - have x ∈ a::u, from mem_cons_of_qeq q x this, - sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose x = a, by substvars; contradiction) - (suppose x ∈ u, this)-/ -end qeq - -section firstn -variable {A : Type} - -definition firstn : nat → list A → list A -| 0 l := [] -| (n+1) [] := [] -| (n+1) (a::l) := a :: firstn n l - -lemma firstn_zero : ∀ (l : list A), firstn 0 l = [] := -by intros; reflexivity - -lemma firstn_nil : ∀ n, firstn n [] = ([] : list A) -| 0 := rfl -| (n+1) := rfl - -lemma firstn_cons : ∀ n (a : A) (l : list A), firstn (succ n) (a::l) = a :: firstn n l := -by intros; reflexivity - -lemma firstn_all : ∀ (l : list A), firstn (length l) l = l -| [] := rfl -| (a::l) := begin unfold [length, firstn], rewrite firstn_all end - -/-lemma firstn_all_of_ge : ∀ {n} {l : list A}, n ≥ length l → firstn n l = l -| 0 [] h := rfl -| 0 (a::l) h := absurd h (not_le_of_gt !succ_pos) -| (n+1) [] h := rfl -| (n+1) (a::l) h := begin unfold firstn, rewrite [firstn_all_of_ge (le_of_succ_le_succ h)] end-/ - -/-lemma firstn_firstn : ∀ (n m) (l : list A), firstn n (firstn m l) = firstn (min n m) l -| n 0 l := by rewrite [min_zero, firstn_zero, firstn_nil] -| 0 m l := by rewrite [zero_min] -| (succ n) (succ m) nil := by rewrite [*firstn_nil] -| (succ n) (succ m) (a::l) := by rewrite [*firstn_cons, firstn_firstn, min_succ_succ]-/ - -lemma length_firstn_le : ∀ (n) (l : list A), length (firstn n l) ≤ n -| 0 l := by rewrite [firstn_zero] -| (succ n) (a::l) := by rewrite [firstn_cons, length_cons, add_one]; apply succ_le_succ; apply length_firstn_le -| (succ n) [] := by rewrite [firstn_nil, length_nil]; apply zero_le - -/-lemma length_firstn_eq : ∀ (n) (l : list A), length (firstn n l) = min n (length l) -| 0 l := by rewrite [firstn_zero, zero_min] -| (succ n) (a::l) := by rewrite [firstn_cons, *length_cons, *add_one, min_succ_succ, length_firstn_eq] -| (succ n) [] := by rewrite [firstn_nil]-/ -end firstn - -section count -variable {A : Type} -variable [decA : decidable_eq A] -include decA - -definition count (a : A) : list A → nat -| [] := 0 -| (x::xs) := if a = x then succ (count xs) else count xs - -lemma count_nil (a : A) : count a [] = 0 := -rfl - -lemma count_cons (a b : A) (l : list A) : count a (b::l) = if a = b then succ (count a l) else count a l := -rfl - -lemma count_cons_eq (a : A) (l : list A) : count a (a::l) = succ (count a l) := -if_pos rfl - -lemma count_cons_of_ne {a b : A} (h : a ≠ b) (l : list A) : count a (b::l) = count a l := -if_neg h - -lemma count_cons_ge_count (a b : A) (l : list A) : count a (b::l) ≥ count a l := -by_cases - (suppose a = b, begin subst b, rewrite count_cons_eq, apply le_succ end) - (suppose a ≠ b, begin rewrite (count_cons_of_ne this), apply le.refl end) - -lemma count_singleton (a : A) : count a [a] = 1 := -by rewrite count_cons_eq - -lemma count_append (a : A) : ∀ l₁ l₂, count a (l₁++l₂) = count a l₁ + count a l₂ -| [] l₂ := by rewrite [append_nil_left, count_nil, zero_add] -| (b::l₁) l₂ := by_cases - (suppose a = b, by rewrite [-this, append_cons, *count_cons_eq, succ_add, count_append]) - (suppose a ≠ b, by rewrite [append_cons, *count_cons_of_ne this, count_append]) - -lemma count_concat (a : A) (l : list A) : count a (concat a l) = succ (count a l) := -by rewrite [concat_eq_append, count_append, count_singleton] - -lemma mem_of_count_gt_zero : ∀ {a : A} {l : list A}, count a l > 0 → a ∈ l -| a [] h := absurd h !lt.irrefl -| a (b::l) h := by_cases - (suppose a = b, begin subst b, apply mem_cons end) - (suppose a ≠ b, - have count a l > 0, by rewrite [count_cons_of_ne this at h]; exact h, - have a ∈ l, from mem_of_count_gt_zero this, - show a ∈ b::l, from mem_cons_of_mem _ this) - -/-lemma count_gt_zero_of_mem : ∀ {a : A} {l : list A}, a ∈ l → count a l > 0 -| a [] h := absurd h !not_mem_nil -| a (b::l) h := sum.rec_on h - (suppose a = b, begin subst b, rewrite count_cons_eq, apply zero_lt_succ end) - (suppose a ∈ l, calc - count a (b::l) ≥ count a l : count_cons_ge_count - ... > 0 : count_gt_zero_of_mem this)-/ - -/-lemma count_eq_zero_of_not_mem {a : A} {l : list A} (h : a ∉ l) : count a l = 0 := -match count a l with -| zero := suppose count a l = zero, this -| (succ n) := suppose count a l = succ n, absurd (mem_of_count_gt_zero (begin rewrite this, exact dec_trivial end)) h -end rfl-/ - -end count -end list - -attribute list.has_decidable_eq [instance] ---attribute list.decidable_mem [instance] - -namespace list - -variables {A B C : Type} -/- map -/ -definition map (f : A → B) : list A → list B -| [] := [] -| (a :: l) := f a :: map l - -theorem map_nil (f : A → B) : map f [] = [] := idp - -theorem map_cons (f : A → B) (a : A) (l : list A) : map f (a :: l) = f a :: map f l := idp - -lemma map_concat (f : A → B) (a : A) : Πl, map f (concat a l) = concat (f a) (map f l) -| nil := rfl -| (b::l) := begin rewrite [concat_cons, +map_cons, concat_cons, map_concat] end - -lemma map_append (f : A → B) : Π l₁ l₂, map f (l₁++l₂) = (map f l₁)++(map f l₂) -| nil := take l, rfl -| (a::l) := take l', begin rewrite [append_cons, *map_cons, append_cons, map_append] end - -lemma map_reverse (f : A → B) : Πl, map f (reverse l) = reverse (map f l) -| nil := rfl -| (b::l) := begin rewrite [reverse_cons, +map_cons, reverse_cons, map_concat, map_reverse] end - -lemma map_singleton (f : A → B) (a : A) : map f [a] = [f a] := rfl - -theorem map_id : Π l : list A, map id l = l -| [] := rfl -| (x::xs) := begin rewrite [map_cons, map_id] end - -theorem map_id' {f : A → A} (H : Πx, f x = x) : Π l : list A, map f l = l -| [] := rfl -| (x::xs) := begin rewrite [map_cons, H, map_id'] end - -theorem map_map (g : B → C) (f : A → B) : Π l, map g (map f l) = map (g ∘ f) l -| [] := rfl -| (a :: l) := - show (g ∘ f) a :: map g (map f l) = map (g ∘ f) (a :: l), - by rewrite (map_map l) - -theorem length_map (f : A → B) : Π l : list A, length (map f l) = length l -| [] := by esimp -| (a :: l) := - show length (map f l) + 1 = length l + 1, - by rewrite (length_map l) - -theorem mem_map {A B : Type} (f : A → B) : Π {a l}, a ∈ l → f a ∈ map f l -| a [] i := absurd i !not_mem_nil -| a (x::xs) i := sum.rec_on (eq_or_mem_of_mem_cons i) - (suppose a = x, by rewrite [this, map_cons]; apply mem_cons) - (suppose a ∈ xs, sum.inr (mem_map this)) - -theorem exists_of_mem_map {A B : Type} {f : A → B} {b : B} : - Π{l}, b ∈ map f l → Σa, a ∈ l × f a = b -| [] H := empty.elim (down H) -| (c::l) H := sum.rec_on (iff.mp !mem_cons_iff H) - (suppose b = f c, - sigma.mk c (pair !mem_cons (inverse this))) - (suppose b ∈ map f l, - obtain a (Hl : a ∈ l) (Hr : f a = b), from exists_of_mem_map this, - sigma.mk a (pair (mem_cons_of_mem _ Hl) Hr)) - -theorem eq_of_map_const {A B : Type} {b₁ b₂ : B} : Π {l : list A}, b₁ ∈ map (const A b₂) l → b₁ = b₂ -| [] h := absurd h !not_mem_nil -| (a::l) h := - sum.rec_on (eq_or_mem_of_mem_cons h) - (suppose b₁ = b₂, this) - (suppose b₁ ∈ map (const A b₂) l, eq_of_map_const this) - -definition map₂ (f : A → B → C) : list A → list B → list C -| [] _ := [] -| _ [] := [] -| (x::xs) (y::ys) := f x y :: map₂ xs ys - -/- filter -/ -definition filter (p : A → Type) [h : decidable_pred p] : list A → list A -| [] := [] -| (a::l) := if p a then a :: filter l else filter l - -theorem filter_nil (p : A → Type) [h : decidable_pred p] : filter p [] = [] := idp - -theorem filter_cons_of_pos {p : A → Type} [h : decidable_pred p] {a : A} : Π l, p a → filter p (a::l) = a :: filter p l := -λ l pa, if_pos pa - -theorem filter_cons_of_neg {p : A → Type} [h : decidable_pred p] {a : A} : Π l, ¬ p a → filter p (a::l) = filter p l := -λ l pa, if_neg pa - -/- -theorem of_mem_filter {p : A → Type} [h : decidable_pred p] {a : A} : Π {l}, a ∈ filter p l → p a -| [] ain := absurd ain !not_mem_nil -| (b::l) ain := by_cases - (assume pb : p b, - have a ∈ b :: filter p l, by rewrite [filter_cons_of_pos _ pb at ain]; exact ain, - sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose a = b, by rewrite [-this at pb]; exact pb) - (suppose a ∈ filter p l, of_mem_filter this)) - (suppose ¬ p b, by rewrite [filter_cons_of_neg _ this at ain]; exact (of_mem_filter ain)) - -theorem mem_of_mem_filter {p : A → Type} [h : decidable_pred p] {a : A} : Π {l}, a ∈ filter p l → a ∈ l -| [] ain := absurd ain !not_mem_nil -| (b::l) ain := by_cases - (λ pb : p b, - have a ∈ b :: filter p l, by rewrite [filter_cons_of_pos _ pb at ain]; exact ain, - sum.rec_on (eq_or_mem_of_mem_cons this) - (suppose a = b, by rewrite this; exact !mem_cons) - (suppose a ∈ filter p l, mem_cons_of_mem _ (mem_of_mem_filter this))) - (suppose ¬ p b, by rewrite [filter_cons_of_neg _ this at ain]; exact (mem_cons_of_mem _ (mem_of_mem_filter ain))) - -theorem mem_filter_of_mem {p : A → Type} [h : decidable_pred p] {a : A} : Π {l}, a ∈ l → p a → a ∈ filter p l -| [] ain pa := absurd ain !not_mem_nil -| (b::l) ain pa := by_cases - (λ pb : p b, sum.rec_on (eq_or_mem_of_mem_cons ain) - (λ aeqb : a = b, by rewrite [filter_cons_of_pos _ pb, aeqb]; exact !mem_cons) - (λ ainl : a ∈ l, by rewrite [filter_cons_of_pos _ pb]; exact (mem_cons_of_mem _ (mem_filter_of_mem ainl pa)))) - (λ npb : ¬ p b, sum.rec_on (eq_or_mem_of_mem_cons ain) - (λ aeqb : a = b, absurd (eq.rec_on aeqb pa) npb) - (λ ainl : a ∈ l, by rewrite [filter_cons_of_neg _ npb]; exact (mem_filter_of_mem ainl pa))) - -theorem filter_sub {p : A → Type} [h : decidable_pred p] (l : list A) : filter p l ⊆ l := -λ a ain, mem_of_mem_filter ain - -theorem filter_append {p : A → Type} [h : decidable_pred p] : Π (l₁ l₂ : list A), filter p (l₁++l₂) = filter p l₁ ++ filter p l₂ -| [] l₂ := rfl -| (a::l₁) l₂ := by_cases - (suppose p a, by rewrite [append_cons, *filter_cons_of_pos _ this, filter_append]) - (suppose ¬ p a, by rewrite [append_cons, *filter_cons_of_neg _ this, filter_append]) --/ - -/- foldl & foldr -/ -definition foldl (f : A → B → A) : A → list B → A -| a [] := a -| a (b :: l) := foldl (f a b) l - -theorem foldl_nil (f : A → B → A) (a : A) : foldl f a [] = a := idp - -theorem foldl_cons (f : A → B → A) (a : A) (b : B) (l : list B) : foldl f a (b::l) = foldl f (f a b) l := idp - -definition foldr (f : A → B → B) : B → list A → B -| b [] := b -| b (a :: l) := f a (foldr b l) - -theorem foldr_nil (f : A → B → B) (b : B) : foldr f b [] = b := idp - -theorem foldr_cons (f : A → B → B) (b : B) (a : A) (l : list A) : foldr f b (a::l) = f a (foldr f b l) := idp - -section foldl_eq_foldr - -- foldl and foldr coincide when f is commutative and associative - parameters {α : Type} {f : α → α → α} - hypothesis (Hcomm : Π a b, f a b = f b a) - hypothesis (Hassoc : Π a b c, f (f a b) c = f a (f b c)) - include Hcomm Hassoc - - theorem foldl_eq_of_comm_of_assoc : Π a b l, foldl f a (b::l) = f b (foldl f a l) - | a b nil := Hcomm a b - | a b (c::l) := - begin - change foldl f (f (f a b) c) l = f b (foldl f (f a c) l), - rewrite -foldl_eq_of_comm_of_assoc, - change foldl f (f (f a b) c) l = foldl f (f (f a c) b) l, - have H₁ : f (f a b) c = f (f a c) b, by rewrite [Hassoc, Hassoc, Hcomm b c], - rewrite H₁ - end - - theorem foldl_eq_foldr : Π a l, foldl f a l = foldr f a l - | a nil := rfl - | a (b :: l) := - begin - rewrite foldl_eq_of_comm_of_assoc, - esimp, - change f b (foldl f a l) = f b (foldr f a l), - rewrite foldl_eq_foldr - end -end foldl_eq_foldr - -theorem foldl_append (f : B → A → B) : Π (b : B) (l₁ l₂ : list A), foldl f b (l₁++l₂) = foldl f (foldl f b l₁) l₂ -| b [] l₂ := rfl -| b (a::l₁) l₂ := by rewrite [append_cons, *foldl_cons, foldl_append] - -theorem foldr_append (f : A → B → B) : Π (b : B) (l₁ l₂ : list A), foldr f b (l₁++l₂) = foldr f (foldr f b l₂) l₁ -| b [] l₂ := rfl -| b (a::l₁) l₂ := by rewrite [append_cons, *foldr_cons, foldr_append] - -end list diff --git a/hott/types/nat/basic.hlean b/hott/types/nat/basic.hlean deleted file mode 100644 index 565340ea98..0000000000 --- a/hott/types/nat/basic.hlean +++ /dev/null @@ -1,318 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -(Ported from standard library) -Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad - -Basic operations on the natural numbers. --/ -import ..num algebra.ring -open prod binary eq algebra lift is_trunc - -namespace nat - -/- a variant of add, defined by recursion on the first argument -/ - -definition addl (x y : ℕ) : ℕ := -nat.rec y (λ n r, succ r) x -infix ` ⊕ `:65 := addl - -theorem addl_succ_right (n m : ℕ) : n ⊕ succ m = succ (n ⊕ m) := -nat.rec_on n - rfl - (λ n₁ ih, calc - succ n₁ ⊕ succ m = succ (n₁ ⊕ succ m) : rfl - ... = succ (succ (n₁ ⊕ m)) : ih - ... = succ (succ n₁ ⊕ m) : rfl) - -theorem add_eq_addl (x : ℕ) : Πy, x + y = x ⊕ y := -nat.rec_on x - (λ y, nat.rec_on y - rfl - (λ y₁ ih, calc - 0 + succ y₁ = succ (0 + y₁) : rfl - ... = succ (0 ⊕ y₁) : {ih} - ... = 0 ⊕ (succ y₁) : rfl)) - (λ x₁ ih₁ y, nat.rec_on y - (calc - succ x₁ + 0 = succ (x₁ + 0) : rfl - ... = succ (x₁ ⊕ 0) : {ih₁ 0} - ... = succ x₁ ⊕ 0 : rfl) - (λ y₁ ih₂, calc - succ x₁ + succ y₁ = succ (succ x₁ + y₁) : rfl - ... = succ (succ x₁ ⊕ y₁) : {ih₂} - ... = succ x₁ ⊕ succ y₁ : addl_succ_right)) - -/- successor and predecessor -/ - -theorem succ_ne_zero (n : ℕ) : succ n ≠ 0 := -by contradiction - --- add_rewrite succ_ne_zero - -theorem pred_zero [simp] : pred 0 = 0 := -rfl - -theorem pred_succ [simp] (n : ℕ) : pred (succ n) = n := -rfl - -theorem eq_zero_sum_eq_succ_pred (n : ℕ) : n = 0 ⊎ n = succ (pred n) := -nat.rec_on n - (sum.inl rfl) - (take m IH, sum.inr - (show succ m = succ (pred (succ m)), from ap succ !pred_succ⁻¹)) - -theorem exists_eq_succ_of_ne_zero {n : ℕ} (H : n ≠ 0) : Σk : ℕ, n = succ k := -sigma.mk _ (sum_resolve_right !eq_zero_sum_eq_succ_pred H) - -theorem succ.inj {n m : ℕ} (H : succ n = succ m) : n = m := -down (nat.no_confusion H imp.id) - -abbreviation eq_of_succ_eq_succ := @succ.inj - -theorem succ_ne_self {n : ℕ} : succ n ≠ n := -nat.rec_on n - (take H : 1 = 0, - have ne : 1 ≠ 0, from !succ_ne_zero, - absurd H ne) - (take k IH H, IH (succ.inj H)) - -theorem discriminate {B : Type} {n : ℕ} (H1: n = 0 → B) (H2 : Πm, n = succ m → B) : B := -have H : n = n → B, from nat.cases_on n H1 H2, -H rfl - -theorem two_step_rec_on {P : ℕ → Type} (a : ℕ) (H1 : P 0) (H2 : P 1) - (H3 : Π (n : ℕ) (IH1 : P n) (IH2 : P (succ n)), P (succ (succ n))) : P a := -have stronger : P a × P (succ a), from - nat.rec_on a - (pair H1 H2) - (take k IH, - have IH1 : P k, from prod.pr1 IH, - have IH2 : P (succ k), from prod.pr2 IH, - pair IH2 (H3 k IH1 IH2)), - prod.pr1 stronger - -theorem sub_induction {P : ℕ → ℕ → Type} (n m : ℕ) (H1 : Πm, P 0 m) - (H2 : Πn, P (succ n) 0) (H3 : Πn m, P n m → P (succ n) (succ m)) : P n m := -have general : Πm, P n m, from nat.rec_on n H1 - (take k : ℕ, - assume IH : Πm, P k m, - take m : ℕ, - nat.cases_on m (H2 k) (take l, (H3 k l (IH l)))), -general m - -/- addition -/ - -protected definition add_zero [simp] (n : ℕ) : n + 0 = n := -rfl - -definition add_succ [simp] (n m : ℕ) : n + succ m = succ (n + m) := -rfl - -protected definition zero_add [simp] (n : ℕ) : 0 + n = n := -begin - induction n with n IH, - reflexivity, - exact ap succ IH -end - -definition succ_add [simp] (n m : ℕ) : (succ n) + m = succ (n + m) := -begin - induction m with m IH, - reflexivity, - exact ap succ IH -end - -protected definition add_comm [simp] (n m : ℕ) : n + m = m + n := -begin - induction n with n IH, - { apply nat.zero_add}, - { exact !succ_add ⬝ ap succ IH} -end - -protected definition add_add (n l k : ℕ) : n + l + k = n + (k + l) := -begin - induction l with l IH, - reflexivity, - exact succ_add (n + l) k ⬝ ap succ IH -end - -definition succ_add_eq_succ_add (n m : ℕ) : succ n + m = n + succ m := -!succ_add - -protected definition add_assoc [simp] (n m k : ℕ) : (n + m) + k = n + (m + k) := -begin - induction k with k IH, - reflexivity, - exact ap succ IH -end - -protected theorem add_left_comm : Π (n m k : ℕ), n + (m + k) = m + (n + k) := -left_comm nat.add_comm nat.add_assoc - -protected theorem add_right_comm : Π (n m k : ℕ), n + m + k = n + k + m := -right_comm nat.add_comm nat.add_assoc - -protected theorem add_left_cancel {n m k : ℕ} : n + m = n + k → m = k := -nat.rec_on n - (take H : 0 + m = 0 + k, - !nat.zero_add⁻¹ ⬝ H ⬝ !nat.zero_add) - (take (n : ℕ) (IH : n + m = n + k → m = k) (H : succ n + m = succ n + k), - have succ (n + m) = succ (n + k), - from calc - succ (n + m) = succ n + m : succ_add - ... = succ n + k : H - ... = succ (n + k) : succ_add, - have n + m = n + k, from succ.inj this, - IH this) - -protected theorem add_right_cancel {n m k : ℕ} (H : n + m = k + m) : n = k := -have H2 : m + n = m + k, from !nat.add_comm ⬝ H ⬝ !nat.add_comm, - nat.add_left_cancel H2 - -theorem eq_zero_of_add_eq_zero_right {n m : ℕ} : n + m = 0 → n = 0 := -nat.rec_on n - (take (H : 0 + m = 0), rfl) - (take k IH, - assume H : succ k + m = 0, - absurd - (show succ (k + m) = 0, from calc - succ (k + m) = succ k + m : succ_add - ... = 0 : H) - !succ_ne_zero) - -theorem eq_zero_of_add_eq_zero_left {n m : ℕ} (H : n + m = 0) : m = 0 := -eq_zero_of_add_eq_zero_right (!nat.add_comm ⬝ H) - -theorem eq_zero_prod_eq_zero_of_add_eq_zero {n m : ℕ} (H : n + m = 0) : n = 0 × m = 0 := -pair (eq_zero_of_add_eq_zero_right H) (eq_zero_of_add_eq_zero_left H) - -theorem add_one [simp] (n : ℕ) : n + 1 = succ n := rfl - -theorem one_add (n : ℕ) : 1 + n = succ n := -!nat.zero_add ▸ !succ_add - -/- multiplication -/ - -protected theorem mul_zero [simp] (n : ℕ) : n * 0 = 0 := -rfl - -theorem mul_succ [simp] (n m : ℕ) : n * succ m = n * m + n := -rfl - --- commutativity, distributivity, associativity, identity - -protected theorem zero_mul [simp] (n : ℕ) : 0 * n = 0 := -nat.rec_on n - !nat.mul_zero - (take m IH, !mul_succ ⬝ !nat.add_zero ⬝ IH) - -theorem succ_mul [simp] (n m : ℕ) : (succ n) * m = (n * m) + m := -nat.rec_on m - (by rewrite nat.mul_zero) - (take k IH, calc - succ n * succ k = succ n * k + succ n : mul_succ - ... = n * k + k + succ n : IH - ... = n * k + (k + succ n) : nat.add_assoc - ... = n * k + (succ n + k) : nat.add_comm - ... = n * k + (n + succ k) : succ_add_eq_succ_add - ... = n * k + n + succ k : nat.add_assoc - ... = n * succ k + succ k : mul_succ) - -protected theorem mul_comm [simp] (n m : ℕ) : n * m = m * n := -nat.rec_on m - (!nat.mul_zero ⬝ !nat.zero_mul⁻¹) - (take k IH, calc - n * succ k = n * k + n : mul_succ - ... = k * n + n : IH - ... = (succ k) * n : succ_mul) - -protected theorem right_distrib (n m k : ℕ) : (n + m) * k = n * k + m * k := -nat.rec_on k - (calc - (n + m) * 0 = 0 : nat.mul_zero - ... = 0 + 0 : nat.add_zero - ... = n * 0 + 0 : nat.mul_zero - ... = n * 0 + m * 0 : nat.mul_zero) - (take l IH, calc - (n + m) * succ l = (n + m) * l + (n + m) : mul_succ - ... = n * l + m * l + (n + m) : IH - ... = n * l + m * l + n + m : nat.add_assoc - ... = n * l + n + m * l + m : nat.add_right_comm - ... = n * l + n + (m * l + m) : nat.add_assoc - ... = n * succ l + (m * l + m) : mul_succ - ... = n * succ l + m * succ l : mul_succ) - -protected theorem left_distrib (n m k : ℕ) : n * (m + k) = n * m + n * k := -calc - n * (m + k) = (m + k) * n : nat.mul_comm - ... = m * n + k * n : nat.right_distrib - ... = n * m + k * n : nat.mul_comm - ... = n * m + n * k : nat.mul_comm - -protected theorem mul_assoc [simp] (n m k : ℕ) : (n * m) * k = n * (m * k) := -nat.rec_on k - (calc - (n * m) * 0 = n * (m * 0) : nat.mul_zero) - (take l IH, - calc - (n * m) * succ l = (n * m) * l + n * m : mul_succ - ... = n * (m * l) + n * m : IH - ... = n * (m * l + m) : nat.left_distrib - ... = n * (m * succ l) : mul_succ) - -protected theorem mul_one [simp] (n : ℕ) : n * 1 = n := -calc - n * 1 = n * 0 + n : mul_succ - ... = 0 + n : nat.mul_zero - ... = n : nat.zero_add - -protected theorem one_mul [simp] (n : ℕ) : 1 * n = n := -calc - 1 * n = n * 1 : nat.mul_comm - ... = n : nat.mul_one - -theorem eq_zero_sum_eq_zero_of_mul_eq_zero {n m : ℕ} : n * m = 0 → n = 0 ⊎ m = 0 := -nat.cases_on n - (assume H, sum.inl rfl) - (take n', - nat.cases_on m - (assume H, sum.inr rfl) - (take m', - assume H : succ n' * succ m' = 0, - absurd - (calc - 0 = succ n' * succ m' : H - ... = succ n' * m' + succ n' : mul_succ - ... = succ (succ n' * m' + n') : add_succ)⁻¹ - !succ_ne_zero)) - -protected definition comm_semiring [trans_instance] : comm_semiring nat := -⦃comm_semiring, - add := nat.add, - add_assoc := nat.add_assoc, - zero := nat.zero, - zero_add := nat.zero_add, - add_zero := nat.add_zero, - add_comm := nat.add_comm, - mul := nat.mul, - mul_assoc := nat.mul_assoc, - one := nat.succ nat.zero, - one_mul := nat.one_mul, - mul_one := nat.mul_one, - left_distrib := nat.left_distrib, - right_distrib := nat.right_distrib, - zero_mul := nat.zero_mul, - mul_zero := nat.mul_zero, - mul_comm := nat.mul_comm, - is_set_carrier:= _⦄ -end nat - -section -open nat -definition iterate {A : Type} (op : A → A) : ℕ → A → A - | 0 := λ a, a - | (succ k) := λ a, op (iterate k a) - -notation f`^[`n`]` := iterate f n -end diff --git a/hott/types/nat/default.hlean b/hott/types/nat/default.hlean deleted file mode 100644 index 0bcbecc875..0000000000 --- a/hott/types/nat/default.hlean +++ /dev/null @@ -1,7 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn --/ - -import .basic .order .sub .hott diff --git a/hott/types/nat/div.hlean b/hott/types/nat/div.hlean deleted file mode 100644 index 8bd1fc4e32..0000000000 --- a/hott/types/nat/div.hlean +++ /dev/null @@ -1,619 +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 - -Definitions prod properties of div prod mod. Much of the development follows Isabelle's library. --/ -import .sub -open eq eq.ops well_founded decidable prod algebra - -set_option class.force_new true - -namespace nat - -/- div -/ - --- auxiliary lemma used to justify div -private definition div_rec_lemma {x y : nat} : 0 < y × y ≤ x → x - y < x := -prod.rec (λ ypos ylex, sub_lt (lt_of_lt_of_le ypos ylex) ypos) - -private definition div.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := -if H : 0 < y × y ≤ x then f (x - y) (div_rec_lemma H) y + 1 else zero - -protected definition div := fix div.F - -definition nat_has_divide [reducible] [instance] [priority nat.prio] : has_div nat := -has_div.mk nat.div - -theorem div_def (x y : nat) : div x y = if 0 < y × y ≤ x then div (x - y) y + 1 else 0 := -congr_fun (fix_eq div.F x) y - -protected theorem div_zero [simp] (a : ℕ) : a / 0 = 0 := -div_def a 0 ⬝ if_neg (!not_prod_of_not_left (lt.irrefl 0)) - -theorem div_eq_zero_of_lt {a b : ℕ} (h : a < b) : a / b = 0 := -div_def a b ⬝ if_neg (!not_prod_of_not_right (not_le_of_gt h)) - -protected theorem zero_div [simp] (b : ℕ) : 0 / b = 0 := -div_def 0 b ⬝ if_neg (prod.rec not_le_of_gt) - -theorem div_eq_succ_sub_div {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a / b = succ ((a - b) / b) := -div_def a b ⬝ if_pos (pair h₁ h₂) - -theorem add_div_self (x : ℕ) {z : ℕ} (H : z > 0) : (x + z) / z = succ (x / z) := -calc - (x + z) / z = if 0 < z × z ≤ x + z then (x + z - z) / z + 1 else 0 : !div_def - ... = (x + z - z) / z + 1 : if_pos (pair H (le_add_left z x)) - ... = succ (x / z) : {!nat.add_sub_cancel} - -theorem add_div_self_left {x : ℕ} (z : ℕ) (H : x > 0) : (x + z) / x = succ (z / x) := -!add.comm ▸ !add_div_self H - -local attribute succ_mul [simp] - -theorem add_mul_div_self {x y z : ℕ} (H : z > 0) : (x + y * z) / z = x / z + y := -nat.rec_on y - (by rewrite [zero_mul]) - (take y, - assume IH : (x + y * z) / z = x / z + y, calc - (x + succ y * z) / z = (x + y * z + z) / z : by rewrite [succ_mul, add.assoc] - ... = succ ((x + y * z) / z) : !add_div_self H - ... = succ (x / z + y) : IH) - -theorem add_mul_div_self_left (x z : ℕ) {y : ℕ} (H : y > 0) : (x + y * z) / y = x / y + z := -!mul.comm ▸ add_mul_div_self H - -protected theorem mul_div_cancel (m : ℕ) {n : ℕ} (H : n > 0) : m * n / n = m := -calc - m * n / n = (0 + m * n) / n : by rewrite [zero_add] - ... = 0 / n + m : add_mul_div_self H - ... = m : by rewrite [nat.zero_div, zero_add] - -protected theorem mul_div_cancel_left {m : ℕ} (n : ℕ) (H : m > 0) : m * n / m = n := -!mul.comm ▸ !nat.mul_div_cancel H - -/- mod -/ - -private definition mod.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := -if H : 0 < y × y ≤ x then f (x - y) (div_rec_lemma H) y else x - -protected definition mod := fix mod.F - -definition nat_has_mod [reducible] [instance] [priority nat.prio] : has_mod nat := -has_mod.mk nat.mod - -notation [priority nat.prio] a ≡ b `[mod `:0 c:0 `]` := a % c = b % c - -theorem mod_def (x y : nat) : mod x y = if 0 < y × y ≤ x then mod (x - y) y else x := -congr_fun (fix_eq mod.F x) y - -theorem mod_zero [simp] (a : ℕ) : a % 0 = a := -mod_def a 0 ⬝ if_neg (!not_prod_of_not_left (lt.irrefl 0)) - -theorem mod_eq_of_lt {a b : ℕ} (h : a < b) : a % b = a := -mod_def a b ⬝ if_neg (!not_prod_of_not_right (not_le_of_gt h)) - -theorem zero_mod [simp] (b : ℕ) : 0 % b = 0 := -mod_def 0 b ⬝ if_neg (λ h, prod.rec_on h (λ l r, absurd (lt_of_lt_of_le l r) (lt.irrefl 0))) - -theorem mod_eq_sub_mod {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a % b = (a - b) % b := -mod_def a b ⬝ if_pos (pair h₁ h₂) - -theorem add_mod_self [simp] (x z : ℕ) : (x + z) % z = x % z := -by_cases_zero_pos z - (by rewrite add_zero) - (take z, assume H : z > 0, - calc - (x + z) % z = if 0 < z × z ≤ x + z then (x + z - z) % z else _ : mod_def - ... = (x + z - z) % z : if_pos (pair H (le_add_left z x)) - ... = x % z : nat.add_sub_cancel) - -theorem add_mod_self_left [simp] (x z : ℕ) : (x + z) % x = z % x := -!add.comm ▸ !add_mod_self - -local attribute succ_mul [simp] - -theorem add_mul_mod_self [simp] (x y z : ℕ) : (x + y * z) % z = x % z := -nat.rec_on y (by rewrite [zero_mul, add_zero]) - (by intro y IH; rewrite [succ_mul, -add.assoc, add_mod_self, IH]) - -theorem add_mul_mod_self_left [simp] (x y z : ℕ) : (x + y * z) % y = x % y := -by rewrite [mul.comm, add_mul_mod_self] - -theorem mul_mod_left [simp] (m n : ℕ) : (m * n) % n = 0 := -calc (m * n) % n = (0 + m * n) % n : by rewrite [zero_add] - ... = 0 : by rewrite [add_mul_mod_self, zero_mod] - -theorem mul_mod_right [simp] (m n : ℕ) : (m * n) % m = 0 := -by rewrite [mul.comm, mul_mod_left] - -theorem mod_lt (x : ℕ) {y : ℕ} (H : y > 0) : x % y < y := -nat.case_strong_rec_on x - (show 0 % y < y, from !zero_mod⁻¹ ▸ H) - (take x, - assume IH : Πx', x' ≤ x → x' % y < y, - show succ x % y < y, from - by_cases -- (succ x < y) - (assume H1 : succ x < y, - have succ x % y = succ x, from mod_eq_of_lt H1, - show succ x % y < y, from this⁻¹ ▸ H1) - (assume H1 : ¬ succ x < y, - have y ≤ succ x, from le_of_not_gt H1, - have h : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H this, - have succ x - y < succ x, from sub_lt !succ_pos H, - have succ x - y ≤ x, from le_of_lt_succ this, - show succ x % y < y, from h⁻¹ ▸ IH _ this)) - -theorem mod_one (n : ℕ) : n % 1 = 0 := -have H1 : n % 1 < 1, from !mod_lt !succ_pos, -eq_zero_of_le_zero (le_of_lt_succ H1) - -/- properties of div prod mod -/ - --- the quotient - remainder theorem -theorem eq_div_mul_add_mod (x y : ℕ) : x = x / y * y + x % y := -begin - eapply by_cases_zero_pos y, - show x = x / 0 * 0 + x % 0, from - (calc - x / 0 * 0 + x % 0 = 0 + x % 0 : mul_zero - ... = x % 0 : zero_add - ... = x : mod_zero)⁻¹, - intro y H, - show x = x / y * y + x % y, - begin - eapply nat.case_strong_rec_on x, - show 0 = (0 / y) * y + 0 % y, by rewrite [zero_mod, add_zero, nat.zero_div, zero_mul], - intro x IH, - show succ x = succ x / y * y + succ x % y, from - if H1 : succ x < y then - have H2 : succ x / y = 0, from div_eq_zero_of_lt H1, - have H3 : succ x % y = succ x, from mod_eq_of_lt H1, - begin rewrite [H2, H3, zero_mul, zero_add] end - else - have H2 : y ≤ succ x, from le_of_not_gt H1, - have H3 : succ x / y = succ ((succ x - y) / y), from div_eq_succ_sub_div H H2, - have H4 : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H H2, - have H5 : succ x - y < succ x, from sub_lt !succ_pos H, - have H6 : succ x - y ≤ x, from le_of_lt_succ H5, - (calc - succ x / y * y + succ x % y = - succ ((succ x - y) / y) * y + succ x % y : by rewrite H3 - ... = ((succ x - y) / y) * y + y + succ x % y : by rewrite succ_mul - ... = ((succ x - y) / y) * y + y + (succ x - y) % y : by rewrite H4 - ... = ((succ x - y) / y) * y + (succ x - y) % y + y : add.right_comm - ... = succ x - y + y : by rewrite -(IH _ H6) - ... = succ x : nat.sub_add_cancel H2)⁻¹ - end -end - -theorem mod_eq_sub_div_mul (x y : ℕ) : x % y = x - x / y * y := -nat.eq_sub_of_add_eq (!add.comm ▸ !eq_div_mul_add_mod)⁻¹ - -theorem mod_add_mod (m n k : ℕ) : (m % n + k) % n = (m + k) % n := -by rewrite [eq_div_mul_add_mod m n at {2}, add.assoc, add.comm (m / n * n), add_mul_mod_self] - -theorem add_mod_mod (m n k : ℕ) : (m + n % k) % k = (m + n) % k := -by rewrite [add.comm, mod_add_mod, add.comm] - -theorem add_mod_eq_add_mod_right {m n k : ℕ} (i : ℕ) (H : m % n = k % n) : - (m + i) % n = (k + i) % n := -by rewrite [-mod_add_mod, -mod_add_mod k, H] - -theorem add_mod_eq_add_mod_left {m n k : ℕ} (i : ℕ) (H : m % n = k % n) : - (i + m) % n = (i + k) % n := -by rewrite [add.comm, add_mod_eq_add_mod_right _ H, add.comm] - -theorem mod_eq_mod_of_add_mod_eq_add_mod_right {m n k i : ℕ} : - (m + i) % n = (k + i) % n → m % n = k % n := -by_cases_zero_pos n - (by rewrite [*mod_zero]; apply eq_of_add_eq_add_right) - (take n, - assume npos : n > 0, - assume H1 : (m + i) % n = (k + i) % n, - have H2 : (m + i % n) % n = (k + i % n) % n, by rewrite [*add_mod_mod, H1], - have H3 : (m + i % n + (n - i % n)) % n = (k + i % n + (n - i % n)) % n, - from add_mod_eq_add_mod_right _ H2, - begin - revert H3, - rewrite [*add.assoc, add_sub_of_le (le_of_lt (!mod_lt npos)), *add_mod_self], - intros, assumption - end) - -theorem mod_eq_mod_of_add_mod_eq_add_mod_left {m n k i : ℕ} : - (i + m) % n = (i + k) % n → m % n = k % n := -by rewrite [add.comm i m, add.comm i k]; apply mod_eq_mod_of_add_mod_eq_add_mod_right - -theorem mod_le {x y : ℕ} : x % y ≤ x := -!eq_div_mul_add_mod⁻¹ ▸ !le_add_left - -theorem eq_remainder {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y) - (H3 : q1 * y + r1 = q2 * y + r2) : r1 = r2 := -calc - r1 = r1 % y : mod_eq_of_lt H1 - ... = (r1 + q1 * y) % y : !add_mul_mod_self⁻¹ - ... = (q1 * y + r1) % y : add.comm - ... = (r2 + q2 * y) % y : by rewrite [H3, add.comm] - ... = r2 % y : !add_mul_mod_self - ... = r2 : mod_eq_of_lt H2 - -theorem eq_quotient {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y) - (H3 : q1 * y + r1 = q2 * y + r2) : q1 = q2 := -have H4 : q1 * y + r2 = q2 * y + r2, from (eq_remainder H1 H2 H3) ▸ H3, -have H5 : q1 * y = q2 * y, from add.right_cancel H4, -have H6 : y > 0, from lt_of_le_of_lt !zero_le H1, -show q1 = q2, from eq_of_mul_eq_mul_right H6 H5 - -protected theorem mul_div_mul_left {z : ℕ} (x y : ℕ) (zpos : z > 0) : - (z * x) / (z * y) = x / y := -if H : y = 0 then - by rewrite [H, mul_zero, *nat.div_zero] -else - have ypos : y > 0, from pos_of_ne_zero H, - have zypos : z * y > 0, from mul_pos zpos ypos, - have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos, - have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos, - eq_quotient H1 H2 - (calc - ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : eq_div_mul_add_mod - ... = z * (x / y * y + x % y) : eq_div_mul_add_mod - ... = z * (x / y * y) + z * (x % y) : left_distrib - ... = (x / y) * (z * y) + z * (x % y) : mul.left_comm) - -protected theorem mul_div_mul_right {x z y : ℕ} (zpos : z > 0) : (x * z) / (y * z) = x / y := -!mul.comm ▸ !mul.comm ▸ !nat.mul_div_mul_left zpos - -theorem mul_mod_mul_left (z x y : ℕ) : (z * x) % (z * y) = z * (x % y) := -sum.elim (eq_zero_sum_pos z) - (assume H : z = 0, H⁻¹ ▸ calc - (0 * x) % (z * y) = 0 % (z * y) : zero_mul - ... = 0 : zero_mod - ... = 0 * (x % y) : zero_mul) - (assume zpos : z > 0, - sum.elim (eq_zero_sum_pos y) - (assume H : y = 0, by rewrite [H, mul_zero, *mod_zero]) - (assume ypos : y > 0, - have zypos : z * y > 0, from mul_pos zpos ypos, - have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos, - have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos, - eq_remainder H1 H2 - (calc - ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : eq_div_mul_add_mod - ... = z * (x / y * y + x % y) : eq_div_mul_add_mod - ... = z * (x / y * y) + z * (x % y) : left_distrib - ... = (x / y) * (z * y) + z * (x % y) : mul.left_comm))) - -theorem mul_mod_mul_right (x z y : ℕ) : (x * z) % (y * z) = (x % y) * z := -mul.comm z x ▸ mul.comm z y ▸ !mul.comm ▸ !mul_mod_mul_left - -theorem mod_self (n : ℕ) : n % n = 0 := -nat.cases_on n (by rewrite zero_mod) - (take n, by rewrite [-zero_add (succ n) at {1}, add_mod_self]) - -theorem mul_mod_eq_mod_mul_mod (m n k : nat) : (m * n) % k = ((m % k) * n) % k := -calc - (m * n) % k = (((m / k) * k + m % k) * n) % k : eq_div_mul_add_mod - ... = ((m % k) * n) % k : - by rewrite [right_distrib, mul.right_comm, add.comm, add_mul_mod_self] - -theorem mul_mod_eq_mul_mod_mod (m n k : nat) : (m * n) % k = (m * (n % k)) % k := -!mul.comm ▸ !mul.comm ▸ !mul_mod_eq_mod_mul_mod - -protected theorem div_one (n : ℕ) : n / 1 = n := -have n / 1 * 1 + n % 1 = n, from !eq_div_mul_add_mod⁻¹, -begin rewrite [-this at {2}, mul_one, mod_one] end - -protected theorem div_self {n : ℕ} (H : n > 0) : n / n = 1 := -have (n * 1) / (n * 1) = 1 / 1, from !nat.mul_div_mul_left H, -by rewrite [nat.div_one at this, -this, *mul_one] - -theorem div_mul_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : m / n * n = m := -by rewrite [eq_div_mul_add_mod m n at {2}, H, add_zero] - -theorem mul_div_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : n * (m / n) = m := -!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H - -/- dvd -/ - -theorem dvd_of_mod_eq_zero {m n : ℕ} (H : n % m = 0) : m ∣ n := -dvd.intro (!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H) - -theorem mod_eq_zero_of_dvd {m n : ℕ} (H : m ∣ n) : n % m = 0 := -dvd.elim H (take z, assume H1 : n = m * z, H1⁻¹ ▸ !mul_mod_right) - -theorem dvd_iff_mod_eq_zero (m n : ℕ) : m ∣ n ↔ n % m = 0 := -iff.intro mod_eq_zero_of_dvd dvd_of_mod_eq_zero - -definition dvd.decidable_rel [instance] : decidable_rel dvd := -take m n, decidable_of_decidable_of_iff _ (iff.symm !dvd_iff_mod_eq_zero) - -protected theorem div_mul_cancel {m n : ℕ} (H : n ∣ m) : m / n * n = m := -div_mul_cancel_of_mod_eq_zero (mod_eq_zero_of_dvd H) - -protected theorem mul_div_cancel' {m n : ℕ} (H : n ∣ m) : n * (m / n) = m := -!mul.comm ▸ nat.div_mul_cancel H - -theorem dvd_of_dvd_add_left {m n₁ n₂ : ℕ} (H₁ : m ∣ n₁ + n₂) (H₂ : m ∣ n₁) : m ∣ n₂ := -obtain (c₁ : nat) (Hc₁ : n₁ + n₂ = m * c₁), from H₁, -obtain (c₂ : nat) (Hc₂ : n₁ = m * c₂), from H₂, -have aux : m * (c₁ - c₂) = n₂, from calc - m * (c₁ - c₂) = m * c₁ - m * c₂ : nat.mul_sub_left_distrib - ... = n₁ + n₂ - m * c₂ : Hc₁ - ... = n₁ + n₂ - n₁ : Hc₂ - ... = n₂ : nat.add_sub_cancel_left, -dvd.intro aux - -theorem dvd_of_dvd_add_right {m n₁ n₂ : ℕ} (H : m ∣ n₁ + n₂) : m ∣ n₂ → m ∣ n₁ := -nat.dvd_of_dvd_add_left (!add.comm ▸ H) - -theorem dvd_sub {m n₁ n₂ : ℕ} (H1 : m ∣ n₁) (H2 : m ∣ n₂) : m ∣ n₁ - n₂ := -by_cases - (assume H3 : n₁ ≥ n₂, - have H4 : n₁ = n₁ - n₂ + n₂, from (nat.sub_add_cancel H3)⁻¹, - show m ∣ n₁ - n₂, from nat.dvd_of_dvd_add_right (H4 ▸ H1) H2) - (assume H3 : ¬ (n₁ ≥ n₂), - have H4 : n₁ - n₂ = 0, from sub_eq_zero_of_le (le_of_lt (lt_of_not_ge H3)), - show m ∣ n₁ - n₂, from H4⁻¹ ▸ dvd_zero _) - -theorem dvd.antisymm {m n : ℕ} : m ∣ n → n ∣ m → m = n := -by_cases_zero_pos n - (assume H1, assume H2 : 0 ∣ m, eq_zero_of_zero_dvd H2) - (take n, - assume Hpos : n > 0, - assume H1 : m ∣ n, - assume H2 : n ∣ m, - obtain k (Hk : n = m * k), from exists_eq_mul_right_of_dvd H1, - obtain l (Hl : m = n * l), from exists_eq_mul_right_of_dvd H2, - have n * (l * k) = n, from !mul.assoc ▸ Hl ▸ Hk⁻¹, - have l * k = 1, from eq_one_of_mul_eq_self_right Hpos this, - have k = 1, from eq_one_of_mul_eq_one_left this, - show m = n, from (mul_one m)⁻¹ ⬝ (this ▸ Hk⁻¹)) - -protected theorem mul_div_assoc (m : ℕ) {n k : ℕ} (H : k ∣ n) : m * n / k = m * (n / k) := -sum.elim (eq_zero_sum_pos k) - (assume H1 : k = 0, - calc - m * n / k = m * n / 0 : H1 - ... = 0 : nat.div_zero - ... = m * 0 : mul_zero m - ... = m * (n / 0) : nat.div_zero - ... = m * (n / k) : H1) - (assume H1 : k > 0, - have H2 : n = n / k * k, from (nat.div_mul_cancel H)⁻¹, - calc - m * n / k = m * (n / k * k) / k : H2 - ... = m * (n / k) * k / k : mul.assoc - ... = m * (n / k) : nat.mul_div_cancel _ H1) - -theorem dvd_of_mul_dvd_mul_left {m n k : ℕ} (kpos : k > 0) (H : k * m ∣ k * n) : m ∣ n := -dvd.elim H - (take l, - assume H1 : k * n = k * m * l, - have H2 : n = m * l, from eq_of_mul_eq_mul_left kpos (H1 ⬝ !mul.assoc), - dvd.intro H2⁻¹) - -theorem dvd_of_mul_dvd_mul_right {m n k : ℕ} (kpos : k > 0) (H : m * k ∣ n * k) : m ∣ n := -nat.dvd_of_mul_dvd_mul_left kpos (!mul.comm ▸ !mul.comm ▸ H) - -lemma dvd_of_eq_mul (i j n : nat) : n = j*i → j ∣ n := -begin intros, subst n, apply dvd_mul_right end - -theorem div_dvd_div {k m n : ℕ} (H1 : k ∣ m) (H2 : m ∣ n) : m / k ∣ n / k := -have H3 : m = m / k * k, from (nat.div_mul_cancel H1)⁻¹, -have H4 : n = n / k * k, from (nat.div_mul_cancel (dvd.trans H1 H2))⁻¹, -sum.elim (eq_zero_sum_pos k) - (assume H5 : k = 0, - have H6: n / k = 0, from (ap _ H5 ⬝ !nat.div_zero), - H6⁻¹ ▸ !dvd_zero) - (assume H5 : k > 0, - nat.dvd_of_mul_dvd_mul_right H5 (H3 ▸ H4 ▸ H2)) - -protected theorem div_eq_iff_eq_mul_right {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : - m / n = k ↔ m = n * k := -iff.intro - (assume H1, by rewrite [-H1, nat.mul_div_cancel' H']) - (assume H1, by rewrite [H1, !nat.mul_div_cancel_left H]) - -protected theorem div_eq_iff_eq_mul_left {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : - m / n = k ↔ m = k * n := -!mul.comm ▸ !nat.div_eq_iff_eq_mul_right H H' - -protected theorem eq_mul_of_div_eq_right {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) : - m = n * k := -calc - m = n * (m / n) : nat.mul_div_cancel' H1 - ... = n * k : H2 - -protected theorem div_eq_of_eq_mul_right {m n k : ℕ} (H1 : n > 0) (H2 : m = n * k) : - m / n = k := -calc - m / n = n * k / n : H2 - ... = k : !nat.mul_div_cancel_left H1 - -protected theorem eq_mul_of_div_eq_left {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) : - m = k * n := -!mul.comm ▸ !nat.eq_mul_of_div_eq_right H1 H2 - -protected theorem div_eq_of_eq_mul_left {m n k : ℕ} (H1 : n > 0) (H2 : m = k * n) : - m / n = k := -!nat.div_eq_of_eq_mul_right H1 (!mul.comm ▸ H2) - -lemma add_mod_eq_of_dvd (i j n : nat) : n ∣ j → (i + j) % n = i % n := -assume h, -obtain k (hk : j = n * k), from exists_eq_mul_right_of_dvd h, -begin - subst j, rewrite mul.comm, - apply add_mul_mod_self -end - -/- / prod ordering -/ - -lemma le_of_dvd {m n : nat} : n > 0 → m ∣ n → m ≤ n := -assume (h₁ : n > 0) (h₂ : m ∣ n), -have h₃ : n % m = 0, from mod_eq_zero_of_dvd h₂, -by_contradiction - (λ nle : ¬ m ≤ n, - have h₄ : m > n, from lt_of_not_ge nle, - have h₅ : n % m = n, from mod_eq_of_lt h₄, - begin - rewrite h₃ at h₅, subst n, - exact absurd h₁ (lt.irrefl 0) - end) - -theorem div_mul_le (m n : ℕ) : m / n * n ≤ m := -calc - m = m / n * n + m % n : eq_div_mul_add_mod - ... ≥ m / n * n : le_add_right - -protected theorem div_le_of_le_mul {m n k : ℕ} (H : m ≤ n * k) : m / k ≤ n := -sum.elim (eq_zero_sum_pos k) - (assume H1 : k = 0, - calc - m / k = m / 0 : H1 - ... = 0 : nat.div_zero - ... ≤ n : zero_le) - (assume H1 : k > 0, - le_of_mul_le_mul_right (calc - m / k * k ≤ m / k * k + m % k : le_add_right - ... = m : eq_div_mul_add_mod - ... ≤ n * k : H) H1) - -protected theorem div_le_self (m n : ℕ) : m / n ≤ m := -nat.cases_on n (!nat.div_zero⁻¹ ▸ !zero_le) - take n, - have H : m ≤ m * succ n, from calc - m = m * 1 : mul_one - ... ≤ m * succ n : !mul_le_mul_left (succ_le_succ !zero_le), - nat.div_le_of_le_mul H - -protected theorem mul_le_of_le_div {m n k : ℕ} (H : m ≤ n / k) : m * k ≤ n := -calc - m * k ≤ n / k * k : !mul_le_mul_right H - ... ≤ n : div_mul_le - -protected theorem le_div_of_mul_le {m n k : ℕ} (H1 : k > 0) (H2 : m * k ≤ n) : m ≤ n / k := -have H3 : m * k < (succ (n / k)) * k, from - calc - m * k ≤ n : H2 - ... = n / k * k + n % k : eq_div_mul_add_mod - ... < n / k * k + k : add_lt_add_left (!mod_lt H1) - ... = (succ (n / k)) * k : succ_mul, -le_of_lt_succ (lt_of_mul_lt_mul_right H3) - -protected theorem le_div_iff_mul_le {m n k : ℕ} (H : k > 0) : m ≤ n / k ↔ m * k ≤ n := -iff.intro !nat.mul_le_of_le_div (!nat.le_div_of_mul_le H) - -protected theorem div_le_div {m n : ℕ} (k : ℕ) (H : m ≤ n) : m / k ≤ n / k := -by_cases_zero_pos k - (by rewrite [*nat.div_zero]) - (take k, assume H1 : k > 0, nat.le_div_of_mul_le H1 (le.trans !div_mul_le H)) - -protected theorem div_lt_of_lt_mul {m n k : ℕ} (H : m < n * k) : m / k < n := -lt_of_mul_lt_mul_right (calc - m / k * k ≤ m / k * k + m % k : le_add_right - ... = m : eq_div_mul_add_mod - ... < n * k : H) - -protected theorem lt_mul_of_div_lt {m n k : ℕ} (H1 : k > 0) (H2 : m / k < n) : m < n * k := -have H3 : succ (m / k) * k ≤ n * k, from !mul_le_mul_right (succ_le_of_lt H2), -have H4 : m / k * k + k ≤ n * k, by rewrite [succ_mul at H3]; apply H3, -calc - m = m / k * k + m % k : eq_div_mul_add_mod - ... < m / k * k + k : add_lt_add_left (!mod_lt H1) - ... ≤ n * k : H4 - -protected theorem div_lt_iff_lt_mul {m n k : ℕ} (H : k > 0) : m / k < n ↔ m < n * k := -iff.intro (!nat.lt_mul_of_div_lt H) !nat.div_lt_of_lt_mul - -protected theorem div_le_iff_le_mul_of_div {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : - m / n ≤ k ↔ m ≤ k * n := -by refine iff.trans (!le_iff_mul_le_mul_right H) _; rewrite [!nat.div_mul_cancel H'] - -protected theorem le_mul_of_div_le_of_div {m n k : ℕ} (H1 : n > 0) (H2 : n ∣ m) (H3 : m / n ≤ k) : - m ≤ k * n := -iff.mp (!nat.div_le_iff_le_mul_of_div H1 H2) H3 - --- needed for integer division -theorem mul_sub_div_of_lt {m n k : ℕ} (H : k < m * n) : - (m * n - (k + 1)) / m = n - k / m - 1 := -begin - have H1 : k / m < n, from nat.div_lt_of_lt_mul (!mul.comm ▸ H), - have H2 : n - k / m ≥ 1, from - nat.le_sub_of_add_le (calc - 1 + k / m = succ (k / m) : add.comm - ... ≤ n : succ_le_of_lt H1), - have H3 : n - k / m = n - k / m - 1 + 1, from (nat.sub_add_cancel H2)⁻¹, - have H4 : m > 0, from pos_of_ne_zero (assume H': m = 0, not_lt_zero k (begin rewrite [H' at H, zero_mul at H], exact H end)), - have H5 : k % m + 1 ≤ m, from succ_le_of_lt (!mod_lt H4), - have H6 : m - (k % m + 1) < m, from nat.sub_lt_self H4 !succ_pos, -calc - (m * n - (k + 1)) / m = (m * n - (k / m * m + k % m + 1)) / m : eq_div_mul_add_mod - ... = (m * n - k / m * m - (k % m + 1)) / m : by rewrite [*nat.sub_sub] - ... = ((n - k / m) * m - (k % m + 1)) / m : - by rewrite [mul.comm m, nat.mul_sub_right_distrib] - ... = ((n - k / m - 1) * m + m - (k % m + 1)) / m : - by rewrite [H3 at {1}, right_distrib, nat.one_mul] - ... = ((n - k / m - 1) * m + (m - (k % m + 1))) / m : {nat.add_sub_assoc H5 _} - ... = (m - (k % m + 1)) / m + (n - k / m - 1) : - by rewrite [add.comm, (add_mul_div_self H4)] - ... = n - k / m - 1 : - by rewrite [div_eq_zero_of_lt H6, zero_add] -end - -private lemma div_div_aux (a b c : nat) : b > 0 → c > 0 → (a / b) / c = a / (b * c) := -suppose b > 0, suppose c > 0, -nat.strong_rec_on a -(λ a ih, - let k₁ := a / (b*c) in - let k₂ := a %(b*c) in - have bc_pos : b*c > 0, from mul_pos `b > 0` `c > 0`, - have k₂ < b * c, from mod_lt _ bc_pos, - have k₂ ≤ a, from !mod_le, - sum.elim (eq_sum_lt_of_le this) - (suppose k₂ = a, - have i₁ : a < b * c, by rewrite -this; assumption, - have k₁ = 0, from div_eq_zero_of_lt i₁, - have a / b < c, by rewrite [mul.comm at i₁]; exact nat.div_lt_of_lt_mul i₁, - begin - rewrite [`k₁ = 0`], - show (a / b) / c = 0, from div_eq_zero_of_lt `a / b < c` - end) - (suppose k₂ < a, - have a = k₁*(b*c) + k₂, from eq_div_mul_add_mod a (b*c), - have a / b = k₁*c + k₂ / b, by - rewrite [this at {1}, mul.comm b c at {2}, -mul.assoc, - add.comm, add_mul_div_self `b > 0`, add.comm], - have e₁ : (a / b) / c = k₁ + (k₂ / b) / c, by - rewrite [this, add.comm, add_mul_div_self `c > 0`, add.comm], - have e₂ : (k₂ / b) / c = k₂ / (b * c), from ih k₂ `k₂ < a`, - have e₃ : k₂ / (b * c) = 0, from div_eq_zero_of_lt `k₂ < b * c`, - have (k₂ / b) / c = 0, by rewrite [e₂, e₃], - show (a / b) / c = k₁, by rewrite [e₁, this])) - -protected lemma div_div_eq_div_mul (a b c : nat) : (a / b) / c = a / (b * c) := -begin - cases b with b, - rewrite [zero_mul, *nat.div_zero, nat.zero_div], - cases c with c, - rewrite [mul_zero, *nat.div_zero], - apply div_div_aux a (succ b) (succ c) dec_star dec_star -end - -lemma div_lt_of_ne_zero : Π {n : nat}, n ≠ 0 → n / 2 < n -| 0 h := absurd rfl h -| (succ n) h := - begin - apply nat.div_lt_of_lt_mul, - rewrite [-add_one, right_distrib], - change n + 1 < (n * 1 + n) + (1 + 1), - rewrite [mul_one, -add.assoc], - apply add_lt_add_right, - show n < n + n + 1, - begin - rewrite [add.assoc, -add_zero n at {1}], - apply add_lt_add_left, - apply zero_lt_succ - end - end -end nat diff --git a/hott/types/nat/hott.hlean b/hott/types/nat/hott.hlean deleted file mode 100644 index 9b4cbddb6c..0000000000 --- a/hott/types/nat/hott.hlean +++ /dev/null @@ -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 the natural numbers specific to HoTT --/ - -import .order types.pointed - -open is_trunc unit empty eq equiv algebra pointed - -namespace nat - definition is_prop_le [instance] (n m : ℕ) : is_prop (n ≤ m) := - begin - have lem : Π{n m : ℕ} (p : n ≤ m) (q : n = m), p = q ▸ le.refl n, - begin - intros, cases p, - { have H' : q = idp, by apply is_set.elim, - cases H', reflexivity}, - { cases q, exfalso, apply not_succ_le_self a} - end, - apply is_prop.mk, intro H1 H2, induction H2, - { apply lem}, - { cases H1, - { exfalso, apply not_succ_le_self a}, - { exact ap le.step !v_0}}, - end - - definition is_prop_lt [instance] (n m : ℕ) : is_prop (n < m) := !is_prop_le - - definition le_equiv_succ_le_succ (n m : ℕ) : (n ≤ m) ≃ (succ n ≤ succ m) := - equiv_of_is_prop succ_le_succ le_of_succ_le_succ - definition le_succ_equiv_pred_le (n m : ℕ) : (n ≤ succ m) ≃ (pred n ≤ m) := - equiv_of_is_prop pred_le_pred le_succ_of_pred_le - - theorem lt_by_cases_lt {a b : ℕ} {P : Type} (H1 : a < b → P) (H2 : a = b → P) - (H3 : a > b → P) (H : a < b) : lt.by_cases H1 H2 H3 = H1 H := - begin - unfold lt.by_cases, induction (lt.trichotomy a b) with H' H', - { esimp, exact ap H1 !is_prop.elim}, - { exfalso, cases H' with H' H', apply lt.irrefl, exact H' ▸ H, exact lt.asymm H H'} - end - - theorem lt_by_cases_eq {a b : ℕ} {P : Type} (H1 : a < b → P) (H2 : a = b → P) - (H3 : a > b → P) (H : a = b) : lt.by_cases H1 H2 H3 = H2 H := - begin - unfold lt.by_cases, induction (lt.trichotomy a b) with H' H', - { exfalso, apply lt.irrefl, exact H ▸ H'}, - { cases H' with H' H', esimp, exact ap H2 !is_prop.elim, exfalso, apply lt.irrefl, exact H ▸ H'} - end - - theorem lt_by_cases_ge {a b : ℕ} {P : Type} (H1 : a < b → P) (H2 : a = b → P) - (H3 : a > b → P) (H : a > b) : lt.by_cases H1 H2 H3 = H3 H := - begin - unfold lt.by_cases, induction (lt.trichotomy a b) with H' H', - { exfalso, exact lt.asymm H H'}, - { cases H' with H' H', exfalso, apply lt.irrefl, exact H' ▸ H, esimp, exact ap H3 !is_prop.elim} - end - - theorem lt_ge_by_cases_lt {n m : ℕ} {P : Type} (H1 : n < m → P) (H2 : n ≥ m → P) - (H : n < m) : lt_ge_by_cases H1 H2 = H1 H := - by apply lt_by_cases_lt - - theorem lt_ge_by_cases_ge {n m : ℕ} {P : Type} (H1 : n < m → P) (H2 : n ≥ m → P) - (H : n ≥ m) : lt_ge_by_cases H1 H2 = H2 H := - begin - unfold [lt_ge_by_cases,lt.by_cases], induction (lt.trichotomy n m) with H' H', - { exfalso, apply lt.irrefl, exact lt_of_le_of_lt H H'}, - { cases H' with H' H'; all_goals (esimp; apply ap H2 !is_prop.elim)} - end - - theorem lt_ge_by_cases_le {n m : ℕ} {P : Type} {H1 : n ≤ m → P} {H2 : n ≥ m → P} - (H : n ≤ m) (Heq : Π(p : n = m), H1 (le_of_eq p) = H2 (le_of_eq p⁻¹)) - : lt_ge_by_cases (λH', H1 (le_of_lt H')) H2 = H1 H := - begin - unfold [lt_ge_by_cases,lt.by_cases], induction (lt.trichotomy n m) with H' H', - { esimp, apply ap H1 !is_prop.elim}, - { cases H' with H' H', - { esimp, induction H', esimp, symmetry, - exact ap H1 !is_prop.elim ⬝ Heq idp ⬝ ap H2 !is_prop.elim}, - { exfalso, apply lt.irrefl, apply lt_of_le_of_lt H H'}} - end - - protected definition code [reducible] [unfold 1 2] : ℕ → ℕ → Type₀ - | code 0 0 := unit - | code 0 (succ m) := empty - | code (succ n) 0 := empty - | code (succ n) (succ m) := code n m - - protected definition refl : Πn, nat.code n n - | refl 0 := star - | refl (succ n) := refl n - - protected definition encode [unfold 3] {n m : ℕ} (p : n = m) : nat.code n m := - p ▸ nat.refl n - - protected definition decode : Π(n m : ℕ), nat.code n m → n = m - | decode 0 0 := λc, idp - | decode 0 (succ l) := λc, empty.elim c _ - | decode (succ k) 0 := λc, empty.elim c _ - | decode (succ k) (succ l) := λc, ap succ (decode k l c) - - definition nat_eq_equiv (n m : ℕ) : (n = m) ≃ nat.code n m := - equiv.MK nat.encode - !nat.decode - begin - revert m, induction n, all_goals (intro m;induction m;all_goals intro c), - all_goals try contradiction, - induction c, reflexivity, - xrewrite [↑nat.decode,-tr_compose,v_0], - end - begin - intro p, induction p, esimp, induction n, - reflexivity, - rewrite [↑nat.decode,↑nat.refl,v_0] - end - - definition pointed_nat [instance] [constructor] : pointed ℕ := - pointed.mk 0 - -end nat diff --git a/hott/types/nat/nat.md b/hott/types/nat/nat.md deleted file mode 100644 index 68d0319efe..0000000000 --- a/hott/types/nat/nat.md +++ /dev/null @@ -1,8 +0,0 @@ -types.nat -========= - -The natural numbers. Note: all these files are ported 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)). - -* [basic](basic.hlean) : the natural numbers, with succ, pred, addition, and multiplication -* [order](order.hlean) : less-than, less-then-or-equal, etc. -* [sub](sub.hlean) : subtraction, and distance diff --git a/hott/types/nat/order.hlean b/hott/types/nat/order.hlean deleted file mode 100644 index 71fac0d3b7..0000000000 --- a/hott/types/nat/order.hlean +++ /dev/null @@ -1,492 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad - -The order relation on the natural numbers. --/ -import .basic algebra.ordered_ring -open eq eq.ops algebra algebra - -namespace nat - -/- lt and le -/ - -protected theorem le_of_lt_sum_eq {m n : ℕ} (H : m < n ⊎ m = n) : m ≤ n := -nat.le_of_eq_sum_lt (sum.swap H) - -protected theorem lt_sum_eq_of_le {m n : ℕ} (H : m ≤ n) : m < n ⊎ m = n := -sum.swap (nat.eq_sum_lt_of_le H) - -protected theorem le_iff_lt_sum_eq (m n : ℕ) : m ≤ n ↔ m < n ⊎ m = n := -iff.intro nat.lt_sum_eq_of_le nat.le_of_lt_sum_eq - -protected theorem lt_of_le_prod_ne {m n : ℕ} (H1 : m ≤ n) : m ≠ n → m < n := -sum_resolve_right (nat.eq_sum_lt_of_le H1) - -protected theorem lt_iff_le_prod_ne (m n : ℕ) : m < n ↔ m ≤ n × m ≠ n := -iff.intro - (take H, pair (nat.le_of_lt H) (take H1, !nat.lt_irrefl (H1 ▸ H))) - (prod.rec nat.lt_of_le_prod_ne) - -theorem le_add_right (n k : ℕ) : n ≤ n + k := -nat.rec !nat.le_refl (λ k, le_succ_of_le) k - -theorem le_add_left (n m : ℕ): n ≤ m + n := -!add.comm ▸ !le_add_right - -theorem le.intro {n m k : ℕ} (h : n + k = m) : n ≤ m := -h ▸ !le_add_right - -theorem le.elim {n m : ℕ} : n ≤ m → Σ k, n + k = m := -le.rec (sigma.mk 0 rfl) (λm h, sigma.rec - (λ k H, sigma.mk (succ k) (H ▸ rfl))) - -protected theorem le_total {m n : ℕ} : m ≤ n ⊎ n ≤ m := -sum.imp_left nat.le_of_lt !nat.lt_sum_ge - -/- addition -/ - -protected theorem add_le_add_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k + n ≤ k + m := -obtain l Hl, from le.elim H, le.intro (Hl ▸ !add.assoc) - -protected theorem add_le_add_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n + k ≤ m + k := -!add.comm ▸ !add.comm ▸ nat.add_le_add_left H k - -protected theorem le_of_add_le_add_left {k n m : ℕ} (H : k + n ≤ k + m) : n ≤ m := -obtain l Hl, from le.elim H, le.intro (nat.add_left_cancel (!add.assoc⁻¹ ⬝ Hl)) - -protected theorem lt_of_add_lt_add_left {k n m : ℕ} (H : k + n < k + m) : n < m := -let H' := nat.le_of_lt H in -nat.lt_of_le_prod_ne (nat.le_of_add_le_add_left H') (assume Heq, !nat.lt_irrefl (Heq ▸ H)) - -protected theorem add_lt_add_left {n m : ℕ} (H : n < m) (k : ℕ) : k + n < k + m := -lt_of_succ_le (!add_succ ▸ nat.add_le_add_left (succ_le_of_lt H) k) - -protected theorem add_lt_add_right {n m : ℕ} (H : n < m) (k : ℕ) : n + k < m + k := -!add.comm ▸ !add.comm ▸ nat.add_lt_add_left H k - -protected theorem lt_add_of_pos_right {n k : ℕ} (H : k > 0) : n < n + k := -!add_zero ▸ nat.add_lt_add_left H n - -/- multiplication -/ - -theorem mul_le_mul_left {n m : ℕ} (k : ℕ) (H : n ≤ m) : k * n ≤ k * m := -obtain (l : ℕ) (Hl : n + l = m), from le.elim H, -have k * n + k * l = k * m, by rewrite [-left_distrib, Hl], -le.intro this - -theorem mul_le_mul_right {n m : ℕ} (k : ℕ) (H : n ≤ m) : n * k ≤ m * k := -!mul.comm ▸ !mul.comm ▸ !mul_le_mul_left H - -protected theorem mul_le_mul {n m k l : ℕ} (H1 : n ≤ k) (H2 : m ≤ l) : n * m ≤ k * l := -nat.le_trans (!nat.mul_le_mul_right H1) (!nat.mul_le_mul_left H2) - -protected theorem mul_lt_mul_of_pos_left {n m k : ℕ} (H : n < m) (Hk : k > 0) : k * n < k * m := -nat.lt_of_lt_of_le (nat.lt_add_of_pos_right Hk) (!mul_succ ▸ nat.mul_le_mul_left k (succ_le_of_lt H)) - -protected theorem mul_lt_mul_of_pos_right {n m k : ℕ} (H : n < m) (Hk : k > 0) : n * k < m * k := -!mul.comm ▸ !mul.comm ▸ nat.mul_lt_mul_of_pos_left H Hk - -/- nat is an instance of a linearly ordered semiring and a lattice -/ - -protected definition decidable_linear_ordered_semiring [trans_instance] : -decidable_linear_ordered_semiring nat := -⦃ decidable_linear_ordered_semiring, nat.comm_semiring, - add_left_cancel := @nat.add_left_cancel, - add_right_cancel := @nat.add_right_cancel, - lt := nat.lt, - le := nat.le, - le_refl := nat.le_refl, - le_trans := @nat.le_trans, - le_antisymm := @nat.le_antisymm, - le_total := @nat.le_total, - le_iff_lt_sum_eq := @nat.le_iff_lt_sum_eq, - le_of_lt := @nat.le_of_lt, - lt_irrefl := @nat.lt_irrefl, - lt_of_lt_of_le := @nat.lt_of_lt_of_le, - lt_of_le_of_lt := @nat.lt_of_le_of_lt, - lt_of_add_lt_add_left := @nat.lt_of_add_lt_add_left, - add_lt_add_left := @nat.add_lt_add_left, - add_le_add_left := @nat.add_le_add_left, - le_of_add_le_add_left := @nat.le_of_add_le_add_left, - zero_lt_one := zero_lt_succ 0, - mul_le_mul_of_nonneg_left := (take a b c H1 H2, nat.mul_le_mul_left c H1), - mul_le_mul_of_nonneg_right := (take a b c H1 H2, nat.mul_le_mul_right c H1), - mul_lt_mul_of_pos_left := @nat.mul_lt_mul_of_pos_left, - mul_lt_mul_of_pos_right := @nat.mul_lt_mul_of_pos_right, - decidable_lt := nat.decidable_lt ⦄ - -definition nat_has_dvd [instance] [priority nat.prio] : has_dvd nat := -has_dvd.mk has_dvd.dvd - -theorem add_pos_left {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < a + b := -@add_pos_of_pos_of_nonneg _ _ a b H !zero_le - -theorem add_pos_right {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < b + a := -by rewrite add.comm; apply add_pos_left H b - -theorem add_eq_zero_iff_eq_zero_prod_eq_zero {a b : ℕ} : -a + b = 0 ↔ a = 0 × b = 0 := -@add_eq_zero_iff_eq_zero_prod_eq_zero_of_nonneg_of_nonneg _ _ a b !zero_le !zero_le - -theorem le_add_of_le_left {a b c : ℕ} (H : b ≤ c) : b ≤ a + c := -@le_add_of_nonneg_of_le _ _ a b c !zero_le H - -theorem le_add_of_le_right {a b c : ℕ} (H : b ≤ c) : b ≤ c + a := -@le_add_of_le_of_nonneg _ _ a b c H !zero_le - -theorem lt_add_of_lt_left {b c : ℕ} (H : b < c) (a : ℕ) : b < a + c := -@lt_add_of_nonneg_of_lt _ _ a b c !zero_le H - -theorem lt_add_of_lt_right {b c : ℕ} (H : b < c) (a : ℕ) : b < c + a := -@lt_add_of_lt_of_nonneg _ _ a b c H !zero_le - -theorem lt_of_mul_lt_mul_left {a b c : ℕ} (H : c * a < c * b) : a < b := -@lt_of_mul_lt_mul_left _ _ a b c H !zero_le - -theorem lt_of_mul_lt_mul_right {a b c : ℕ} (H : a * c < b * c) : a < b := -@lt_of_mul_lt_mul_right _ _ a b c H !zero_le - -theorem pos_of_mul_pos_left {a b : ℕ} (H : 0 < a * b) : 0 < b := -@pos_of_mul_pos_left _ _ a b H !zero_le - -theorem pos_of_mul_pos_right {a b : ℕ} (H : 0 < a * b) : 0 < a := -@pos_of_mul_pos_right _ _ a b H !zero_le - -theorem zero_le_one : (0:nat) ≤ 1 := -dec_star - -/- properties specific to nat -/ - -theorem lt_intro {n m k : ℕ} (H : succ n + k = m) : n < m := -lt_of_succ_le (le.intro H) - -theorem lt_elim {n m : ℕ} (H : n < m) : Σk, succ n + k = m := -le.elim (succ_le_of_lt H) - -theorem lt_add_succ (n m : ℕ) : n < n + succ m := -lt_intro !succ_add_eq_succ_add - -theorem eq_zero_of_le_zero {n : ℕ} (H : n ≤ 0) : n = 0 := -obtain (k : ℕ) (Hk : n + k = 0), from le.elim H, -eq_zero_of_add_eq_zero_right Hk - -/- succ and pred -/ - -theorem le_of_lt_succ {m n : nat} : m < succ n → m ≤ n := -le_of_succ_le_succ - -theorem lt_iff_succ_le (m n : nat) : m < n ↔ succ m ≤ n := -iff.rfl - -theorem lt_succ_iff_le (m n : nat) : m < succ n ↔ m ≤ n := -iff.intro le_of_lt_succ lt_succ_of_le - -theorem self_le_succ (n : ℕ) : n ≤ succ n := -le.intro !add_one - -theorem succ_le_sum_eq_of_le {n m : ℕ} : n ≤ m → succ n ≤ m ⊎ n = m := -lt_sum_eq_of_le - -theorem pred_le_of_le_succ {n m : ℕ} : n ≤ succ m → pred n ≤ m := -pred_le_pred - -theorem succ_le_of_le_pred {n m : ℕ} : succ n ≤ m → n ≤ pred m := -pred_le_pred - -theorem pred_le_pred_of_le {n m : ℕ} : n ≤ m → pred n ≤ pred m := -pred_le_pred - -theorem pre_lt_of_lt {n m : ℕ} : n < m → pred n < m := -lt_of_le_of_lt !pred_le - -theorem lt_of_pred_lt_pred {n m : ℕ} (H : pred n < pred m) : n < m := -lt_of_not_ge - (suppose m ≤ n, - not_lt_of_ge (pred_le_pred_of_le this) H) - -theorem le_sum_eq_succ_of_le_succ {n m : ℕ} (H : n ≤ succ m) : n ≤ m ⊎ n = succ m := -sum.imp_left le_of_succ_le_succ (succ_le_sum_eq_of_le H) - -theorem le_pred_self (n : ℕ) : pred n ≤ n := -!pred_le - -theorem succ_pos (n : ℕ) : 0 < succ n := -!zero_lt_succ - -theorem succ_pred_of_pos {n : ℕ} (H : n > 0) : succ (pred n) = n := -(sum_resolve_right (eq_zero_sum_eq_succ_pred n) (ne.symm (ne_of_lt H)))⁻¹ - -theorem exists_eq_succ_of_lt {n : ℕ} : Π {m : ℕ}, n < m → Σk, m = succ k -| 0 H := absurd H !not_lt_zero -| (succ k) H := sigma.mk k rfl - -theorem lt_succ_self (n : ℕ) : n < succ n := -lt.base n - -lemma lt_succ_of_lt {i j : nat} : i < j → i < succ j := -assume Plt, lt.trans Plt (self_lt_succ j) - -/- other forms of induction -/ - -protected definition strong_rec_on {P : nat → Type} (n : ℕ) (H : Πn, (Πm, m < n → P m) → P n) : P n := -nat.rec (λm h, absurd h !not_lt_zero) - (λn' (IH : Π {m : ℕ}, m < n' → P m) m l, - sum.elim (lt_sum_eq_of_le (le_of_lt_succ l)) - IH (λ e, eq.rec (H n' @IH) e⁻¹)) (succ n) n !lt_succ_self - -protected theorem case_strong_rec_on {P : nat → Type} (a : nat) (H0 : P 0) - (Hind : Π(n : nat), (Πm, m ≤ n → P m) → P (succ n)) : P a := -nat.strong_rec_on a - (take n, - show (Π m, m < n → P m) → P n, from - nat.cases_on n - (suppose (Π m, m < 0 → P m), show P 0, from H0) - (take n, - suppose (Π m, m < succ n → P m), - show P (succ n), from - Hind n (take m, assume H1 : m ≤ n, this _ (lt_succ_of_le H1)))) - -/- pos -/ - -theorem by_cases_zero_pos {P : ℕ → Type} (y : ℕ) (H0 : P 0) (H1 : Π {y : nat}, y > 0 → P y) : - P y := -nat.cases_on y H0 (take y, H1 !succ_pos) - -theorem eq_zero_sum_pos (n : ℕ) : n = 0 ⊎ n > 0 := -sum_of_sum_of_imp_left - (sum.swap (lt_sum_eq_of_le !zero_le)) - (suppose 0 = n, by subst n) - -theorem pos_of_ne_zero {n : ℕ} (H : n ≠ 0) : n > 0 := -sum.elim !eq_zero_sum_pos (take H2 : n = 0, by contradiction) (take H2 : n > 0, H2) - -theorem ne_zero_of_pos {n : ℕ} (H : n > 0) : n ≠ 0 := -ne.symm (ne_of_lt H) - -theorem exists_eq_succ_of_pos {n : ℕ} (H : n > 0) : Σl, n = succ l := -exists_eq_succ_of_lt H - -theorem pos_of_dvd_of_pos {m n : ℕ} (H1 : m ∣ n) (H2 : n > 0) : m > 0 := -pos_of_ne_zero - (suppose m = 0, - have n = 0, from eq_zero_of_zero_dvd (this ▸ H1), - ne_of_lt H2 (by subst n)) - -/- multiplication -/ - -theorem mul_lt_mul_of_le_of_lt {n m k l : ℕ} (Hk : k > 0) (H1 : n ≤ k) (H2 : m < l) : - n * m < k * l := -lt_of_le_of_lt (mul_le_mul_right m H1) (mul_lt_mul_of_pos_left H2 Hk) - -theorem mul_lt_mul_of_lt_of_le {n m k l : ℕ} (Hl : l > 0) (H1 : n < k) (H2 : m ≤ l) : - n * m < k * l := -lt_of_le_of_lt (mul_le_mul_left n H2) (mul_lt_mul_of_pos_right H1 Hl) - -theorem mul_lt_mul_of_le_of_le {n m k l : ℕ} (H1 : n < k) (H2 : m < l) : n * m < k * l := -have H3 : n * m ≤ k * m, from mul_le_mul_right m (le_of_lt H1), -have H4 : k * m < k * l, from mul_lt_mul_of_pos_left H2 (lt_of_le_of_lt !zero_le H1), -lt_of_le_of_lt H3 H4 - -theorem eq_of_mul_eq_mul_left {m k n : ℕ} (Hn : n > 0) (H : n * m = n * k) : m = k := -have n * m ≤ n * k, by rewrite H, -have m ≤ k, from le_of_mul_le_mul_left this Hn, -have n * k ≤ n * m, by rewrite H, -have k ≤ m, from le_of_mul_le_mul_left this Hn, -le.antisymm `m ≤ k` this - -theorem eq_of_mul_eq_mul_right {n m k : ℕ} (Hm : m > 0) (H : n * m = k * m) : n = k := -eq_of_mul_eq_mul_left Hm (!mul.comm ▸ !mul.comm ▸ H) - -theorem eq_zero_sum_eq_of_mul_eq_mul_left {n m k : ℕ} (H : n * m = n * k) : n = 0 ⊎ m = k := -sum_of_sum_of_imp_right !eq_zero_sum_pos - (assume Hn : n > 0, eq_of_mul_eq_mul_left Hn H) - -theorem eq_zero_sum_eq_of_mul_eq_mul_right {n m k : ℕ} (H : n * m = k * m) : m = 0 ⊎ n = k := -eq_zero_sum_eq_of_mul_eq_mul_left (!mul.comm ▸ !mul.comm ▸ H) - -theorem eq_one_of_mul_eq_one_right {n m : ℕ} (H : n * m = 1) : n = 1 := -have H2 : n * m > 0, by rewrite H; apply succ_pos, -sum.elim (le_sum_gt n 1) - (suppose n ≤ 1, - have n > 0, from pos_of_mul_pos_right H2, - show n = 1, from le.antisymm `n ≤ 1` (succ_le_of_lt this)) - (suppose n > 1, - have m > 0, from pos_of_mul_pos_left H2, - have n * m ≥ 2 * 1, from nat.mul_le_mul (succ_le_of_lt `n > 1`) (succ_le_of_lt this), - have 1 ≥ 2, from !mul_one ▸ H ▸ this, - absurd !lt_succ_self (not_lt_of_ge this)) - -theorem eq_one_of_mul_eq_one_left {n m : ℕ} (H : n * m = 1) : m = 1 := -eq_one_of_mul_eq_one_right (!mul.comm ▸ H) - -theorem eq_one_of_mul_eq_self_left {n m : ℕ} (Hpos : n > 0) (H : m * n = n) : m = 1 := -eq_of_mul_eq_mul_right Hpos (H ⬝ !one_mul⁻¹) - -theorem eq_one_of_mul_eq_self_right {n m : ℕ} (Hpos : m > 0) (H : m * n = m) : n = 1 := -eq_one_of_mul_eq_self_left Hpos (!mul.comm ▸ H) - -theorem eq_one_of_dvd_one {n : ℕ} (H : n ∣ 1) : n = 1 := -dvd.elim H - (take m, suppose 1 = n * m, - eq_one_of_mul_eq_one_right this⁻¹) - -/- min and max -/ -open decidable - -theorem min_zero [simp] (a : ℕ) : min a 0 = 0 := -by rewrite [min_eq_right !zero_le] - -theorem zero_min [simp] (a : ℕ) : min 0 a = 0 := -by rewrite [min_eq_left !zero_le] - -theorem max_zero [simp] (a : ℕ) : max a 0 = a := -by rewrite [max_eq_left !zero_le] - -theorem zero_max [simp] (a : ℕ) : max 0 a = a := -by rewrite [max_eq_right !zero_le] - -theorem min_succ_succ [simp] (a b : ℕ) : min (succ a) (succ b) = succ (min a b) := -sum.elim !lt_sum_ge - (suppose a < b, by rewrite [min_eq_left_of_lt this, min_eq_left_of_lt (succ_lt_succ this)]) - (suppose a ≥ b, by rewrite [min_eq_right this, min_eq_right (succ_le_succ this)]) - -theorem max_succ_succ [simp] (a b : ℕ) : max (succ a) (succ b) = succ (max a b) := -sum.elim !lt_sum_ge - (suppose a < b, by rewrite [max_eq_right_of_lt this, max_eq_right_of_lt (succ_lt_succ this)]) - (suppose a ≥ b, by rewrite [max_eq_left this, max_eq_left (succ_le_succ this)]) - -/- In algebra.ordered_group, these next four are only proved for additive groups, not additive - semigroups. -/ - -protected theorem min_add_add_left (a b c : ℕ) : min (a + b) (a + c) = a + min b c := -decidable.by_cases - (suppose b ≤ c, - have a + b ≤ a + c, from add_le_add_left this _, - by rewrite [min_eq_left `b ≤ c`, min_eq_left this]) - (suppose ¬ b ≤ c, - have c ≤ b, from le_of_lt (lt_of_not_ge this), - have a + c ≤ a + b, from add_le_add_left this _, - by rewrite [min_eq_right `c ≤ b`, min_eq_right this]) - -protected theorem min_add_add_right (a b c : ℕ) : min (a + c) (b + c) = min a b + c := -by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply nat.min_add_add_left - -protected theorem max_add_add_left (a b c : ℕ) : max (a + b) (a + c) = a + max b c := -decidable.by_cases - (suppose b ≤ c, - have a + b ≤ a + c, from add_le_add_left this _, - by rewrite [max_eq_right `b ≤ c`, max_eq_right this]) - (suppose ¬ b ≤ c, - have c ≤ b, from le_of_lt (lt_of_not_ge this), - have a + c ≤ a + b, from add_le_add_left this _, - by rewrite [max_eq_left `c ≤ b`, max_eq_left this]) - -protected theorem max_add_add_right (a b c : ℕ) : max (a + c) (b + c) = max a b + c := -by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply nat.max_add_add_left - -/- least and greatest -/ - -section least_prod_greatest - variable (P : ℕ → Type) - variable [decP : Π n, decidable (P n)] - include decP - - -- returns the least i < n satisfying P, sum n if there is none - definition least : ℕ → ℕ - | 0 := 0 - | (succ n) := if P (least n) then least n else succ n - - theorem least_of_bound {n : ℕ} (H : P n) : P (least P n) := - begin - induction n with [m, ih], - rewrite ↑least, - apply H, - rewrite ↑least, - cases decidable.em (P (least P m)) with [Hlp, Hlp], - rewrite [if_pos Hlp], - apply Hlp, - rewrite [if_neg Hlp], - apply H - end - - theorem least_le (n : ℕ) : least P n ≤ n:= - begin - induction n with [m, ih], - {rewrite ↑least}, - rewrite ↑least, - cases decidable.em (P (least P m)) with [Psm, Pnsm], - rewrite [if_pos Psm], - apply le.trans ih !le_succ, - rewrite [if_neg Pnsm] - end - - theorem least_of_lt {i n : ℕ} (ltin : i < n) (H : P i) : P (least P n) := - begin - induction n with [m, ih], - exact absurd ltin !not_lt_zero, - rewrite ↑least, - cases decidable.em (P (least P m)) with [Psm, Pnsm], - rewrite [if_pos Psm], - apply Psm, - rewrite [if_neg Pnsm], - cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with [Hlt, Heq], - exact absurd (ih Hlt) Pnsm, - rewrite Heq at H, - exact absurd (least_of_bound P H) Pnsm - end - - theorem ge_least_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : i ≥ least P n := - begin - induction n with [m, ih], - exact absurd ltin !not_lt_zero, - rewrite ↑least, - cases decidable.em (P (least P m)) with [Psm, Pnsm], - rewrite [if_pos Psm], - cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with [Hlt, Heq], - apply ih Hlt, - rewrite Heq, - apply least_le, - rewrite [if_neg Pnsm], - cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with [Hlt, Heq], - apply absurd (least_of_lt P Hlt Hi) Pnsm, - rewrite Heq at Hi, - apply absurd (least_of_bound P Hi) Pnsm - end - - theorem least_lt {n i : ℕ} (ltin : i < n) (Hi : P i) : least P n < n := - lt_of_le_of_lt (ge_least_of_lt P ltin Hi) ltin - - -- returns the largest i < n satisfying P, sum n if there is none. - definition greatest : ℕ → ℕ - | 0 := 0 - | (succ n) := if P n then n else greatest n - - theorem greatest_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : P (greatest P n) := - begin - induction n with [m, ih], - {exact absurd ltin !not_lt_zero}, - {cases (decidable.em (P m)) with [Psm, Pnsm], - {rewrite [↑greatest, if_pos Psm]; exact Psm}, - {rewrite [↑greatest, if_neg Pnsm], - have neim : i ≠ m, from assume H : i = m, absurd (H ▸ Hi) Pnsm, - have ltim : i < m, from lt_of_le_of_ne (le_of_lt_succ ltin) neim, - apply ih ltim}} - end - - theorem le_greatest_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : i ≤ greatest P n := - begin - induction n with [m, ih], - {exact absurd ltin !not_lt_zero}, - {cases (decidable.em (P m)) with [Psm, Pnsm], - {rewrite [↑greatest, if_pos Psm], apply le_of_lt_succ ltin}, - {rewrite [↑greatest, if_neg Pnsm], - have neim : i ≠ m, from assume H : i = m, absurd (H ▸ Hi) Pnsm, - have ltim : i < m, from lt_of_le_of_ne (le_of_lt_succ ltin) neim, - apply ih ltim}} - end - -end least_prod_greatest - -end nat diff --git a/hott/types/nat/sub.hlean b/hott/types/nat/sub.hlean deleted file mode 100644 index a6be2f3ff2..0000000000 --- a/hott/types/nat/sub.hlean +++ /dev/null @@ -1,502 +0,0 @@ -/- -Copyright (c) 2014 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. - -Authors: Floris van Doorn, Jeremy Avigad -Subtraction on the natural numbers, as well as min, max, and distance. --/ -import .order -open eq.ops algebra eq - -namespace nat - -/- subtraction -/ - -protected theorem sub_zero (n : ℕ) : n - 0 = n := -rfl - -theorem sub_succ (n m : ℕ) : n - succ m = pred (n - m) := -rfl - -protected theorem zero_sub (n : ℕ) : 0 - n = 0 := -nat.rec_on n !nat.sub_zero - (take k : nat, - assume IH : 0 - k = 0, - calc - 0 - succ k = pred (0 - k) : sub_succ - ... = pred 0 : IH - ... = 0 : pred_zero) - -theorem succ_sub_succ (n m : ℕ) : succ n - succ m = n - m := -succ_sub_succ_eq_sub n m - -protected theorem sub_self (n : ℕ) : n - n = 0 := -nat.rec_on n !nat.sub_zero (take k IH, !succ_sub_succ ⬝ IH) - -protected theorem add_sub_add_right (n k m : ℕ) : (n + k) - (m + k) = n - m := -nat.rec_on k - (calc - (n + 0) - (m + 0) = n - (m + 0) : {!add_zero} - ... = n - m : {!add_zero}) - (take l : nat, - assume IH : (n + l) - (m + l) = n - m, - calc - (n + succ l) - (m + succ l) = succ (n + l) - (m + succ l) : {!add_succ} - ... = succ (n + l) - succ (m + l) : {!add_succ} - ... = (n + l) - (m + l) : !succ_sub_succ - ... = n - m : IH) -protected theorem add_sub_add_left (k n m : ℕ) : (k + n) - (k + m) = n - m := -add.comm n k ▸ add.comm m k ▸ nat.add_sub_add_right n k m - -protected theorem add_sub_cancel (n m : ℕ) : n + m - m = n := -nat.rec_on m - (begin rewrite add_zero end) - (take k : ℕ, - assume IH : n + k - k = n, - calc - n + succ k - succ k = succ (n + k) - succ k : add_succ - ... = n + k - k : succ_sub_succ - ... = n : IH) - -protected theorem add_sub_cancel_left (n m : ℕ) : n + m - n = m := -!add.comm ▸ !nat.add_sub_cancel - -protected theorem sub_sub (n m k : ℕ) : n - m - k = n - (m + k) := -nat.rec_on k - (calc - n - m - 0 = n - m : nat.sub_zero - ... = n - (m + 0) : add_zero) - (take l : nat, - assume IH : n - m - l = n - (m + l), - calc - n - m - succ l = pred (n - m - l) : !sub_succ - ... = pred (n - (m + l)) : IH - ... = n - succ (m + l) : sub_succ - ... = n - (m + succ l) : by rewrite add_succ) - -theorem succ_sub_sub_succ (n m k : ℕ) : succ n - m - succ k = n - m - k := -calc - succ n - m - succ k = succ n - (m + succ k) : nat.sub_sub - ... = succ n - succ (m + k) : add_succ - ... = n - (m + k) : succ_sub_succ - ... = n - m - k : nat.sub_sub - -theorem sub_self_add (n m : ℕ) : n - (n + m) = 0 := -calc - n - (n + m) = n - n - m : nat.sub_sub - ... = 0 - m : nat.sub_self - ... = 0 : nat.zero_sub - -protected theorem sub.right_comm (m n k : ℕ) : m - n - k = m - k - n := -calc - m - n - k = m - (n + k) : !nat.sub_sub - ... = m - (k + n) : {!add.comm} - ... = m - k - n : !nat.sub_sub⁻¹ - -theorem sub_one (n : ℕ) : n - 1 = pred n := -rfl - -theorem succ_sub_one (n : ℕ) : succ n - 1 = n := -rfl - -/- interaction with multiplication -/ - -theorem mul_pred_left (n m : ℕ) : pred n * m = n * m - m := -nat.rec_on n - (calc - pred 0 * m = 0 * m : pred_zero - ... = 0 : zero_mul - ... = 0 - m : nat.zero_sub - ... = 0 * m - m : zero_mul) - (take k : nat, - assume IH : pred k * m = k * m - m, - calc - pred (succ k) * m = k * m : pred_succ - ... = k * m + m - m : nat.add_sub_cancel - ... = succ k * m - m : succ_mul) - -theorem mul_pred_right (n m : ℕ) : n * pred m = n * m - n := -calc - n * pred m = pred m * n : mul.comm - ... = m * n - n : mul_pred_left - ... = n * m - n : mul.comm - -protected theorem mul_sub_right_distrib (n m k : ℕ) : (n - m) * k = n * k - m * k := -nat.rec_on m - (calc - (n - 0) * k = n * k : nat.sub_zero - ... = n * k - 0 : nat.sub_zero - ... = n * k - 0 * k : zero_mul) - (take l : nat, - assume IH : (n - l) * k = n * k - l * k, - calc - (n - succ l) * k = pred (n - l) * k : sub_succ - ... = (n - l) * k - k : mul_pred_left - ... = n * k - l * k - k : IH - ... = n * k - (l * k + k) : nat.sub_sub - ... = n * k - (succ l * k) : succ_mul) - -protected theorem mul_sub_left_distrib (n m k : ℕ) : n * (m - k) = n * m - n * k := -calc - n * (m - k) = (m - k) * n : !mul.comm - ... = m * n - k * n : !nat.mul_sub_right_distrib - ... = n * m - k * n : {!mul.comm} - ... = n * m - n * k : {!mul.comm} - -protected theorem mul_self_sub_mul_self_eq (a b : nat) : a * a - b * b = (a + b) * (a - b) := -by rewrite [nat.mul_sub_left_distrib, *right_distrib, mul.comm b a, add.comm (a*a) (a*b), - nat.add_sub_add_left] - -theorem succ_mul_succ_eq (a : nat) : succ a * succ a = a*a + a + a + 1 := -calc succ a * succ a = (a+1)*(a+1) : by rewrite [add_one] - ... = a*a + a + a + 1 : by rewrite [right_distrib, left_distrib, one_mul, mul_one] - -/- interaction with inequalities -/ - -theorem succ_sub {m n : ℕ} : m ≥ n → succ m - n = succ (m - n) := -sub_induction n m - (take k, assume H : 0 ≤ k, rfl) - (take k, - assume H : succ k ≤ 0, - absurd H !not_succ_le_zero) - (take k l, - assume IH : k ≤ l → succ l - k = succ (l - k), - take H : succ k ≤ succ l, - calc - succ (succ l) - succ k = succ l - k : succ_sub_succ - ... = succ (l - k) : IH (le_of_succ_le_succ H) - ... = succ (succ l - succ k) : succ_sub_succ) - -theorem sub_eq_zero_of_le {n m : ℕ} (H : n ≤ m) : n - m = 0 := -obtain (k : ℕ) (Hk : n + k = m), from le.elim H, Hk ▸ !sub_self_add - -theorem add_sub_of_le {n m : ℕ} : n ≤ m → n + (m - n) = m := -sub_induction n m - (take k, - assume H : 0 ≤ k, - calc - 0 + (k - 0) = k - 0 : zero_add - ... = k : nat.sub_zero) - (take k, assume H : succ k ≤ 0, absurd H !not_succ_le_zero) - (take k l, - assume IH : k ≤ l → k + (l - k) = l, - take H : succ k ≤ succ l, - calc - succ k + (succ l - succ k) = succ k + (l - k) : succ_sub_succ - ... = succ (k + (l - k)) : succ_add - ... = succ l : IH (le_of_succ_le_succ H)) - -theorem add_sub_of_ge {n m : ℕ} (H : n ≥ m) : n + (m - n) = n := -calc - n + (m - n) = n + 0 : sub_eq_zero_of_le H - ... = n : add_zero - -protected theorem sub_add_cancel {n m : ℕ} : n ≥ m → n - m + m = n := -!add.comm ▸ !add_sub_of_le - -theorem sub_add_of_le {n m : ℕ} : n ≤ m → n - m + m = m := -!add.comm ▸ add_sub_of_ge - -theorem sub.cases {P : ℕ → Type} {n m : ℕ} (H1 : n ≤ m → P 0) (H2 : Πk, m + k = n -> P k) - : P (n - m) := -sum.elim !le.total - (assume H3 : n ≤ m, (sub_eq_zero_of_le H3)⁻¹ ▸ (H1 H3)) - (assume H3 : m ≤ n, H2 (n - m) (add_sub_of_le H3)) - -theorem exists_sub_eq_of_le {n m : ℕ} (H : n ≤ m) : Σk, m - k = n := -obtain (k : ℕ) (Hk : n + k = m), from le.elim H, -sigma.mk k - (calc - m - k = n + k - k : by rewrite Hk - ... = n : nat.add_sub_cancel) - -protected theorem add_sub_assoc {m k : ℕ} (H : k ≤ m) (n : ℕ) : n + m - k = n + (m - k) := -have l1 : k ≤ m → n + m - k = n + (m - k), from - sub_induction k m - (take m : ℕ, - assume H : 0 ≤ m, - calc - n + m - 0 = n + m : nat.sub_zero - ... = n + (m - 0) : nat.sub_zero) - (take k : ℕ, assume H : succ k ≤ 0, absurd H !not_succ_le_zero) - (take k m, - assume IH : k ≤ m → n + m - k = n + (m - k), - take H : succ k ≤ succ m, - calc - n + succ m - succ k = succ (n + m) - succ k : add_succ - ... = n + m - k : succ_sub_succ - ... = n + (m - k) : IH (le_of_succ_le_succ H) - ... = n + (succ m - succ k) : succ_sub_succ), -l1 H - -theorem le_of_sub_eq_zero {n m : ℕ} : n - m = 0 → n ≤ m := -sub.cases - (assume H1 : n ≤ m, assume H2 : 0 = 0, H1) - (take k : ℕ, - assume H1 : m + k = n, - assume H2 : k = 0, - have H3 : n = m, from !add_zero ▸ H2 ▸ H1⁻¹, - H3 ▸ !le.refl) - -theorem sub_sub.cases {P : ℕ → ℕ → Type} {n m : ℕ} (H1 : Πk, n = m + k -> P k 0) - (H2 : Πk, m = n + k → P 0 k) : P (n - m) (m - n) := -sum.elim !le.total - (assume H3 : n ≤ m, - (sub_eq_zero_of_le H3)⁻¹ ▸ (H2 (m - n) (add_sub_of_le H3)⁻¹)) - (assume H3 : m ≤ n, - (sub_eq_zero_of_le H3)⁻¹ ▸ (H1 (n - m) (add_sub_of_le H3)⁻¹)) - -protected theorem sub_eq_of_add_eq {n m k : ℕ} (H : n + m = k) : k - n = m := -have H2 : k - n + n = m + n, from - calc - k - n + n = k : nat.sub_add_cancel (le.intro H) - ... = n + m : H⁻¹ - ... = m + n : !add.comm, -add.right_cancel H2 - -protected theorem eq_sub_of_add_eq {a b c : ℕ} (H : a + c = b) : a = b - c := -(nat.sub_eq_of_add_eq (!add.comm ▸ H))⁻¹ - -protected theorem sub_eq_of_eq_add {a b c : ℕ} (H : a = c + b) : a - b = c := -nat.sub_eq_of_add_eq (!add.comm ▸ H⁻¹) - -protected theorem sub_le_sub_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n - k ≤ m - k := -obtain (l : ℕ) (Hl : n + l = m), from le.elim H, -sum.elim !le.total - (assume H2 : n ≤ k, (sub_eq_zero_of_le H2)⁻¹ ▸ !zero_le) - (assume H2 : k ≤ n, - have H3 : n - k + l = m - k, from - calc - n - k + l = l + (n - k) : add.comm - ... = l + n - k : nat.add_sub_assoc H2 l - ... = n + l - k : add.comm - ... = m - k : Hl, - le.intro H3) - -protected theorem sub_le_sub_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k - m ≤ k - n := -obtain (l : ℕ) (Hl : n + l = m), from le.elim H, -sub.cases - (assume H2 : k ≤ m, !zero_le) - (take m' : ℕ, - assume Hm : m + m' = k, - have H3 : n ≤ k, from le.trans H (le.intro Hm), - have H4 : m' + l + n = k - n + n, from - calc - m' + l + n = n + (m' + l) : add.comm - ... = n + (l + m') : add.comm - ... = n + l + m' : add.assoc - ... = m + m' : Hl - ... = k : Hm - ... = k - n + n : nat.sub_add_cancel H3, - le.intro (add.right_cancel H4)) - -protected theorem sub_pos_of_lt {m n : ℕ} (H : m < n) : n - m > 0 := -have H1 : n = n - m + m, from (nat.sub_add_cancel (le_of_lt H))⁻¹, -have H2 : 0 + m < n - m + m, begin rewrite [zero_add, -H1], exact H end, -!lt_of_add_lt_add_right H2 - -protected theorem lt_of_sub_pos {m n : ℕ} (H : n - m > 0) : m < n := -lt_of_not_ge - (take H1 : m ≥ n, - have H2 : n - m = 0, from sub_eq_zero_of_le H1, - !lt.irrefl (H2 ▸ H)) - -protected theorem lt_of_sub_lt_sub_right {n m k : ℕ} (H : n - k < m - k) : n < m := -lt_of_not_ge - (assume H1 : m ≤ n, - have H2 : m - k ≤ n - k, from nat.sub_le_sub_right H1 _, - not_le_of_gt H H2) - -protected theorem lt_of_sub_lt_sub_left {n m k : ℕ} (H : n - m < n - k) : k < m := -lt_of_not_ge - (assume H1 : m ≤ k, - have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H1 _, - not_le_of_gt H H2) - -protected theorem sub_lt_sub_add_sub (n m k : ℕ) : n - k ≤ (n - m) + (m - k) := -sub.cases - (assume H : n ≤ m, (zero_add (m - k))⁻¹ ▸ nat.sub_le_sub_right H k) - (take mn : ℕ, - assume Hmn : m + mn = n, - sub.cases - (assume H : m ≤ k, - have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H n, - have H3 : n - k ≤ mn, from nat.sub_eq_of_add_eq Hmn ▸ H2, - show n - k ≤ mn + 0, begin rewrite add_zero, assumption end) - (take km : ℕ, - assume Hkm : k + km = m, - have H : k + (mn + km) = n, from - calc - k + (mn + km) = k + (km + mn): add.comm - ... = k + km + mn : add.assoc - ... = m + mn : Hkm - ... = n : Hmn, - have H2 : n - k = mn + km, from nat.sub_eq_of_add_eq H, - H2 ▸ !le.refl)) - -protected theorem sub_lt_self {m n : ℕ} (H1 : m > 0) (H2 : n > 0) : m - n < m := -calc - m - n = succ (pred m) - n : succ_pred_of_pos H1 - ... = succ (pred m) - succ (pred n) : succ_pred_of_pos H2 - ... = pred m - pred n : succ_sub_succ - ... ≤ pred m : sub_le - ... < succ (pred m) : lt_succ_self - ... = m : succ_pred_of_pos H1 - -protected theorem le_sub_of_add_le {m n k : ℕ} (H : m + k ≤ n) : m ≤ n - k := -calc - m = m + k - k : nat.add_sub_cancel - ... ≤ n - k : nat.sub_le_sub_right H k - -protected theorem lt_sub_of_add_lt {m n k : ℕ} (H : m + k < n) (H2 : k ≤ n) : m < n - k := -lt_of_succ_le (nat.le_sub_of_add_le (calc - succ m + k = succ (m + k) : succ_add_eq_succ_add - ... ≤ n : succ_le_of_lt H)) - -protected theorem sub_lt_of_lt_add {v n m : nat} (h₁ : v < n + m) (h₂ : n ≤ v) : v - n < m := -have succ v ≤ n + m, from succ_le_of_lt h₁, -have succ (v - n) ≤ m, from - calc succ (v - n) = succ v - n : succ_sub h₂ - ... ≤ n + m - n : nat.sub_le_sub_right this n - ... = m : nat.add_sub_cancel_left, -lt_of_succ_le this - -/- distance -/ - -definition dist [reducible] (n m : ℕ) := (n - m) + (m - n) - -theorem dist.comm (n m : ℕ) : dist n m = dist m n := -!add.comm - -theorem dist_self (n : ℕ) : dist n n = 0 := -calc - (n - n) + (n - n) = 0 + (n - n) : nat.sub_self - ... = 0 + 0 : nat.sub_self - ... = 0 : rfl - -theorem eq_of_dist_eq_zero {n m : ℕ} (H : dist n m = 0) : n = m := -have H2 : n - m = 0, from eq_zero_of_add_eq_zero_right H, -have H3 : n ≤ m, from le_of_sub_eq_zero H2, -have H4 : m - n = 0, from eq_zero_of_add_eq_zero_left H, -have H5 : m ≤ n, from le_of_sub_eq_zero H4, -le.antisymm H3 H5 - -theorem dist_eq_zero {n m : ℕ} (H : n = m) : dist n m = 0 := -by substvars; rewrite [↑dist, *nat.sub_self, add_zero] - -theorem dist_eq_sub_of_le {n m : ℕ} (H : n ≤ m) : dist n m = m - n := -calc - dist n m = 0 + (m - n) : {sub_eq_zero_of_le H} - ... = m - n : zero_add - -theorem dist_eq_sub_of_lt {n m : ℕ} (H : n < m) : dist n m = m - n := -dist_eq_sub_of_le (le_of_lt H) - -theorem dist_eq_sub_of_ge {n m : ℕ} (H : n ≥ m) : dist n m = n - m := -!dist.comm ▸ dist_eq_sub_of_le H - -theorem dist_eq_sub_of_gt {n m : ℕ} (H : n > m) : dist n m = n - m := -dist_eq_sub_of_ge (le_of_lt H) - -theorem dist_zero_right (n : ℕ) : dist n 0 = n := -dist_eq_sub_of_ge !zero_le ⬝ !nat.sub_zero - -theorem dist_zero_left (n : ℕ) : dist 0 n = n := -dist_eq_sub_of_le !zero_le ⬝ !nat.sub_zero - -theorem dist.intro {n m k : ℕ} (H : n + m = k) : dist k n = m := -calc - dist k n = k - n : dist_eq_sub_of_ge (le.intro H) - ... = m : nat.sub_eq_of_add_eq H - -theorem dist_add_add_right (n k m : ℕ) : dist (n + k) (m + k) = dist n m := -calc - dist (n + k) (m + k) = ((n+k) - (m+k)) + ((m+k)-(n+k)) : rfl - ... = (n - m) + ((m + k) - (n + k)) : nat.add_sub_add_right - ... = (n - m) + (m - n) : nat.add_sub_add_right - -theorem dist_add_add_left (k n m : ℕ) : dist (k + n) (k + m) = dist n m := -begin rewrite [add.comm k n, add.comm k m]; apply dist_add_add_right end - -theorem dist_add_eq_of_ge {n m : ℕ} (H : n ≥ m) : dist n m + m = n := -calc - dist n m + m = n - m + m : {dist_eq_sub_of_ge H} - ... = n : nat.sub_add_cancel H - -theorem dist_eq_intro {n m k l : ℕ} (H : n + m = k + l) : dist n k = dist l m := -calc - dist n k = dist (n + m) (k + m) : dist_add_add_right - ... = dist (k + l) (k + m) : H - ... = dist l m : dist_add_add_left - -theorem dist_sub_eq_dist_add_left {n m : ℕ} (H : n ≥ m) (k : ℕ) : - dist (n - m) k = dist n (k + m) := -have H2 : n - m + (k + m) = k + n, from - calc - n - m + (k + m) = n - m + (m + k) : add.comm - ... = n - m + m + k : add.assoc - ... = n + k : nat.sub_add_cancel H - ... = k + n : add.comm, -dist_eq_intro H2 - -theorem dist_sub_eq_dist_add_right {k m : ℕ} (H : k ≥ m) (n : ℕ) : - dist n (k - m) = dist (n + m) k := -dist.comm (k - m) n ▸ dist.comm k (n + m) ▸ dist_sub_eq_dist_add_left H n - -theorem dist.triangle_inequality (n m k : ℕ) : dist n k ≤ dist n m + dist m k := -have (n - m) + (m - k) + ((k - m) + (m - n)) = (n - m) + (m - n) + ((m - k) + (k - m)), -begin rewrite [add.comm (k - m) (m - n), - {n - m + _ + _}add.assoc, - {m - k + _}add.left_comm, -add.assoc] end, -this ▸ add_le_add !nat.sub_lt_sub_add_sub !nat.sub_lt_sub_add_sub - -theorem dist_add_add_le_add_dist_dist (n m k l : ℕ) : dist (n + m) (k + l) ≤ dist n k + dist m l := -have H : dist (n + m) (k + m) + dist (k + m) (k + l) = dist n k + dist m l, - by rewrite [dist_add_add_left, dist_add_add_right], -by rewrite -H; apply dist.triangle_inequality - -theorem dist_mul_right (n k m : ℕ) : dist (n * k) (m * k) = dist n m * k := -have Π n m, dist n m = n - m + (m - n), from take n m, rfl, -by rewrite [this, this n m, right_distrib, *nat.mul_sub_right_distrib] - -theorem dist_mul_left (k n m : ℕ) : dist (k * n) (k * m) = k * dist n m := -begin rewrite [mul.comm k n, mul.comm k m, dist_mul_right, mul.comm] end - -theorem dist_mul_dist (n m k l : ℕ) : dist n m * dist k l = dist (n * k + m * l) (n * l + m * k) := -have aux : Πk l, k ≥ l → dist n m * dist k l = dist (n * k + m * l) (n * l + m * k), from - take k l : ℕ, - assume H : k ≥ l, - have H2 : m * k ≥ m * l, from !mul_le_mul_left H, - have H3 : n * l + m * k ≥ m * l, from le.trans H2 !le_add_left, - calc - dist n m * dist k l = dist n m * (k - l) : dist_eq_sub_of_ge H - ... = dist (n * (k - l)) (m * (k - l)) : dist_mul_right - ... = dist (n * k - n * l) (m * k - m * l) : by rewrite [*nat.mul_sub_left_distrib] - ... = dist (n * k) (m * k - m * l + n * l) : dist_sub_eq_dist_add_left (!mul_le_mul_left H) - ... = dist (n * k) (n * l + (m * k - m * l)) : add.comm - ... = dist (n * k) (n * l + m * k - m * l) : nat.add_sub_assoc H2 (n * l) - ... = dist (n * k + m * l) (n * l + m * k) : dist_sub_eq_dist_add_right H3 _, -sum.elim !le.total - (assume H : k ≤ l, !dist.comm ▸ !dist.comm ▸ aux l k H) - (assume H : l ≤ k, aux k l H) - -lemma dist_eq_max_sub_min {i j : nat} : dist i j = (max i j) - min i j := -sum.elim (lt_sum_ge i j) - (suppose i < j, - by rewrite [max_eq_right_of_lt this, min_eq_left_of_lt this, dist_eq_sub_of_lt this]) - (suppose i ≥ j, - by rewrite [max_eq_left this , min_eq_right this, dist_eq_sub_of_ge this]) - -lemma dist_succ {i j : nat} : dist (succ i) (succ j) = dist i j := -by rewrite [↑dist, *succ_sub_succ] - -lemma dist_le_max {i j : nat} : dist i j ≤ max i j := -begin rewrite dist_eq_max_sub_min, apply sub_le end - -lemma dist_pos_of_ne {i j : nat} : i ≠ j → dist i j > 0 := -assume Pne, lt.by_cases - (suppose i < j, begin rewrite [dist_eq_sub_of_lt this], apply nat.sub_pos_of_lt this end) - (suppose i = j, by contradiction) - (suppose i > j, begin rewrite [dist_eq_sub_of_gt this], apply nat.sub_pos_of_lt this end) - -end nat diff --git a/hott/types/num.hlean b/hott/types/num.hlean deleted file mode 100644 index dc7b8b10ac..0000000000 --- a/hott/types/num.hlean +++ /dev/null @@ -1,523 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Leonardo de Moura --/ -import types.bool tools.helper_tactics -open bool eq eq.ops decidable helper_tactics - -namespace pos_num - theorem succ_not_is_one (a : pos_num) : is_one (succ a) = ff := - pos_num.rec_on a rfl (take n iH, rfl) (take n iH, rfl) - - theorem succ_one : succ one = bit0 one - theorem succ_bit1 (a : pos_num) : succ (bit1 a) = bit0 (succ a) - theorem succ_bit0 (a : pos_num) : succ (bit0 a) = bit1 a - - theorem ne_of_bit0_ne_bit0 {a b : pos_num} (H₁ : bit0 a ≠ bit0 b) : a ≠ b := - suppose a = b, - absurd rfl (this ▸ H₁) - - theorem ne_of_bit1_ne_bit1 {a b : pos_num} (H₁ : bit1 a ≠ bit1 b) : a ≠ b := - suppose a = b, - absurd rfl (this ▸ H₁) - - theorem pred_succ : Π (a : pos_num), pred (succ a) = a - | one := rfl - | (bit0 a) := by rewrite succ_bit0 - | (bit1 a) := - calc - pred (succ (bit1 a)) = cond (is_one (succ a)) one (bit1 (pred (succ a))) : rfl - ... = cond ff one (bit1 (pred (succ a))) : succ_not_is_one - ... = bit1 (pred (succ a)) : rfl - ... = bit1 a : pred_succ a - - section - variables (a b : pos_num) - - theorem one_add_one : one + one = bit0 one - theorem one_add_bit0 : one + (bit0 a) = bit1 a - theorem one_add_bit1 : one + (bit1 a) = succ (bit1 a) - theorem bit0_add_one : (bit0 a) + one = bit1 a - theorem bit1_add_one : (bit1 a) + one = succ (bit1 a) - theorem bit0_add_bit0 : (bit0 a) + (bit0 b) = bit0 (a + b) - theorem bit0_add_bit1 : (bit0 a) + (bit1 b) = bit1 (a + b) - theorem bit1_add_bit0 : (bit1 a) + (bit0 b) = bit1 (a + b) - theorem bit1_add_bit1 : (bit1 a) + (bit1 b) = succ (bit1 (a + b)) - theorem one_mul : one * a = a - end - - theorem mul_one : Π a, a * one = a - | one := rfl - | (bit1 n) := - calc bit1 n * one = bit0 (n * one) + one : rfl - ... = bit0 n + one : mul_one n - ... = bit1 n : bit0_add_one - | (bit0 n) := - calc bit0 n * one = bit0 (n * one) : rfl - ... = bit0 n : mul_one n - - theorem decidable_eq [instance] : Π (a b : pos_num), decidable (a = b) - | one one := inl rfl - | one (bit0 b) := inr (by contradiction) - | one (bit1 b) := inr (by contradiction) - | (bit0 a) one := inr (by contradiction) - | (bit0 a) (bit0 b) := - match decidable_eq a b with - | inl H₁ := inl (by rewrite H₁) - | inr H₁ := inr (by intro H; injection H; contradiction) - end - | (bit0 a) (bit1 b) := inr (by contradiction) - | (bit1 a) one := inr (by contradiction) - | (bit1 a) (bit0 b) := inr (by contradiction) - | (bit1 a) (bit1 b) := - match decidable_eq a b with - | inl H₁ := inl (by rewrite H₁) - | inr H₁ := inr (by intro H; injection H; contradiction) - end - - local notation a < b := (lt a b = tt) - local notation a ` ≮ `:50 b:50 := (lt a b = ff) - - theorem lt_one_right_eq_ff : Π a : pos_num, a ≮ one - | one := rfl - | (bit0 a) := rfl - | (bit1 a) := rfl - - theorem lt_one_succ_eq_tt : Π a : pos_num, one < succ a - | one := rfl - | (bit0 a) := rfl - | (bit1 a) := rfl - - theorem lt_of_lt_bit0_bit0 {a b : pos_num} (H : bit0 a < bit0 b) : a < b := H - theorem lt_of_lt_bit0_bit1 {a b : pos_num} (H : bit1 a < bit0 b) : a < b := H - theorem lt_of_lt_bit1_bit1 {a b : pos_num} (H : bit1 a < bit1 b) : a < b := H - theorem lt_of_lt_bit1_bit0 {a b : pos_num} (H : bit0 a < bit1 b) : a < succ b := H - - theorem lt_bit0_bit0_eq_lt (a b : pos_num) : lt (bit0 a) (bit0 b) = lt a b := - rfl - - theorem lt_bit1_bit1_eq_lt (a b : pos_num) : lt (bit1 a) (bit1 b) = lt a b := - rfl - - theorem lt_bit1_bit0_eq_lt (a b : pos_num) : lt (bit1 a) (bit0 b) = lt a b := - rfl - - theorem lt_bit0_bit1_eq_lt_succ (a b : pos_num) : lt (bit0 a) (bit1 b) = lt a (succ b) := - rfl - - theorem lt_irrefl : Π (a : pos_num), a ≮ a - | one := rfl - | (bit0 a) := - begin - rewrite lt_bit0_bit0_eq_lt, apply lt_irrefl - end - | (bit1 a) := - begin - rewrite lt_bit1_bit1_eq_lt, apply lt_irrefl - end - - theorem ne_of_lt_eq_tt : Π {a b : pos_num}, a < b → a = b → empty - | one ⌞one⌟ H₁ (eq.refl one) := absurd H₁ ff_ne_tt - | (bit0 a) ⌞(bit0 a)⌟ H₁ (eq.refl (bit0 a)) := - begin - rewrite lt_bit0_bit0_eq_lt at H₁, - apply ne_of_lt_eq_tt H₁ (eq.refl a) - end - | (bit1 a) ⌞(bit1 a)⌟ H₁ (eq.refl (bit1 a)) := - begin - rewrite lt_bit1_bit1_eq_lt at H₁, - apply ne_of_lt_eq_tt H₁ (eq.refl a) - end - - theorem lt_base : Π a : pos_num, a < succ a - | one := rfl - | (bit0 a) := - begin - rewrite [succ_bit0, lt_bit0_bit1_eq_lt_succ], - apply lt_base - end - | (bit1 a) := - begin - rewrite [succ_bit1, lt_bit1_bit0_eq_lt], - apply lt_base - end - - theorem lt_step : Π {a b : pos_num}, a < b → a < succ b - | one one H := rfl - | one (bit0 b) H := rfl - | one (bit1 b) H := rfl - | (bit0 a) one H := absurd H ff_ne_tt - | (bit0 a) (bit0 b) H := - begin - rewrite [succ_bit0, lt_bit0_bit1_eq_lt_succ, lt_bit0_bit0_eq_lt at H], - apply lt_step H - end - | (bit0 a) (bit1 b) H := - begin - rewrite [succ_bit1, lt_bit0_bit0_eq_lt, lt_bit0_bit1_eq_lt_succ at H], - exact H - end - | (bit1 a) one H := absurd H ff_ne_tt - | (bit1 a) (bit0 b) H := - begin - rewrite [succ_bit0, lt_bit1_bit1_eq_lt, lt_bit1_bit0_eq_lt at H], - exact H - end - | (bit1 a) (bit1 b) H := - begin - rewrite [succ_bit1, lt_bit1_bit0_eq_lt, lt_bit1_bit1_eq_lt at H], - apply lt_step H - end - - theorem lt_of_lt_succ_succ : Π {a b : pos_num}, succ a < succ b → a < b - | one one H := absurd H ff_ne_tt - | one (bit0 b) H := rfl - | one (bit1 b) H := rfl - | (bit0 a) one H := - begin - rewrite [succ_bit0 at H, succ_one at H, lt_bit1_bit0_eq_lt at H], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff a) H - end - | (bit0 a) (bit0 b) H := by exact H - | (bit0 a) (bit1 b) H := by exact H - | (bit1 a) one H := - begin - rewrite [succ_bit1 at H, succ_one at H, lt_bit0_bit0_eq_lt at H], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff (succ a)) H - end - | (bit1 a) (bit0 b) H := - begin - rewrite [succ_bit1 at H, succ_bit0 at H, lt_bit0_bit1_eq_lt_succ at H], - rewrite lt_bit1_bit0_eq_lt, - apply lt_of_lt_succ_succ H - end - | (bit1 a) (bit1 b) H := - begin - rewrite [lt_bit1_bit1_eq_lt, *succ_bit1 at H, lt_bit0_bit0_eq_lt at H], - apply lt_of_lt_succ_succ H - end - - theorem lt_succ_succ : Π {a b : pos_num}, a < b → succ a < succ b - | one one H := absurd H ff_ne_tt - | one (bit0 b) H := - begin - rewrite [succ_bit0, succ_one, lt_bit0_bit1_eq_lt_succ], - apply lt_one_succ_eq_tt - end - | one (bit1 b) H := - begin - rewrite [succ_one, succ_bit1, lt_bit0_bit0_eq_lt], - apply lt_one_succ_eq_tt - end - | (bit0 a) one H := absurd H ff_ne_tt - | (bit0 a) (bit0 b) H := by exact H - | (bit0 a) (bit1 b) H := by exact H - | (bit1 a) one H := absurd H ff_ne_tt - | (bit1 a) (bit0 b) H := - begin - rewrite [succ_bit1, succ_bit0, lt_bit0_bit1_eq_lt_succ, lt_bit1_bit0_eq_lt at H], - apply lt_succ_succ H - end - | (bit1 a) (bit1 b) H := - begin - rewrite [lt_bit1_bit1_eq_lt at H, *succ_bit1, lt_bit0_bit0_eq_lt], - apply lt_succ_succ H - end - - theorem lt_of_lt_succ : Π {a b : pos_num}, succ a < b → a < b - | one one H := absurd_of_eq_ff_of_eq_tt !lt_one_right_eq_ff H - | one (bit0 b) H := rfl - | one (bit1 b) H := rfl - | (bit0 a) one H := absurd_of_eq_ff_of_eq_tt !lt_one_right_eq_ff H - | (bit0 a) (bit0 b) H := by exact H - | (bit0 a) (bit1 b) H := - begin - rewrite [succ_bit0 at H, lt_bit1_bit1_eq_lt at H, lt_bit0_bit1_eq_lt_succ], - apply lt_step H - end - | (bit1 a) one H := absurd_of_eq_ff_of_eq_tt !lt_one_right_eq_ff H - | (bit1 a) (bit0 b) H := - begin - rewrite [lt_bit1_bit0_eq_lt, succ_bit1 at H, lt_bit0_bit0_eq_lt at H], - apply lt_of_lt_succ H - end - | (bit1 a) (bit1 b) H := - begin - rewrite [succ_bit1 at H, lt_bit0_bit1_eq_lt_succ at H, lt_bit1_bit1_eq_lt], - apply lt_of_lt_succ_succ H - end - - theorem lt_of_lt_succ_of_ne : Π {a b : pos_num}, a < succ b → a ≠ b → a < b - | one one H₁ H₂ := absurd rfl H₂ - | one (bit0 b) H₁ H₂ := rfl - | one (bit1 b) H₁ H₂ := rfl - | (bit0 a) one H₁ H₂ := - begin - rewrite [succ_one at H₁, lt_bit0_bit0_eq_lt at H₁], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₁ - end - | (bit0 a) (bit0 b) H₁ H₂ := - begin - rewrite [lt_bit0_bit0_eq_lt, succ_bit0 at H₁, lt_bit0_bit1_eq_lt_succ at H₁], - apply lt_of_lt_succ_of_ne H₁ (ne_of_bit0_ne_bit0 H₂) - end - | (bit0 a) (bit1 b) H₁ H₂ := - begin - rewrite [succ_bit1 at H₁, lt_bit0_bit0_eq_lt at H₁, lt_bit0_bit1_eq_lt_succ], - exact H₁ - end - | (bit1 a) one H₁ H₂ := - begin - rewrite [succ_one at H₁, lt_bit1_bit0_eq_lt at H₁], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₁ - end - | (bit1 a) (bit0 b) H₁ H₂ := - begin - rewrite [succ_bit0 at H₁, lt_bit1_bit1_eq_lt at H₁, lt_bit1_bit0_eq_lt], - exact H₁ - end - | (bit1 a) (bit1 b) H₁ H₂ := - begin - rewrite [succ_bit1 at H₁, lt_bit1_bit0_eq_lt at H₁, lt_bit1_bit1_eq_lt], - apply lt_of_lt_succ_of_ne H₁ (ne_of_bit1_ne_bit1 H₂) - end - - theorem lt_trans : Π {a b c : pos_num}, a < b → b < c → a < c - | one b (bit0 c) H₁ H₂ := rfl - | one b (bit1 c) H₁ H₂ := rfl - | a (bit0 b) one H₁ H₂ := absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₂ - | a (bit1 b) one H₁ H₂ := absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₂ - | (bit0 a) (bit0 b) (bit0 c) H₁ H₂ := - begin - rewrite lt_bit0_bit0_eq_lt at *, apply lt_trans H₁ H₂ - end - | (bit0 a) (bit0 b) (bit1 c) H₁ H₂ := - begin - rewrite [lt_bit0_bit1_eq_lt_succ at *, lt_bit0_bit0_eq_lt at H₁], - apply lt_trans H₁ H₂ - end - | (bit0 a) (bit1 b) (bit0 c) H₁ H₂ := - begin - rewrite [lt_bit0_bit1_eq_lt_succ at H₁, lt_bit1_bit0_eq_lt at H₂, lt_bit0_bit0_eq_lt], - apply @by_cases (a = b), - begin - intro H, rewrite -H at H₂, exact H₂ - end, - begin - intro H, - apply lt_trans (lt_of_lt_succ_of_ne H₁ H) H₂ - end - end - | (bit0 a) (bit1 b) (bit1 c) H₁ H₂ := - begin - rewrite [lt_bit0_bit1_eq_lt_succ at *, lt_bit1_bit1_eq_lt at H₂], - apply lt_trans H₁ (lt_succ_succ H₂) - end - | (bit1 a) (bit0 b) (bit0 c) H₁ H₂ := - begin - rewrite [lt_bit0_bit0_eq_lt at H₂, lt_bit1_bit0_eq_lt at *], - apply lt_trans H₁ H₂ - end - | (bit1 a) (bit0 b) (bit1 c) H₁ H₂ := - begin - rewrite [lt_bit1_bit0_eq_lt at H₁, lt_bit0_bit1_eq_lt_succ at H₂, lt_bit1_bit1_eq_lt], - apply @by_cases (b = c), - begin - intro H, rewrite H at H₁, exact H₁ - end, - begin - intro H, - apply lt_trans H₁ (lt_of_lt_succ_of_ne H₂ H) - end - end - | (bit1 a) (bit1 b) (bit0 c) H₁ H₂ := - begin - rewrite [lt_bit1_bit1_eq_lt at H₁, lt_bit1_bit0_eq_lt at H₂, lt_bit1_bit0_eq_lt], - apply lt_trans H₁ H₂ - end - | (bit1 a) (bit1 b) (bit1 c) H₁ H₂ := - begin - rewrite lt_bit1_bit1_eq_lt at *, - apply lt_trans H₁ H₂ - end - - theorem lt_antisymm : Π {a b : pos_num}, a < b → b ≮ a - | one one H := rfl - | one (bit0 b) H := rfl - | one (bit1 b) H := rfl - | (bit0 a) one H := absurd H ff_ne_tt - | (bit0 a) (bit0 b) H := - begin - rewrite lt_bit0_bit0_eq_lt at *, - apply lt_antisymm H - end - | (bit0 a) (bit1 b) H := - begin - rewrite lt_bit1_bit0_eq_lt, - rewrite lt_bit0_bit1_eq_lt_succ at H, - have H₁ : succ b ≮ a, from lt_antisymm H, - apply eq_ff_of_ne_tt, - intro H₂, - apply @by_cases (succ b = a), - show succ b = a → empty, - begin - intro Hp, - rewrite -Hp at H, - apply absurd_of_eq_ff_of_eq_tt (lt_irrefl (succ b)) H - end, - show succ b ≠ a → empty, - begin - intro Hn, - have H₃ : succ b < succ a, from lt_succ_succ H₂, - have H₄ : succ b < a, from lt_of_lt_succ_of_ne H₃ Hn, - apply absurd_of_eq_ff_of_eq_tt H₁ H₄ - end, - end - | (bit1 a) one H := absurd H ff_ne_tt - | (bit1 a) (bit0 b) H := - begin - rewrite lt_bit0_bit1_eq_lt_succ, - rewrite lt_bit1_bit0_eq_lt at H, - have H₁ : lt b a = ff, from lt_antisymm H, - apply eq_ff_of_ne_tt, - intro H₂, - apply @by_cases (b = a), - show b = a → empty, - begin - intro Hp, - rewrite -Hp at H, - apply absurd_of_eq_ff_of_eq_tt (lt_irrefl b) H - end, - show b ≠ a → empty, - begin - intro Hn, - have H₃ : b < a, from lt_of_lt_succ_of_ne H₂ Hn, - apply absurd_of_eq_ff_of_eq_tt H₁ H₃ - end, - end - | (bit1 a) (bit1 b) H := - begin - rewrite lt_bit1_bit1_eq_lt at *, - apply lt_antisymm H - end - - local notation a ≤ b := (le a b = tt) - - theorem le_refl : Π a : pos_num, a ≤ a := - lt_base - - theorem le_eq_lt_succ {a b : pos_num} : le a b = lt a (succ b) := - rfl - - theorem not_lt_of_le : Π {a b : pos_num}, a ≤ b → b < a → empty - | one one H₁ H₂ := absurd H₂ ff_ne_tt - | one (bit0 b) H₁ H₂ := absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₂ - | one (bit1 b) H₁ H₂ := absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₂ - | (bit0 a) one H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_one at H₁, lt_bit0_bit0_eq_lt at H₁], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₁ - end - | (bit0 a) (bit0 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_bit0 at H₁, lt_bit0_bit1_eq_lt_succ at H₁], - rewrite [lt_bit0_bit0_eq_lt at H₂], - apply not_lt_of_le H₁ H₂ - end - | (bit0 a) (bit1 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_bit1 at H₁, lt_bit0_bit0_eq_lt at H₁], - rewrite [lt_bit1_bit0_eq_lt at H₂], - apply not_lt_of_le H₁ H₂ - end - | (bit1 a) one H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_one at H₁, lt_bit1_bit0_eq_lt at H₁], - apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff _) H₁ - end - | (bit1 a) (bit0 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_bit0 at H₁, lt_bit1_bit1_eq_lt at H₁], - rewrite lt_bit0_bit1_eq_lt_succ at H₂, - have H₃ : a < succ b, from lt_step H₁, - apply @by_cases (b = a), - begin - intro Hba, rewrite -Hba at H₁, - apply absurd_of_eq_ff_of_eq_tt (lt_irrefl b) H₁ - end, - begin - intro Hnba, - have H₄ : b < a, from lt_of_lt_succ_of_ne H₂ Hnba, - apply not_lt_of_le H₃ H₄ - end - end - | (bit1 a) (bit1 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at H₁, succ_bit1 at H₁, lt_bit1_bit0_eq_lt at H₁], - rewrite [lt_bit1_bit1_eq_lt at H₂], - apply not_lt_of_le H₁ H₂ - end - - theorem le_antisymm : Π {a b : pos_num}, a ≤ b → b ≤ a → a = b - | one one H₁ H₂ := rfl - | one (bit0 b) H₁ H₂ := - by apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff b) H₂ - | one (bit1 b) H₁ H₂ := - by apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff b) H₂ - | (bit0 a) one H₁ H₂ := - by apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff a) H₁ - | (bit0 a) (bit0 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at *, succ_bit0 at *, lt_bit0_bit1_eq_lt_succ at *], - have H : a = b, from le_antisymm H₁ H₂, - rewrite H - end - | (bit0 a) (bit1 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at *, succ_bit1 at H₁, succ_bit0 at H₂], - rewrite [lt_bit0_bit0_eq_lt at H₁, lt_bit1_bit1_eq_lt at H₂], - apply empty.rec _ (not_lt_of_le H₁ H₂) - end - | (bit1 a) one H₁ H₂ := - by apply absurd_of_eq_ff_of_eq_tt (lt_one_right_eq_ff a) H₁ - | (bit1 a) (bit0 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at *, succ_bit0 at H₁, succ_bit1 at H₂], - rewrite [lt_bit1_bit1_eq_lt at H₁, lt_bit0_bit0_eq_lt at H₂], - apply empty.rec _ (not_lt_of_le H₂ H₁) - end - | (bit1 a) (bit1 b) H₁ H₂ := - begin - rewrite [le_eq_lt_succ at *, succ_bit1 at *, lt_bit1_bit0_eq_lt at *], - have H : a = b, from le_antisymm H₁ H₂, - rewrite H - end - - theorem le_trans {a b c : pos_num} : a ≤ b → b ≤ c → a ≤ c := - begin - intro H₁ H₂, - rewrite [le_eq_lt_succ at *], - apply @by_cases (a = b), - begin - intro Hab, rewrite Hab, exact H₂ - end, - begin - intro Hnab, - have Haltb : a < b, from lt_of_lt_succ_of_ne H₁ Hnab, - apply lt_trans Haltb H₂ - end, - end - -end pos_num - -namespace num - open pos_num - - theorem decidable_eq [instance] : Π (a b : num), decidable (a = b) - | zero zero := inl rfl - | zero (pos b) := inr (by contradiction) - | (pos a) zero := inr (by contradiction) - | (pos a) (pos b) := - if H : a = b then inl (by rewrite H) else inr (suppose pos a = pos b, begin injection this, contradiction end) -end num diff --git a/hott/types/pi.hlean b/hott/types/pi.hlean deleted file mode 100644 index 28dfa92c98..0000000000 --- a/hott/types/pi.hlean +++ /dev/null @@ -1,333 +0,0 @@ -/- -Copyright (c) 2014-15 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Floris van Doorn - -Partially ported from Coq HoTT -Theorems about pi-types (dependent function spaces) --/ - -import types.sigma arity - -open eq equiv is_equiv funext sigma unit bool is_trunc prod - -namespace pi - variables {A A' : Type} {B : A → Type} {B' : A' → Type} {C : Πa, B a → Type} - {D : Πa b, C a b → Type} - {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {f g : Πa, B a} - - /- Paths -/ - - /- - Paths [p : f ≈ g] in a function type [Πx:X, P x] are equivalent to functions taking values - in path types, [H : Πx:X, f x ≈ g x], or concisely, [H : f ~ g]. - - This equivalence, however, is just the combination of [apd10] and function extensionality - [funext], and as such, [eq_of_homotopy] - - Now we show how these things compute. - -/ - - definition apd10_eq_of_homotopy (h : f ~ g) : apd10 (eq_of_homotopy h) ~ h := - apd10 (right_inv apd10 h) - - definition eq_of_homotopy_eta (p : f = g) : eq_of_homotopy (apd10 p) = p := - left_inv apd10 p - - definition eq_of_homotopy_idp (f : Πa, B a) : eq_of_homotopy (λx : A, refl (f x)) = refl f := - !eq_of_homotopy_eta - - /- - The identification of the path space of a dependent function space, - up to equivalence, is of course just funext. - -/ - - definition eq_equiv_homotopy (f g : Πx, B x) : (f = g) ≃ (f ~ g) := - equiv.mk apd10 _ - - definition pi_eq_equiv (f g : Πx, B x) : (f = g) ≃ (f ~ g) := !eq_equiv_homotopy - - definition is_equiv_eq_of_homotopy (f g : Πx, B x) - : is_equiv (eq_of_homotopy : f ~ g → f = g) := - _ - - definition homotopy_equiv_eq (f g : Πx, B x) : (f ~ g) ≃ (f = g) := - equiv.mk eq_of_homotopy _ - - - /- Transport -/ - - definition pi_transport (p : a = a') (f : Π(b : B a), C a b) - : (transport (λa, Π(b : B a), C a b) p f) ~ (λb, !tr_inv_tr ▸ (p ▸D (f (p⁻¹ ▸ b)))) := - by induction p; reflexivity - - /- A special case of [transport_pi] where the type [B] does not depend on [A], - and so it is just a fixed type [B]. -/ - definition pi_transport_constant {C : A → A' → Type} (p : a = a') (f : Π(b : A'), C a b) (b : A') - : (transport _ p f) b = p ▸ (f b) := - by induction p; reflexivity - - /- Pathovers -/ - - definition pi_pathover {f : Πb, C a b} {g : Πb', C a' b'} {p : a = a'} - (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[apo011 C p q] g b') : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply eq_of_pathover_idp, apply r - end - - definition pi_pathover_left {f : Πb, C a b} {g : Πb', C a' b'} {p : a = a'} - (r : Π(b : B a), f b =[apo011 C p !pathover_tr] g (p ▸ b)) : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply eq_of_pathover_idp, apply r - end - - definition pi_pathover_right {f : Πb, C a b} {g : Πb', C a' b'} {p : a = a'} - (r : Π(b' : B a'), f (p⁻¹ ▸ b') =[apo011 C p !tr_pathover] g b') : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply eq_of_pathover_idp, apply r - end - - definition pi_pathover_constant {C : A → A' → Type} {f : Π(b : A'), C a b} - {g : Π(b : A'), C a' b} {p : a = a'} - (r : Π(b : A'), f b =[p] g b) : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - exact eq_of_pathover_idp (r b), - end - - -- a version where C is uncurried, but where the conclusion of r is still a proper pathover - -- instead of a heterogenous equality - definition pi_pathover' {C : (Σa, B a) → Type} {f : Πb, C ⟨a, b⟩} {g : Πb', C ⟨a', b'⟩} - {p : a = a'} (r : Π(b : B a) (b' : B a') (q : b =[p] b'), f b =[dpair_eq_dpair p q] g b') - : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply (@eq_of_pathover_idp _ C), exact (r b b (pathover.idpatho b)), - end - - definition pi_pathover_left' {C : (Σa, B a) → Type} {f : Πb, C ⟨a, b⟩} {g : Πb', C ⟨a', b'⟩} - {p : a = a'} (r : Π(b : B a), f b =[dpair_eq_dpair p !pathover_tr] g (p ▸ b)) - : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply eq_of_pathover_idp, esimp at r, exact !pathover_ap (r b) - end - - definition pi_pathover_right' {C : (Σa, B a) → Type} {f : Πb, C ⟨a, b⟩} {g : Πb', C ⟨a', b'⟩} - {p : a = a'} (r : Π(b' : B a'), f (p⁻¹ ▸ b') =[dpair_eq_dpair p !tr_pathover] g b') - : f =[p] g := - begin - cases p, apply pathover_idp_of_eq, - apply eq_of_homotopy, intro b, - apply eq_of_pathover_idp, esimp at r, exact !pathover_ap (r b) - end - - - /- Maps on paths -/ - - /- The action of maps given by lambda. -/ - definition ap_lambdaD {C : A' → Type} (p : a = a') (f : Πa b, C b) : - ap (λa b, f a b) p = eq_of_homotopy (λb, ap (λa, f a b) p) := - begin - apply (eq.rec_on p), - apply inverse, - apply eq_of_homotopy_idp - end - - /- Dependent paths -/ - - /- with more implicit arguments the conclusion of the following theorem is - (Π(b : B a), transportD B C p b (f b) = g (transport B p b)) ≃ - (transport (λa, Π(b : B a), C a b) p f = g) -/ - definition heq_piD (p : a = a') (f : Π(b : B a), C a b) - (g : Π(b' : B a'), C a' b') : (Π(b : B a), p ▸D (f b) = g (p ▸ b)) ≃ (p ▸ f = g) := - eq.rec_on p (λg, !homotopy_equiv_eq) g - - definition heq_pi {C : A → Type} (p : a = a') (f : Π(b : B a), C a) - (g : Π(b' : B a'), C a') : (Π(b : B a), p ▸ (f b) = g (p ▸ b)) ≃ (p ▸ f = g) := - eq.rec_on p (λg, !homotopy_equiv_eq) g - - - section - open sigma sigma.ops - /- more implicit arguments: - (Π(b : B a), transport C (sigma_eq p idp) (f b) = g (p ▸ b)) ≃ - (Π(b : B a), transportD B (λ(a : A) (b : B a), C ⟨a, b⟩) p b (f b) = g (transport B p b)) -/ - definition heq_pi_sigma {C : (Σa, B a) → Type} (p : a = a') - (f : Π(b : B a), C ⟨a, b⟩) (g : Π(b' : B a'), C ⟨a', b'⟩) : - (Π(b : B a), (sigma_eq p !pathover_tr) ▸ (f b) = g (p ▸ b)) ≃ - (Π(b : B a), p ▸D (f b) = g (p ▸ b)) := - eq.rec_on p (λg, !equiv.refl) g - end - - /- Functorial action -/ - variables (f0 : A' → A) (f1 : Π(a':A'), B (f0 a') → B' a') - - /- The functoriality of [forall] is slightly subtle: it is contravariant in the domain type and covariant in the codomain, but the codomain is dependent on the domain. -/ - - definition pi_functor [unfold_full] : (Π(a:A), B a) → (Π(a':A'), B' a') := - λg a', f1 a' (g (f0 a')) - - definition pi_functor_left [unfold_full] (B : A → Type) : (Π(a:A), B a) → (Π(a':A'), B (f0 a')) := - pi_functor f0 (λa, id) - - definition pi_functor_right [unfold_full] {B' : A → Type} (f1 : Π(a:A), B a → B' a) - : (Π(a:A), B a) → (Π(a:A), B' a) := - pi_functor id f1 - - definition ap_pi_functor {g g' : Π(a:A), B a} (h : g ~ g') - : ap (pi_functor f0 f1) (eq_of_homotopy h) - = eq_of_homotopy (λa':A', (ap (f1 a') (h (f0 a')))) := - begin - apply (is_equiv_rect (@apd10 A B g g')), intro p, clear h, - cases p, - apply concat, - exact (ap (ap (pi_functor f0 f1)) (eq_of_homotopy_idp g)), - apply symm, apply eq_of_homotopy_idp - end - - /- Equivalences -/ - - definition is_equiv_pi_functor [instance] [constructor] [H0 : is_equiv f0] - [H1 : Πa', is_equiv (f1 a')] : is_equiv (pi_functor f0 f1) := - begin - apply (adjointify (pi_functor f0 f1) (pi_functor f0⁻¹ - (λ(a : A) (b' : B' (f0⁻¹ a)), transport B (right_inv f0 a) ((f1 (f0⁻¹ a))⁻¹ b')))), - begin - intro h, apply eq_of_homotopy, intro a', esimp, - rewrite [adj f0 a',-tr_compose,fn_tr_eq_tr_fn _ f1,right_inv (f1 _)], - apply apd - end, - begin - intro h, apply eq_of_homotopy, intro a, esimp, - rewrite [left_inv (f1 _)], - apply apd - end - end - - definition pi_equiv_pi_of_is_equiv [constructor] [H : is_equiv f0] - [H1 : Πa', is_equiv (f1 a')] : (Πa, B a) ≃ (Πa', B' a') := - equiv.mk (pi_functor f0 f1) _ - - definition pi_equiv_pi [constructor] (f0 : A' ≃ A) (f1 : Πa', (B (to_fun f0 a') ≃ B' a')) - : (Πa, B a) ≃ (Πa', B' a') := - pi_equiv_pi_of_is_equiv (to_fun f0) (λa', to_fun (f1 a')) - - definition pi_equiv_pi_right [constructor] {P Q : A → Type} (g : Πa, P a ≃ Q a) - : (Πa, P a) ≃ (Πa, Q a) := - pi_equiv_pi equiv.refl g - - /- Equivalence if one of the types is contractible -/ - - definition pi_equiv_of_is_contr_left [constructor] (B : A → Type) [H : is_contr A] - : (Πa, B a) ≃ B (center A) := - begin - fapply equiv.MK, - { intro f, exact f (center A)}, - { intro b a, exact (center_eq a) ▸ b}, - { intro b, rewrite [prop_eq_of_is_contr (center_eq (center A)) idp]}, - { intro f, apply eq_of_homotopy, intro a, induction (center_eq a), - rewrite [prop_eq_of_is_contr (center_eq (center A)) idp]} - end - - definition pi_equiv_of_is_contr_right [constructor] [H : Πa, is_contr (B a)] - : (Πa, B a) ≃ unit := - begin - fapply equiv.MK, - { intro f, exact star}, - { intro u a, exact !center}, - { intro u, induction u, reflexivity}, - { intro f, apply eq_of_homotopy, intro a, apply is_prop.elim} - end - - /- Interaction with other type constructors -/ - - -- most of these are in the file of the other type constructor - - definition pi_empty_left [constructor] (B : empty → Type) : (Πx, B x) ≃ unit := - begin - fapply equiv.MK, - { intro f, exact star}, - { intro x y, contradiction}, - { intro x, induction x, reflexivity}, - { intro f, apply eq_of_homotopy, intro y, contradiction}, - end - - definition pi_unit_left [constructor] (B : unit → Type) : (Πx, B x) ≃ B star := - !pi_equiv_of_is_contr_left - - definition pi_bool_left [constructor] (B : bool → Type) : (Πx, B x) ≃ B ff × B tt := - begin - fapply equiv.MK, - { intro f, exact (f ff, f tt)}, - { intro x b, induction x, induction b: assumption}, - { intro x, induction x, reflexivity}, - { intro f, apply eq_of_homotopy, intro b, induction b: reflexivity}, - end - - /- Truncatedness: any dependent product of n-types is an n-type -/ - - theorem is_trunc_pi (B : A → Type) (n : trunc_index) - [H : ∀a, is_trunc n (B a)] : is_trunc n (Πa, B a) := - begin - revert B H, - eapply (trunc_index.rec_on n), - {intro B H, - fapply is_contr.mk, - intro a, apply center, - intro f, apply eq_of_homotopy, - intro x, apply (center_eq (f x))}, - {intro n IH B H, - fapply is_trunc_succ_intro, intro f g, - fapply is_trunc_equiv_closed, - apply equiv.symm, apply eq_equiv_homotopy, - apply IH, - intro a, - show is_trunc n (f a = g a), from - is_trunc_eq n (f a) (g a)} - end - local attribute is_trunc_pi [instance] - theorem is_trunc_pi_eq [instance] [priority 500] (n : trunc_index) (f g : Πa, B a) - [H : ∀a, is_trunc n (f a = g a)] : is_trunc n (f = g) := - begin - apply is_trunc_equiv_closed_rev, - apply eq_equiv_homotopy - end - - theorem is_trunc_not [instance] (n : trunc_index) (A : Type) : is_trunc (n.+1) ¬A := - by unfold not;exact _ - - theorem is_prop_pi_eq [instance] [priority 490] (a : A) : is_prop (Π(a' : A), a = a') := - is_prop_of_imp_is_contr - ( assume (f : Πa', a = a'), - have is_contr A, from is_contr.mk a f, - by exact _) /- force type clas resolution -/ - - theorem is_prop_neg (A : Type) : is_prop (¬A) := _ - local attribute ne [reducible] - theorem is_prop_ne [instance] {A : Type} (a b : A) : is_prop (a ≠ b) := _ - - /- Symmetry of Π -/ - definition is_equiv_flip [instance] {P : A → A' → Type} - : is_equiv (@function.flip A A' P) := - begin - fapply is_equiv.mk, - exact (@function.flip _ _ (function.flip P)), - repeat (intro f; apply idp) - end - - definition pi_comm_equiv {P : A → A' → Type} : (Πa b, P a b) ≃ (Πb a, P a b) := - equiv.mk (@function.flip _ _ P) _ - -end pi - -attribute pi.is_trunc_pi [instance] [priority 1520] diff --git a/hott/types/pointed.hlean b/hott/types/pointed.hlean deleted file mode 100644 index 178fd7dd4f..0000000000 --- a/hott/types/pointed.hlean +++ /dev/null @@ -1,549 +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 arity .eq .bool .unit .sigma .nat.basic prop_trunc -open is_trunc eq prod sigma nat equiv option is_equiv bool unit algebra sigma.ops - -structure pointed [class] (A : Type) := - (point : A) - -structure pType := - (carrier : Type) - (Point : carrier) - -notation `Type*` := pType - -section - universe variable u - structure ptrunctype (n : trunc_index) extends trunctype.{u} n, pType.{u} -end - -notation n `-Type*` := ptrunctype n -abbreviation pSet [parsing_only] := 0-Type* -notation `Set*` := pSet - -namespace pointed - attribute pType.carrier [coercion] - variables {A B : Type} - - definition pt [unfold 2] [H : pointed A] := point A - definition Point [unfold 1] (A : Type*) := pType.Point A - abbreviation carrier [unfold 1] (A : Type*) := pType.carrier A - protected definition Mk [constructor] {A : Type} (a : A) := pType.mk A a - protected definition MK [constructor] (A : Type) (a : A) := pType.mk A a - protected definition mk' [constructor] (A : Type) [H : pointed A] : Type* := - pType.mk A (point A) - definition pointed_carrier [instance] [constructor] (A : Type*) : pointed A := - pointed.mk (Point A) - - -- Any contractible type is pointed - definition pointed_of_is_contr [instance] [priority 800] [constructor] - (A : Type) [H : is_contr A] : pointed A := - pointed.mk !center - - -- A pi type with a pointed target is pointed - definition pointed_pi [instance] [constructor] (P : A → Type) [H : Πx, pointed (P x)] - : pointed (Πx, P x) := - pointed.mk (λx, pt) - - -- A sigma type of pointed components is pointed - definition pointed_sigma [instance] [constructor] (P : A → Type) [G : pointed A] - [H : pointed (P pt)] : pointed (Σx, P x) := - pointed.mk ⟨pt,pt⟩ - - definition pointed_prod [instance] [constructor] (A B : Type) [H1 : pointed A] [H2 : pointed B] - : pointed (A × B) := - pointed.mk (pt,pt) - - definition pointed_loop [instance] [constructor] (a : A) : pointed (a = a) := - pointed.mk idp - - definition pointed_bool [instance] [constructor] : pointed bool := - pointed.mk ff - - definition pprod [constructor] (A B : Type*) : Type* := - pointed.mk' (A × B) - - infixr ` ×* `:35 := pprod - - definition pointed_fun_closed [constructor] (f : A → B) [H : pointed A] : pointed B := - pointed.mk (f pt) - - definition ploop_space [reducible] [constructor] (A : Type*) : Type* := - pointed.mk' (point A = point A) - - definition iterated_ploop_space [reducible] : ℕ → Type* → Type* - | iterated_ploop_space 0 X := X - | iterated_ploop_space (n+1) X := ploop_space (iterated_ploop_space n X) - - prefix `Ω`:(max+5) := ploop_space - notation `Ω[`:95 n:0 `] `:0 A:95 := iterated_ploop_space n A - - definition iterated_ploop_space_zero [unfold_full] (A : Type*) - : Ω[0] A = A := rfl - - definition iterated_ploop_space_succ [unfold_full] (k : ℕ) (A : Type*) - : Ω[succ k] A = Ω Ω[k] A := rfl - - definition rfln [constructor] [reducible] {A : Type*} {n : ℕ} : Ω[n] A := pt - definition refln [constructor] [reducible] (A : Type*) (n : ℕ) : Ω[n] A := pt - definition refln_eq_refl (A : Type*) (n : ℕ) : rfln = rfl :> Ω[succ n] A := rfl - - definition iterated_loop_space [unfold 3] (A : Type) [H : pointed A] (n : ℕ) : Type := - Ω[n] (pointed.mk' A) - - definition pType_eq {A B : Type*} (f : A ≃ B) (p : f pt = pt) : A = B := - begin - cases A with A a, cases B with B b, esimp at *, - fapply apd011 @pType.mk, - { apply ua f}, - { rewrite [cast_ua,p]}, - end - - definition pType_eq_elim {A B : Type*} (p : A = B :> Type*) - : Σ(p : carrier A = carrier B :> Type), cast p pt = pt := - by induction p; exact ⟨idp, idp⟩ - - protected definition pType.sigma_char.{u} : pType.{u} ≃ Σ(X : Type.{u}), X := - begin - fapply equiv.MK, - { intro x, induction x with X x, exact ⟨X, x⟩}, - { intro x, induction x with X x, exact pointed.MK X x}, - { intro x, induction x with X x, reflexivity}, - { intro x, induction x with X x, reflexivity}, - end - - definition add_point [constructor] (A : Type) : Type* := - pointed.Mk (none : option A) - postfix `₊`:(max+1) := add_point - -- the inclusion A → A₊ is called "some", the extra point "pt" or "none" ("@none A") - -end pointed open pointed - -protected definition ptrunctype.mk' [constructor] (n : trunc_index) - (A : Type) [pointed A] [is_trunc n A] : n-Type* := -ptrunctype.mk A _ pt - -protected definition pSet.mk [constructor] := @ptrunctype.mk (-1.+1) -protected definition pSet.mk' [constructor] := ptrunctype.mk' (-1.+1) - -definition ptrunctype_of_trunctype [constructor] {n : trunc_index} (A : n-Type) (a : A) : n-Type* := -ptrunctype.mk A _ a - -definition ptrunctype_of_pType [constructor] {n : trunc_index} (A : Type*) (H : is_trunc n A) - : n-Type* := -ptrunctype.mk A _ pt - -definition pSet_of_Set [constructor] (A : Set) (a : A) : Set* := -ptrunctype.mk A _ a - -definition pSet_of_pType [constructor] (A : Type*) (H : is_set A) : Set* := -ptrunctype.mk A _ pt - -attribute pType._trans_to_carrier ptrunctype.to_pType ptrunctype.to_trunctype [unfold 2] - -definition ptrunctype_eq {n : trunc_index} {A B : n-Type*} (p : A = B :> Type) (q : cast p pt = pt) - : A = B := -begin - induction A with A HA a, induction B with B HB b, esimp at *, - induction p, induction q, - esimp, - refine ap010 (ptrunctype.mk A) _ a, - exact !is_prop.elim -end - -definition ptrunctype_eq_of_pType_eq {n : trunc_index} {A B : n-Type*} (p : A = B :> Type*) - : A = B := -begin - cases pType_eq_elim p with q r, - exact ptrunctype_eq q r -end - - -namespace pointed - - definition pbool [constructor] : Set* := - pSet.mk' bool - - definition punit [constructor] : Set* := - pSet.mk' unit - - /- properties of iterated loop space -/ - variable (A : Type*) - definition loop_space_succ_eq_in (n : ℕ) : Ω[succ n] A = Ω[n] (Ω A) := - begin - induction n with n IH, - { reflexivity}, - { exact ap ploop_space IH} - end - - definition loop_space_add (n m : ℕ) : Ω[n] (Ω[m] A) = Ω[m+n] (A) := - begin - induction n with n IH, - { reflexivity}, - { exact ap ploop_space IH} - end - - definition loop_space_succ_eq_out (n : ℕ) : Ω[succ n] A = Ω(Ω[n] A) := - idp - - variable {A} - - /- the equality [loop_space_succ_eq_in] preserves concatenation -/ - theorem loop_space_succ_eq_in_concat {n : ℕ} (p q : Ω[succ (succ n)] A) : - transport carrier (ap ploop_space (loop_space_succ_eq_in A n)) (p ⬝ q) - = transport carrier (ap ploop_space (loop_space_succ_eq_in A n)) p - ⬝ transport carrier (ap ploop_space (loop_space_succ_eq_in A n)) q := - begin - rewrite [-+tr_compose, ↑function.compose], - rewrite [+@transport_eq_FlFr_D _ _ _ _ Point Point, +con.assoc], apply whisker_left, - rewrite [-+con.assoc], apply whisker_right, rewrite [con_inv_cancel_right, ▸*, -ap_con] - end - - definition loop_space_loop_irrel (p : point A = point A) : Ω(pointed.Mk p) = Ω[2] A := - begin - intros, fapply pType_eq, - { esimp, transitivity _, - apply eq_equiv_fn_eq_of_equiv (equiv_eq_closed_right _ p⁻¹), - esimp, apply eq_equiv_eq_closed, apply con.right_inv, apply con.right_inv}, - { esimp, apply con.left_inv} - end - - definition iterated_loop_space_loop_irrel (n : ℕ) (p : point A = point A) - : Ω[succ n](pointed.Mk p) = Ω[succ (succ n)] A :> pType := - calc - Ω[succ n](pointed.Mk p) = Ω[n](Ω (pointed.Mk p)) : loop_space_succ_eq_in - ... = Ω[n] (Ω[2] A) : loop_space_loop_irrel - ... = Ω[2+n] A : loop_space_add - ... = Ω[n+2] A : by rewrite [algebra.add.comm] - -end pointed open pointed - -/- pointed maps -/ -structure pmap (A B : Type*) := - (to_fun : A → B) - (resp_pt : to_fun (Point A) = Point B) - -namespace pointed - abbreviation respect_pt [unfold 3] := @pmap.resp_pt - notation `map₊` := pmap - infix ` →* `:30 := pmap - attribute pmap.to_fun [coercion] -end pointed open pointed - -/- pointed homotopies -/ -structure phomotopy {A B : Type*} (f g : A →* B) := - (homotopy : f ~ g) - (homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f) - -namespace pointed - variables {A B C D : Type*} {f g h : A →* B} - - infix ` ~* `:50 := phomotopy - abbreviation to_homotopy_pt [unfold 5] := @phomotopy.homotopy_pt - abbreviation to_homotopy [coercion] [unfold 5] (p : f ~* g) : Πa, f a = g a := - phomotopy.homotopy p - - /- categorical properties of pointed maps -/ - - definition pid [constructor] [refl] (A : Type*) : A →* A := - pmap.mk id idp - - definition pcompose [constructor] [trans] (g : B →* C) (f : A →* B) : A →* C := - pmap.mk (λa, g (f a)) (ap g (respect_pt f) ⬝ respect_pt g) - - infixr ` ∘* `:60 := pcompose - - definition passoc (h : C →* D) (g : B →* C) (f : A →* B) : (h ∘* g) ∘* f ~* h ∘* (g ∘* f) := - begin - fconstructor, intro a, reflexivity, - cases A, cases B, cases C, cases D, cases f with f pf, cases g with g pg, cases h with h ph, - esimp at *, - induction pf, induction pg, induction ph, reflexivity - end - - definition pid_comp (f : A →* B) : pid B ∘* f ~* f := - begin - fconstructor, - { intro a, reflexivity}, - { reflexivity} - end - - definition comp_pid (f : A →* B) : f ∘* pid A ~* f := - begin - fconstructor, - { intro a, reflexivity}, - { reflexivity} - end - - /- equivalences and equalities -/ - - definition pmap_eq (r : Πa, f a = g a) (s : respect_pt f = (r pt) ⬝ respect_pt g) : f = g := - begin - cases f with f p, cases g with g q, - esimp at *, - fapply apo011 pmap.mk, - { exact eq_of_homotopy r}, - { apply concato_eq, apply pathover_eq_Fl, apply inv_con_eq_of_eq_con, - rewrite [ap_eq_ap10,↑ap10,apd10_eq_of_homotopy,s]} - end - - definition pmap_equiv_left (A : Type) (B : Type*) : A₊ →* B ≃ (A → B) := - begin - fapply equiv.MK, - { intro f a, cases f with f p, exact f (some a)}, - { intro f, fconstructor, - intro a, cases a, exact pt, exact f a, - reflexivity}, - { intro f, reflexivity}, - { intro f, cases f with f p, esimp, fapply pmap_eq, - { intro a, cases a; all_goals (esimp at *), exact p⁻¹}, - { esimp, exact !con.left_inv⁻¹}}, - end - - definition pmap_equiv_right (A : Type*) (B : Type) - : (Σ(b : B), A →* (pointed.Mk b)) ≃ (A → B) := - begin - fapply equiv.MK, - { intro u a, exact pmap.to_fun u.2 a}, - { intro f, refine ⟨f pt, _⟩, fapply pmap.mk, - intro a, esimp, exact f a, - reflexivity}, - { intro f, reflexivity}, - { intro u, cases u with b f, cases f with f p, esimp at *, induction p, - reflexivity} - end - - definition pmap_bool_equiv (B : Type*) : (pbool →* B) ≃ B := - begin - fapply equiv.MK, - { intro f, cases f with f p, exact f tt}, - { intro b, fconstructor, - intro u, cases u, exact pt, exact b, - reflexivity}, - { intro b, reflexivity}, - { intro f, cases f with f p, esimp, fapply pmap_eq, - { intro a, cases a; all_goals (esimp at *), exact p⁻¹}, - { esimp, exact !con.left_inv⁻¹}}, - end - - -- The constant pointed map between any two types - definition pconst [constructor] (A B : Type*) : A →* B := - pmap.mk (λ a, Point B) idp - - -- the pointed type of pointed maps - definition ppmap [constructor] (A B : Type*) : Type* := - pType.mk (A →* B) (pconst A B) - - /- instances of pointed maps -/ - - definition ap1 [constructor] (f : A →* B) : Ω A →* Ω B := - begin - fconstructor, - { intro p, exact !respect_pt⁻¹ ⬝ ap f p ⬝ !respect_pt}, - { esimp, apply con.left_inv} - end - - definition apn (n : ℕ) (f : map₊ A B) : Ω[n] A →* Ω[n] B := - begin - induction n with n IH, - { exact f}, - { esimp [iterated_ploop_space], exact ap1 IH} - end - - prefix `Ω→`:(max+5) := ap1 - notation `Ω→[`:95 n:0 `] `:0 f:95 := apn n f - - definition apn_zero (f : map₊ A B) : Ω→[0] f = f := idp - definition apn_succ (n : ℕ) (f : map₊ A B) : Ω→[n + 1] f = ap1 (Ω→[n] f) := idp - - definition pcast [constructor] {A B : Type*} (p : A = B) : A →* B := - proof pmap.mk (cast (ap pType.carrier p)) (by induction p; reflexivity) qed - - definition pinverse [constructor] {X : Type*} : Ω X →* Ω X := - pmap.mk eq.inverse idp - - /- categorical properties of pointed homotopies -/ - - protected definition phomotopy.refl [constructor] [refl] (f : A →* B) : f ~* f := - begin - fconstructor, - { intro a, exact idp}, - { apply idp_con} - end - - protected definition phomotopy.rfl [constructor] {A B : Type*} {f : A →* B} : f ~* f := - phomotopy.refl f - - protected definition phomotopy.trans [constructor] [trans] (p : f ~* g) (q : g ~* h) - : f ~* h := - phomotopy.mk (λa, p a ⬝ q a) - abstract begin - induction f, induction g, induction p with p p', induction q with q q', esimp at *, - induction p', induction q', esimp, apply con.assoc - end end - - protected definition phomotopy.symm [constructor] [symm] (p : f ~* g) : g ~* f := - phomotopy.mk (λa, (p a)⁻¹) - abstract begin - induction f, induction p with p p', esimp at *, - induction p', esimp, apply inv_con_cancel_left - end end - - infix ` ⬝* `:75 := phomotopy.trans - postfix `⁻¹*`:(max+1) := phomotopy.symm - - /- properties about the given pointed maps -/ - - definition is_equiv_ap1 {A B : Type*} (f : A →* B) [is_equiv f] : is_equiv (ap1 f) := - begin - induction B with B b, induction f with f pf, esimp at *, cases pf, esimp, - apply is_equiv.homotopy_closed (ap f), - intro p, exact !idp_con⁻¹ - end - - definition is_equiv_apn {A B : Type*} (n : ℕ) (f : A →* B) [H : is_equiv f] - : is_equiv (apn n f) := - begin - induction n with n IH, - { exact H}, - { exact is_equiv_ap1 (apn n f)} - end - - definition ap1_id [constructor] {A : Type*} : ap1 (pid A) ~* pid (Ω A) := - begin - fapply phomotopy.mk, - { intro p, esimp, refine !idp_con ⬝ !ap_id}, - { reflexivity} - end - - definition ap1_pinverse {A : Type*} : ap1 (@pinverse A) ~* @pinverse (Ω A) := - begin - fapply phomotopy.mk, - { intro p, esimp, refine !idp_con ⬝ _, exact !inverse_eq_inverse2⁻¹ }, - { reflexivity} - end - - definition ap1_compose (g : B →* C) (f : A →* B) : ap1 (g ∘* f) ~* ap1 g ∘* ap1 f := - begin - induction B, induction C, induction g with g pg, induction f with f pf, esimp at *, - induction pg, induction pf, - fconstructor, - { intro p, esimp, apply whisker_left, exact ap_compose g f p ⬝ ap (ap g) !idp_con⁻¹}, - { reflexivity} - end - - definition ap1_compose_pinverse (f : A →* B) : ap1 f ∘* pinverse ~* pinverse ∘* ap1 f := - begin - fconstructor, - { intro p, esimp, refine !con.assoc ⬝ _ ⬝ !con_inv⁻¹, apply whisker_left, - refine whisker_right !ap_inv _ ⬝ _ ⬝ !con_inv⁻¹, apply whisker_left, - exact !inv_inv⁻¹}, - { induction B with B b, induction f with f pf, esimp at *, induction pf, reflexivity}, - end - - theorem ap1_con (f : A →* B) (p q : Ω A) : ap1 f (p ⬝ q) = ap1 f p ⬝ ap1 f q := - begin - rewrite [▸*,ap_con, +con.assoc, con_inv_cancel_left], repeat apply whisker_left - end - - theorem ap1_inv (f : A →* B) (p : Ω A) : ap1 f p⁻¹ = (ap1 f p)⁻¹ := - begin - rewrite [▸*,ap_inv, +con_inv, inv_inv, +con.assoc], repeat apply whisker_left - end - - definition pcast_ap_loop_space {A B : Type*} (p : A = B) - : pcast (ap ploop_space p) ~* Ω→ (pcast p) := - begin - induction p, exact !ap1_id⁻¹* - end - - definition pinverse_con [constructor] {X : Type*} (p q : Ω X) - : pinverse (p ⬝ q) = pinverse q ⬝ pinverse p := - !con_inv - - definition pinverse_inv [constructor] {X : Type*} (p : Ω X) - : pinverse p⁻¹ = (pinverse p)⁻¹ := - idp - - /- more on pointed homotopies -/ - - definition phomotopy_of_eq [constructor] {A B : Type*} {f g : A →* B} (p : f = g) : f ~* g := - phomotopy.mk (ap010 pmap.to_fun p) begin induction p, apply idp_con end - - definition pconcat_eq [constructor] {A B : Type*} {f g h : A →* B} (p : f ~* g) (q : g = h) - : f ~* h := - p ⬝* phomotopy_of_eq q - - definition eq_pconcat [constructor] {A B : Type*} {f g h : A →* B} (p : f = g) (q : g ~* h) - : f ~* h := - phomotopy_of_eq p ⬝* q - - definition pwhisker_left [constructor] (h : B →* C) (p : f ~* g) : h ∘* f ~* h ∘* g := - phomotopy.mk (λa, ap h (p a)) - abstract begin - induction A, induction B, induction C, - induction f with f pf, induction g with g pg, induction h with h ph, - induction p with p p', esimp at *, induction ph, induction pg, induction p', reflexivity - end end - - definition pwhisker_right [constructor] (h : C →* A) (p : f ~* g) : f ∘* h ~* g ∘* h := - phomotopy.mk (λa, p (h a)) - abstract begin - induction A, induction B, induction C, - induction f with f pf, induction g with g pg, induction h with h ph, - induction p with p p', esimp at *, induction ph, induction pg, induction p', esimp, - exact !idp_con⁻¹ - end end - - definition pconcat2 [constructor] {A B C : Type*} {h i : B →* C} {f g : A →* B} - (q : h ~* i) (p : f ~* g) : h ∘* f ~* i ∘* g := - pwhisker_left _ p ⬝* pwhisker_right _ q - - definition eq_of_phomotopy (p : f ~* g) : f = g := - begin - fapply pmap_eq, - { intro a, exact p a}, - { exact !to_homotopy_pt⁻¹} - end - - definition pap {A B C D : Type*} (F : (A →* B) → (C →* D)) - {f g : A →* B} (p : f ~* g) : F f ~* F g := - phomotopy.mk (ap010 F (eq_of_phomotopy p)) begin cases eq_of_phomotopy p, apply idp_con end - - -- TODO: give proof without using function extensionality (commented out part is a start) - definition ap1_phomotopy {A B : Type*} {f g : A →* B} (p : f ~* g) - : ap1 f ~* ap1 g := - pap ap1 p - /- begin - induction p with p q, induction f with f pf, induction g with g pg, induction B with B b, - esimp at *, induction q, induction pg, - fapply phomotopy.mk, - { intro l, esimp, refine _ ⬝ !idp_con⁻¹, refine !con.assoc ⬝ _, apply inv_con_eq_of_eq_con, - apply ap_con_eq_con_ap}, - { esimp, } - end -/ - - definition apn_compose (n : ℕ) (g : B →* C) (f : A →* B) : apn n (g ∘* f) ~* apn n g ∘* apn n f := - begin - induction n with n IH, - { reflexivity}, - { refine ap1_phomotopy IH ⬝* _, apply ap1_compose} - end - - theorem apn_con (n : ℕ) (f : A →* B) (p q : Ω[n+1] A) - : apn (n+1) f (p ⬝ q) = apn (n+1) f p ⬝ apn (n+1) f q := - by rewrite [+apn_succ, ap1_con] - - theorem apn_inv (n : ℕ) (f : A →* B) (p : Ω[n+1] A) : apn (n+1) f p⁻¹ = (apn (n+1) f p)⁻¹ := - by rewrite [+apn_succ, ap1_inv] - - infix ` ⬝*p `:75 := pconcat_eq - infix ` ⬝p* `:75 := eq_pconcat - -end pointed diff --git a/hott/types/pointed2.hlean b/hott/types/pointed2.hlean deleted file mode 100644 index aee4af7597..0000000000 --- a/hott/types/pointed2.hlean +++ /dev/null @@ -1,243 +0,0 @@ -/- -Copyright (c) 2014 Jakob von Raumer. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Floris van Doorn - -Ported from Coq HoTT --/ - - -import .equiv cubical.square - -open eq is_equiv equiv pointed is_trunc - --- structure pequiv (A B : Type*) := --- (to_pmap : A →* B) --- (is_equiv_to_pmap : is_equiv to_pmap) - -structure pequiv (A B : Type*) extends equiv A B, pmap A B - -namespace pointed - - attribute pequiv._trans_of_to_pmap pequiv._trans_of_to_equiv pequiv.to_pmap pequiv.to_equiv - [unfold 3] - - variables {A B C : Type*} - - /- pointed equivalences -/ - - infix ` ≃* `:25 := pequiv - attribute pequiv.to_pmap [coercion] - attribute pequiv.to_is_equiv [instance] - - definition pequiv_of_pmap [constructor] (f : A →* B) (H : is_equiv f) : A ≃* B := - pequiv.mk f _ (respect_pt f) - - definition pequiv_of_equiv [constructor] (f : A ≃ B) (H : f pt = pt) : A ≃* B := - pequiv.mk f _ H - - protected definition pequiv.MK [constructor] (f : A →* B) (g : B →* A) - (gf : Πa, g (f a) = a) (fg : Πb, f (g b) = b) : A ≃* B := - pequiv.mk f (adjointify f g fg gf) (respect_pt f) - - definition equiv_of_pequiv [constructor] (f : A ≃* B) : A ≃ B := - equiv.mk f _ - - definition to_pinv [constructor] (f : A ≃* B) : B →* A := - pmap.mk f⁻¹ ((ap f⁻¹ (respect_pt f))⁻¹ ⬝ !left_inv) - - definition pua {A B : Type*} (f : A ≃* B) : A = B := - pType_eq (equiv_of_pequiv f) !respect_pt - - protected definition pequiv.refl [refl] [constructor] (A : Type*) : A ≃* A := - pequiv_of_pmap !pid !is_equiv_id - - protected definition pequiv.rfl [constructor] : A ≃* A := - pequiv.refl A - - protected definition pequiv.symm [symm] (f : A ≃* B) : B ≃* A := - pequiv_of_pmap (to_pinv f) !is_equiv_inv - - protected definition pequiv.trans [trans] (f : A ≃* B) (g : B ≃* C) : A ≃* C := - pequiv_of_pmap (pcompose g f) !is_equiv_compose - - postfix `⁻¹ᵉ*`:(max + 1) := pequiv.symm - infix ` ⬝e* `:75 := pequiv.trans - - definition pequiv_rect' (f : A ≃* B) (P : A → B → Type) - (g : Πb, P (f⁻¹ b) b) (a : A) : P a (f a) := - left_inv f a ▸ g (f a) - - definition pequiv_of_eq [constructor] {A B : Type*} (p : A = B) : A ≃* B := - pequiv_of_pmap (pcast p) !is_equiv_tr - - definition peconcat_eq {A B C : Type*} (p : A ≃* B) (q : B = C) : A ≃* C := - p ⬝e* pequiv_of_eq q - - definition eq_peconcat {A B C : Type*} (p : A = B) (q : B ≃* C) : A ≃* C := - pequiv_of_eq p ⬝e* q - - definition eq_of_pequiv {A B : Type*} (p : A ≃* B) : A = B := - pType_eq (equiv_of_pequiv p) !respect_pt - - definition peap {A B : Type*} (F : Type* → Type*) (p : A ≃* B) : F A ≃* F B := - pequiv_of_pmap (pcast (ap F (eq_of_pequiv p))) begin cases eq_of_pequiv p, apply is_equiv_id end - - definition loop_space_pequiv [constructor] (p : A ≃* B) : Ω A ≃* Ω B := - pequiv_of_pmap (ap1 p) (is_equiv_ap1 p) - - definition iterated_loop_space_pequiv [constructor] (n : ℕ) (p : A ≃* B) : Ω[n] A ≃* Ω[n] B := - pequiv_of_pmap (apn n p) (is_equiv_apn n p) - - definition pequiv_eq {p q : A ≃* B} (H : p = q :> (A →* B)) : p = q := - begin - cases p with f Hf, cases q with g Hg, esimp at *, - exact apd011 pequiv_of_pmap H !is_prop.elim - end - - definition loop_space_pequiv_rfl - : loop_space_pequiv (@pequiv.refl A) = @pequiv.refl (Ω A) := - begin - apply pequiv_eq, fapply pmap_eq: esimp, - { intro p, exact !idp_con ⬝ !ap_id}, - { reflexivity} - end - - infix ` ⬝e*p `:75 := peconcat_eq - infix ` ⬝pe* `:75 := eq_peconcat - - local attribute pequiv.symm [constructor] - definition pleft_inv (f : A ≃* B) : f⁻¹ᵉ* ∘* f ~* pid A := - phomotopy.mk (left_inv f) - abstract begin - esimp, symmetry, apply con_inv_cancel_left - end end - - definition pright_inv (f : A ≃* B) : f ∘* f⁻¹ᵉ* ~* pid B := - phomotopy.mk (right_inv f) - abstract begin - induction f with f H p, esimp, - rewrite [ap_con, +ap_inv, -adj f, -ap_compose], - note q := natural_square (right_inv f) p, - rewrite [ap_id at q], - apply eq_bot_of_square, - exact transpose q - end end - - definition pcancel_left (f : B ≃* C) {g h : A →* B} (p : f ∘* g ~* f ∘* h) : g ~* h := - begin - refine _⁻¹* ⬝* pwhisker_left f⁻¹ᵉ* p ⬝* _: - refine !passoc⁻¹* ⬝* _: - refine pwhisker_right _ (pleft_inv f) ⬝* _: - apply pid_comp - end - - - definition pcancel_right (f : A ≃* B) {g h : B →* C} (p : g ∘* f ~* h ∘* f) : g ~* h := - begin - refine _⁻¹* ⬝* pwhisker_right f⁻¹ᵉ* p ⬝* _: - refine !passoc ⬝* _: - refine pwhisker_left _ (pright_inv f) ⬝* _: - apply comp_pid - end - - definition phomotopy_pinv_right_of_phomotopy {f : A ≃* B} {g : B →* C} {h : A →* C} - (p : g ∘* f ~* h) : g ~* h ∘* f⁻¹ᵉ* := - begin - refine _ ⬝* pwhisker_right _ p, symmetry, - refine !passoc ⬝* _, - refine pwhisker_left _ (pright_inv f) ⬝* _, - apply comp_pid - end - - definition phomotopy_of_pinv_right_phomotopy {f : B ≃* A} {g : B →* C} {h : A →* C} - (p : g ∘* f⁻¹ᵉ* ~* h) : g ~* h ∘* f := - begin - refine _ ⬝* pwhisker_right _ p, symmetry, - refine !passoc ⬝* _, - refine pwhisker_left _ (pleft_inv f) ⬝* _, - apply comp_pid - end - - definition pinv_right_phomotopy_of_phomotopy {f : A ≃* B} {g : B →* C} {h : A →* C} - (p : h ~* g ∘* f) : h ∘* f⁻¹ᵉ* ~* g := - (phomotopy_pinv_right_of_phomotopy p⁻¹*)⁻¹* - - definition phomotopy_of_phomotopy_pinv_right {f : B ≃* A} {g : B →* C} {h : A →* C} - (p : h ~* g ∘* f⁻¹ᵉ*) : h ∘* f ~* g := - (phomotopy_of_pinv_right_phomotopy p⁻¹*)⁻¹* - - definition phomotopy_pinv_left_of_phomotopy {f : B ≃* C} {g : A →* B} {h : A →* C} - (p : f ∘* g ~* h) : g ~* f⁻¹ᵉ* ∘* h := - begin - refine _ ⬝* pwhisker_left _ p, symmetry, - refine !passoc⁻¹* ⬝* _, - refine pwhisker_right _ (pleft_inv f) ⬝* _, - apply pid_comp - end - - definition phomotopy_of_pinv_left_phomotopy {f : C ≃* B} {g : A →* B} {h : A →* C} - (p : f⁻¹ᵉ* ∘* g ~* h) : g ~* f ∘* h := - begin - refine _ ⬝* pwhisker_left _ p, symmetry, - refine !passoc⁻¹* ⬝* _, - refine pwhisker_right _ (pright_inv f) ⬝* _, - apply pid_comp - end - - definition pinv_left_phomotopy_of_phomotopy {f : B ≃* C} {g : A →* B} {h : A →* C} - (p : h ~* f ∘* g) : f⁻¹ᵉ* ∘* h ~* g := - (phomotopy_pinv_left_of_phomotopy p⁻¹*)⁻¹* - - definition phomotopy_of_phomotopy_pinv_left {f : C ≃* B} {g : A →* B} {h : A →* C} - (p : h ~* f⁻¹ᵉ* ∘* g) : f ∘* h ~* g := - (phomotopy_of_pinv_left_phomotopy p⁻¹*)⁻¹* - - /- pointed equivalences between particular pointed types -/ - - definition loop_pequiv_loop [constructor] (f : A ≃* B) : Ω A ≃* Ω B := - pequiv.MK (ap1 f) (ap1 f⁻¹ᵉ*) - abstract begin - intro p, - refine ((ap1_compose f⁻¹ᵉ* f) p)⁻¹ ⬝ _, - refine ap1_phomotopy (pleft_inv f) p ⬝ _, - exact ap1_id p - end end - abstract begin - intro p, - refine ((ap1_compose f f⁻¹ᵉ*) p)⁻¹ ⬝ _, - refine ap1_phomotopy (pright_inv f) p ⬝ _, - exact ap1_id p - end end - - definition loopn_pequiv_loopn (n : ℕ) (f : A ≃* B) : Ω[n] A ≃* Ω[n] B := - begin - induction n with n IH, - { exact f}, - { exact loop_pequiv_loop IH} - end - - definition pmap_functor [constructor] {A A' B B' : Type*} (f : A' →* A) (g : B →* B') : - ppmap A B →* ppmap A' B' := - pmap.mk (λh, g ∘* h ∘* f) - abstract begin - fapply pmap_eq, - { esimp, intro a, exact respect_pt g}, - { rewrite [▸*, ap_constant], apply idp_con} - end end - -/- - definition pmap_pequiv_pmap {A A' B B' : Type*} (f : A ≃* A') (g : B ≃* B') : - ppmap A B ≃* ppmap A' B' := - pequiv.MK (pmap_functor f⁻¹ᵉ* g) (pmap_functor f g⁻¹ᵉ*) - abstract begin - intro a, esimp, apply pmap_eq, - { esimp, }, - { } - end end - abstract begin - - end end --/ - -end pointed diff --git a/hott/types/prod.hlean b/hott/types/prod.hlean deleted file mode 100644 index c2db35d3e7..0000000000 --- a/hott/types/prod.hlean +++ /dev/null @@ -1,245 +0,0 @@ -/- -Copyright (c) 2014 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 - -Ported from Coq HoTT -Theorems about products --/ - -open eq equiv is_equiv is_trunc prod prod.ops unit - -variables {A A' B B' C D : Type} {P Q : A → Type} - {a a' a'' : A} {b b₁ b₂ b' b'' : B} {u v w : A × B} - -namespace prod - - /- Paths in a product space -/ - - protected definition eta [unfold 3] (u : A × B) : (pr₁ u, pr₂ u) = u := - by cases u; apply idp - - definition pair_eq [unfold 7 8] (pa : a = a') (pb : b = b') : (a, b) = (a', b') := - by cases pa; cases pb; apply idp - - definition prod_eq [unfold 3 4 5 6] (H₁ : u.1 = v.1) (H₂ : u.2 = v.2) : u = v := - by cases u; cases v; exact pair_eq H₁ H₂ - - definition eq_pr1 [unfold 5] (p : u = v) : u.1 = v.1 := - ap pr1 p - - definition eq_pr2 [unfold 5] (p : u = v) : u.2 = v.2 := - ap pr2 p - - namespace ops - postfix `..1`:(max+1) := eq_pr1 - postfix `..2`:(max+1) := eq_pr2 - end ops - open ops - - protected definition ap_pr1 (p : u = v) : ap pr1 p = p..1 := idp - protected definition ap_pr2 (p : u = v) : ap pr2 p = p..2 := idp - - definition pair_prod_eq (p : u.1 = v.1) (q : u.2 = v.2) - : ((prod_eq p q)..1, (prod_eq p q)..2) = (p, q) := - by induction u; induction v; esimp at *; induction p; induction q; reflexivity - - definition prod_eq_pr1 (p : u.1 = v.1) (q : u.2 = v.2) : (prod_eq p q)..1 = p := - (pair_prod_eq p q)..1 - - definition prod_eq_pr2 (p : u.1 = v.1) (q : u.2 = v.2) : (prod_eq p q)..2 = q := - (pair_prod_eq p q)..2 - - definition prod_eq_eta (p : u = v) : prod_eq (p..1) (p..2) = p := - by induction p; induction u; reflexivity - - -- the uncurried version of prod_eq. We will prove that this is an equivalence - definition prod_eq_unc (H : u.1 = v.1 × u.2 = v.2) : u = v := - by cases H with H₁ H₂;exact prod_eq H₁ H₂ - - definition pair_prod_eq_unc : Π(pq : u.1 = v.1 × u.2 = v.2), - ((prod_eq_unc pq)..1, (prod_eq_unc pq)..2) = pq - | pair_prod_eq_unc (pq₁, pq₂) := pair_prod_eq pq₁ pq₂ - - definition prod_eq_unc_pr1 (pq : u.1 = v.1 × u.2 = v.2) : (prod_eq_unc pq)..1 = pq.1 := - (pair_prod_eq_unc pq)..1 - - definition prod_eq_unc_pr2 (pq : u.1 = v.1 × u.2 = v.2) : (prod_eq_unc pq)..2 = pq.2 := - (pair_prod_eq_unc pq)..2 - - definition prod_eq_unc_eta (p : u = v) : prod_eq_unc (p..1, p..2) = p := - prod_eq_eta p - - definition is_equiv_prod_eq [instance] [constructor] (u v : A × B) - : is_equiv (prod_eq_unc : u.1 = v.1 × u.2 = v.2 → u = v) := - adjointify prod_eq_unc - (λp, (p..1, p..2)) - prod_eq_unc_eta - pair_prod_eq_unc - - definition prod_eq_equiv [constructor] (u v : A × B) : (u = v) ≃ (u.1 = v.1 × u.2 = v.2) := - (equiv.mk prod_eq_unc _)⁻¹ᵉ - - /- Groupoid structure -/ - definition prod_eq_inv (p : a = a') (q : b = b') : (prod_eq p q)⁻¹ = prod_eq p⁻¹ q⁻¹ := - by cases p; cases q; reflexivity - - definition prod_eq_concat (p : a = a') (p' : a' = a'') (q : b = b') (q' : b' = b'') - : prod_eq p q ⬝ prod_eq p' q' = prod_eq (p ⬝ p') (q ⬝ q') := - by cases p; cases q; cases p'; cases q'; reflexivity - - /- Transport -/ - - definition prod_transport (p : a = a') (u : P a × Q a) - : p ▸ u = (p ▸ u.1, p ▸ u.2) := - by induction p; induction u; reflexivity - - definition prod_eq_transport (p : a = a') (q : b = b') {R : A × B → Type} (r : R (a, b)) - : (prod_eq p q) ▸ r = p ▸ q ▸ r := - by induction p; induction q; reflexivity - - /- Pathovers -/ - - definition etao (p : a = a') (bc : P a × Q a) : bc =[p] (p ▸ bc.1, p ▸ bc.2) := - by induction p; induction bc; apply idpo - - definition prod_pathover (p : a = a') (u : P a × Q a) (v : P a' × Q a') - (r : u.1 =[p] v.1) (s : u.2 =[p] v.2) : u =[p] v := - begin - induction u, induction v, esimp at *, induction r, - induction s using idp_rec_on, - apply idpo - end - - /- - TODO: - * define the projections from the type u =[p] v - * show that the uncurried version of prod_pathover is an equivalence - -/ - - /- Functorial action -/ - - variables (f : A → A') (g : B → B') - definition prod_functor [unfold 7] (u : A × B) : A' × B' := - (f u.1, g u.2) - - definition ap_prod_functor (p : u.1 = v.1) (q : u.2 = v.2) - : ap (prod_functor f g) (prod_eq p q) = prod_eq (ap f p) (ap g q) := - by induction u; induction v; esimp at *; induction p; induction q; reflexivity - - /- Equivalences -/ - - definition is_equiv_prod_functor [instance] [constructor] [H : is_equiv f] [H : is_equiv g] - : is_equiv (prod_functor f g) := - begin - apply adjointify _ (prod_functor f⁻¹ g⁻¹), - intro u, induction u, rewrite [▸*,right_inv f,right_inv g], - intro u, induction u, rewrite [▸*,left_inv f,left_inv g], - end - - definition prod_equiv_prod_of_is_equiv [constructor] [H : is_equiv f] [H : is_equiv g] - : A × B ≃ A' × B' := - equiv.mk (prod_functor f g) _ - - definition prod_equiv_prod [constructor] (f : A ≃ A') (g : B ≃ B') : A × B ≃ A' × B' := - equiv.mk (prod_functor f g) _ - - definition prod_equiv_prod_left [constructor] (g : B ≃ B') : A × B ≃ A × B' := - prod_equiv_prod equiv.refl g - - definition prod_equiv_prod_right [constructor] (f : A ≃ A') : A × B ≃ A' × B := - prod_equiv_prod f equiv.refl - - /- Symmetry -/ - - definition is_equiv_flip [instance] [constructor] (A B : Type) - : is_equiv (flip : A × B → B × A) := - adjointify flip - flip - (λu, destruct u (λb a, idp)) - (λu, destruct u (λa b, idp)) - - definition prod_comm_equiv [constructor] (A B : Type) : A × B ≃ B × A := - equiv.mk flip _ - - /- Associativity -/ - - definition prod_assoc_equiv [constructor] (A B C : Type) : A × (B × C) ≃ (A × B) × C := - begin - fapply equiv.MK, - { intro z, induction z with a z, induction z with b c, exact (a, b, c)}, - { intro z, induction z with z c, induction z with a b, exact (a, (b, c))}, - { intro z, induction z with z c, induction z with a b, reflexivity}, - { intro z, induction z with a z, induction z with b c, reflexivity}, - end - - definition prod_contr_equiv [constructor] (A B : Type) [H : is_contr B] : A × B ≃ A := - equiv.MK pr1 - (λx, (x, !center)) - (λx, idp) - (λx, by cases x with a b; exact pair_eq idp !center_eq) - - definition prod_unit_equiv [constructor] (A : Type) : A × unit ≃ A := - !prod_contr_equiv - - definition prod_empty_equiv (A : Type) : A × empty ≃ empty := - begin - fapply equiv.MK, - { intro x, cases x with a e, cases e }, - { intro e, cases e }, - { intro e, cases e }, - { intro x, cases x with a e, cases e } - end - - /- Universal mapping properties -/ - definition is_equiv_prod_rec [instance] [constructor] (P : A × B → Type) - : is_equiv (prod.rec : (Πa b, P (a, b)) → Πu, P u) := - adjointify _ - (λg a b, g (a, b)) - (λg, eq_of_homotopy (λu, by induction u;reflexivity)) - (λf, idp) - - definition equiv_prod_rec [constructor] (P : A × B → Type) : (Πa b, P (a, b)) ≃ (Πu, P u) := - equiv.mk prod.rec _ - - definition imp_imp_equiv_prod_imp (A B C : Type) : (A → B → C) ≃ (A × B → C) := - !equiv_prod_rec - - definition prod_corec_unc [unfold 4] {P Q : A → Type} (u : (Πa, P a) × (Πa, Q a)) (a : A) - : P a × Q a := - (u.1 a, u.2 a) - - definition is_equiv_prod_corec [constructor] (P Q : A → Type) - : is_equiv (prod_corec_unc : (Πa, P a) × (Πa, Q a) → Πa, P a × Q a) := - adjointify _ - (λg, (λa, (g a).1, λa, (g a).2)) - (by intro g; apply eq_of_homotopy; intro a; esimp; induction (g a); reflexivity) - (by intro h; induction h with f g; reflexivity) - - definition equiv_prod_corec [constructor] (P Q : A → Type) - : ((Πa, P a) × (Πa, Q a)) ≃ (Πa, P a × Q a) := - equiv.mk _ !is_equiv_prod_corec - - definition imp_prod_imp_equiv_imp_prod [constructor] (A B C : Type) - : (A → B) × (A → C) ≃ (A → (B × C)) := - !equiv_prod_corec - - theorem is_trunc_prod (A B : Type) (n : trunc_index) [HA : is_trunc n A] [HB : is_trunc n B] - : is_trunc n (A × B) := - begin - revert A B HA HB, induction n with n IH, all_goals intro A B HA HB, - { fapply is_contr.mk, - exact (!center, !center), - intro u, apply prod_eq, all_goals apply center_eq}, - { apply is_trunc_succ_intro, intro u v, - apply is_trunc_equiv_closed_rev, apply prod_eq_equiv, - exact IH _ _ _ _} - end - -end prod - -attribute prod.is_trunc_prod [instance] [priority 1510] -definition tprod [constructor] {n : trunc_index} (A B : n-Type) : n-Type := -trunctype.mk (A × B) _ - -infixr `×t`:30 := tprod diff --git a/hott/types/pullback.hlean b/hott/types/pullback.hlean deleted file mode 100644 index f2ae1ca65b..0000000000 --- a/hott/types/pullback.hlean +++ /dev/null @@ -1,139 +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 pullbacks --/ - -import cubical.square -open eq equiv is_equiv function prod unit is_trunc sigma - -variables {A₀₀ A₂₀ A₄₀ A₀₂ A₂₂ A₄₂ : Type} - (f₁₀ : A₀₀ → A₂₀) (f₃₀ : A₂₀ → A₄₀) - (f₀₁ : A₀₀ → A₀₂) (f₂₁ : A₂₀ → A₂₂) (f₄₁ : A₄₀ → A₄₂) - (f₁₂ : A₀₂ → A₂₂) (f₃₂ : A₂₂ → A₄₂) - -structure pullback (f₂₁ : A₂₀ → A₂₂) (f₁₂ : A₀₂ → A₂₂) := - (pr1 : A₂₀) - (pr2 : A₀₂) - (pr1_pr2 : f₂₁ pr1 = f₁₂ pr2) - -namespace pullback - - protected definition sigma_char [constructor] : - pullback f₂₁ f₁₂ ≃ Σ(a₂₀ : A₂₀) (a₀₂ : A₀₂), f₂₁ a₂₀ = f₁₂ a₀₂ := - begin - fapply equiv.MK, - { intro x, induction x with a₂₀ a₀₂ p, exact ⟨a₂₀, a₀₂, p⟩}, - { intro x, induction x with a₂₀ y, induction y with a₀₂ p, exact pullback.mk a₂₀ a₀₂ p}, - { intro x, induction x with a₂₀ y, induction y with a₀₂ p, reflexivity}, - { intro x, induction x with a₂₀ a₀₂ p, reflexivity}, - end - - variables {f₁₀ f₃₀ f₀₁ f₂₁ f₄₁ f₁₂ f₃₂} - - definition pullback_corec [constructor] (p : Πa, f₂₁ (f₁₀ a) = f₁₂ (f₀₁ a)) (a : A₀₀) - : pullback f₂₁ f₁₂ := - pullback.mk (f₁₀ a) (f₀₁ a) (p a) - - definition pullback_eq {x y : pullback f₂₁ f₁₂} (p1 : pr1 x = pr1 y) (p2 : pr2 x = pr2 y) - (r : square (pr1_pr2 x) (pr1_pr2 y) (ap f₂₁ p1) (ap f₁₂ p2)) : x = y := - by induction y; induction x; esimp at *; induction p1; induction p2; - exact ap (pullback.mk _ _) (eq_of_vdeg_square r) - - definition pullback_comm_equiv [constructor] : pullback f₁₂ f₂₁ ≃ pullback f₂₁ f₁₂ := - begin - fapply equiv.MK, - { intro v, induction v with x y p, exact pullback.mk y x p⁻¹}, - { intro v, induction v with x y p, exact pullback.mk y x p⁻¹}, - { intro v, induction v, esimp, exact ap _ !inv_inv}, - { intro v, induction v, esimp, exact ap _ !inv_inv}, - end - - definition pullback_unit_equiv [constructor] - : pullback (λ(x : A₀₂), star) (λ(x : A₂₀), star) ≃ A₀₂ × A₂₀ := - begin - fapply equiv.MK, - { intro v, induction v with x y p, exact (x, y)}, - { intro v, induction v with x y, exact pullback.mk x y idp}, - { intro v, induction v, reflexivity}, - { intro v, induction v, esimp, apply ap _ !is_prop.elim}, - end - - definition pullback_along {f : A₂₀ → A₂₂} (g : A₀₂ → A₂₂) : pullback f g → A₂₀ := - pr1 - - postfix `^*`:(max+1) := pullback_along - - variables (f₁₀ f₃₀ f₀₁ f₂₁ f₄₁ f₁₂ f₃₂) - - structure pullback_square (f₁₀ : A₀₀ → A₂₀) (f₁₂ : A₀₂ → A₂₂) (f₀₁ : A₀₀ → A₀₂) (f₂₁ : A₂₀ → A₂₂) - : Type := - (comm : Πa, f₂₁ (f₁₀ a) = f₁₂ (f₀₁ a)) - (is_pullback : is_equiv (pullback_corec comm : A₀₀ → pullback f₂₁ f₁₂)) - - attribute pullback_square.is_pullback [instance] - definition pbs_comm [unfold 9] := @pullback_square.comm - - definition pullback_square_pullback - : pullback_square (pr1 : pullback f₂₁ f₁₂ → A₂₀) f₁₂ pr2 f₂₁ := - pullback_square.mk - pr1_pr2 - (adjointify _ (λf, f) - (λf, by induction f; reflexivity) - (λg, by induction g; reflexivity)) - - variables {f₁₀ f₃₀ f₀₁ f₂₁ f₄₁ f₁₂ f₃₂} - - definition pullback_square_equiv [constructor] (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - : A₀₀ ≃ pullback f₂₁ f₁₂ := - equiv.mk _ (pullback_square.is_pullback s) - - definition of_pullback [unfold 9] (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - (x : pullback f₂₁ f₁₂) : A₀₀ := - (pullback_square_equiv s)⁻¹ x - - definition right_of_pullback (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - (x : pullback f₂₁ f₁₂) : f₁₀ (of_pullback s x) = pr1 x := - ap pr1 (to_right_inv (pullback_square_equiv s) x) - - definition down_of_pullback (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - (x : pullback f₂₁ f₁₂) : f₀₁ (of_pullback s x) = pr2 x := - ap pr2 (to_right_inv (pullback_square_equiv s) x) - - -- definition pullback_square_compose_inverse (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - -- (t : pullback_square f₃₀ f₃₂ f₂₁ f₄₁) (x : pullback f₄₁ (f₃₂ ∘ f₁₂)) : A₀₀ := - -- let a₂₀' : pullback f₄₁ f₃₂ := - -- pullback.mk (pr1 x) (f₁₂ (pr2 x)) (pr1_pr2 x) in - -- let a₂₀ : A₂₀ := - -- of_pullback t a₂₀' in - -- have a₀₀' : pullback f₂₁ f₁₂, - -- from pullback.mk a₂₀ (pr2 x) !down_of_pullback, - -- show A₀₀, - -- from of_pullback s a₀₀' - -- local attribute pullback_square_compose_inverse [reducible] - - -- definition down_psci (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - -- (t : pullback_square f₃₀ f₃₂ f₂₁ f₄₁) (x : pullback f₄₁ (f₃₂ ∘ f₁₂)) : - -- f₀₁ (pullback_square_compose_inverse s t x) = pr2 x := - -- by apply down_of_pullback - - -- definition pullback_square_compose [constructor] (s : pullback_square f₁₀ f₁₂ f₀₁ f₂₁) - -- (t : pullback_square f₃₀ f₃₂ f₂₁ f₄₁) : pullback_square (f₃₀ ∘ f₁₀) (f₃₂ ∘ f₁₂) f₀₁ f₄₁ := - -- pullback_square.mk - -- (λa, pbs_comm t (f₁₀ a) ⬝ ap f₃₂ (pbs_comm s a)) - -- (adjointify _ - -- (pullback_square_compose_inverse s t) - -- begin - -- intro x, induction x with x y p, esimp, - -- fapply pullback_eq: esimp, - -- { exact ap f₃₀ !right_of_pullback ⬝ !right_of_pullback}, - -- { apply down_of_pullback}, - -- { esimp, exact sorry } - -- end - -- begin - -- intro x, esimp, exact sorry - -- end) - -end pullback diff --git a/hott/types/sigma.hlean b/hott/types/sigma.hlean deleted file mode 100644 index ead5e3ebbd..0000000000 --- a/hott/types/sigma.hlean +++ /dev/null @@ -1,479 +0,0 @@ -/- -Copyright (c) 2014-15 Floris van Doorn. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Floris van Doorn - -Partially ported from Coq HoTT -Theorems about sigma-types (dependent sums) --/ - -import types.prod - -open eq sigma sigma.ops equiv is_equiv function is_trunc sum unit - -namespace sigma - variables {A A' : Type} {B : A → Type} {B' : A' → Type} {C : Πa, B a → Type} - {D : Πa b, C a b → Type} - {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {u v w : Σa, B a} - - definition destruct := @sigma.cases_on - - /- Paths in a sigma-type -/ - - protected definition eta [unfold 3] : Π (u : Σa, B a), ⟨u.1 , u.2⟩ = u - | eta ⟨u₁, u₂⟩ := idp - - definition eta2 : Π (u : Σa b, C a b), ⟨u.1, u.2.1, u.2.2⟩ = u - | eta2 ⟨u₁, u₂, u₃⟩ := idp - - definition eta3 : Π (u : Σa b c, D a b c), ⟨u.1, u.2.1, u.2.2.1, u.2.2.2⟩ = u - | eta3 ⟨u₁, u₂, u₃, u₄⟩ := idp - - definition dpair_eq_dpair [unfold 8] (p : a = a') (q : b =[p] b') : ⟨a, b⟩ = ⟨a', b'⟩ := - apo011 sigma.mk p q - - definition sigma_eq [unfold 3 4] (p : u.1 = v.1) (q : u.2 =[p] v.2) : u = v := - by induction u; induction v; exact (dpair_eq_dpair p q) - - definition eq_pr1 [unfold 5] (p : u = v) : u.1 = v.1 := - ap pr1 p - - postfix `..1`:(max+1) := eq_pr1 - - definition eq_pr2 [unfold 5] (p : u = v) : u.2 =[p..1] v.2 := - by induction p; exact idpo - - postfix `..2`:(max+1) := eq_pr2 - - definition dpair_sigma_eq (p : u.1 = v.1) (q : u.2 =[p] v.2) - : ⟨(sigma_eq p q)..1, (sigma_eq p q)..2⟩ = ⟨p, q⟩ := - by induction u; induction v;esimp at *;induction q;esimp - - definition sigma_eq_pr1 (p : u.1 = v.1) (q : u.2 =[p] v.2) : (sigma_eq p q)..1 = p := - (dpair_sigma_eq p q)..1 - - definition sigma_eq_pr2 (p : u.1 = v.1) (q : u.2 =[p] v.2) - : (sigma_eq p q)..2 =[sigma_eq_pr1 p q] q := - (dpair_sigma_eq p q)..2 - - definition sigma_eq_eta (p : u = v) : sigma_eq (p..1) (p..2) = p := - by induction p; induction u; reflexivity - - definition eq2_pr1 {p q : u = v} (r : p = q) : p..1 = q..1 := - ap eq_pr1 r - - definition eq2_pr2 {p q : u = v} (r : p = q) : p..2 =[eq2_pr1 r] q..2 := - !pathover_ap (apdo eq_pr2 r) - - definition tr_pr1_sigma_eq {B' : A → Type} (p : u.1 = v.1) (q : u.2 =[p] v.2) - : transport (λx, B' x.1) (sigma_eq p q) = transport B' p := - by induction u; induction v; esimp at *;induction q; reflexivity - - protected definition ap_pr1 (p : u = v) : ap (λx : sigma B, x.1) p = p..1 := idp - - /- the uncurried version of sigma_eq. We will prove that this is an equivalence -/ - - definition sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2), u = v - | sigma_eq_unc ⟨pq₁, pq₂⟩ := sigma_eq pq₁ pq₂ - - definition dpair_sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2), - ⟨(sigma_eq_unc pq)..1, (sigma_eq_unc pq)..2⟩ = pq - | dpair_sigma_eq_unc ⟨pq₁, pq₂⟩ := dpair_sigma_eq pq₁ pq₂ - - definition sigma_eq_pr1_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2) - : (sigma_eq_unc pq)..1 = pq.1 := - (dpair_sigma_eq_unc pq)..1 - - definition sigma_eq_pr2_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2) : - (sigma_eq_unc pq)..2 =[sigma_eq_pr1_unc pq] pq.2 := - (dpair_sigma_eq_unc pq)..2 - - definition sigma_eq_eta_unc (p : u = v) : sigma_eq_unc ⟨p..1, p..2⟩ = p := - sigma_eq_eta p - - definition tr_sigma_eq_pr1_unc {B' : A → Type} - (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2) - : transport (λx, B' x.1) (@sigma_eq_unc A B u v pq) = transport B' pq.1 := - destruct pq tr_pr1_sigma_eq - - definition is_equiv_sigma_eq [instance] (u v : Σa, B a) - : is_equiv (@sigma_eq_unc A B u v) := - adjointify sigma_eq_unc - (λp, ⟨p..1, p..2⟩) - sigma_eq_eta_unc - dpair_sigma_eq_unc - - definition sigma_eq_equiv (u v : Σa, B a) : (u = v) ≃ (Σ(p : u.1 = v.1), u.2 =[p] v.2) := - (equiv.mk sigma_eq_unc _)⁻¹ᵉ - - definition dpair_eq_dpair_con (p1 : a = a' ) (q1 : b =[p1] b' ) - (p2 : a' = a'') (q2 : b' =[p2] b'') : - dpair_eq_dpair (p1 ⬝ p2) (q1 ⬝o q2) = dpair_eq_dpair p1 q1 ⬝ dpair_eq_dpair p2 q2 := - by induction q1; induction q2; reflexivity - - definition sigma_eq_con (p1 : u.1 = v.1) (q1 : u.2 =[p1] v.2) - (p2 : v.1 = w.1) (q2 : v.2 =[p2] w.2) : - sigma_eq (p1 ⬝ p2) (q1 ⬝o q2) = sigma_eq p1 q1 ⬝ sigma_eq p2 q2 := - by induction u; induction v; induction w; apply dpair_eq_dpair_con - - local attribute dpair_eq_dpair [reducible] - definition dpair_eq_dpair_con_idp (p : a = a') (q : b =[p] b') : - dpair_eq_dpair p q = dpair_eq_dpair p !pathover_tr ⬝ - dpair_eq_dpair idp (pathover_idp_of_eq (tr_eq_of_pathover q)) := - by induction q; reflexivity - - /- eq_pr1 commutes with the groupoid structure. -/ - - definition eq_pr1_idp (u : Σa, B a) : (refl u) ..1 = refl (u.1) := idp - definition eq_pr1_con (p : u = v) (q : v = w) : (p ⬝ q) ..1 = (p..1) ⬝ (q..1) := !ap_con - definition eq_pr1_inv (p : u = v) : p⁻¹ ..1 = (p..1)⁻¹ := !ap_inv - - /- Applying dpair to one argument is the same as dpair_eq_dpair with reflexivity in the first place. -/ - - definition ap_dpair (q : b₁ = b₂) : - ap (sigma.mk a) q = dpair_eq_dpair idp (pathover_idp_of_eq q) := - by induction q; reflexivity - - /- Dependent transport is the same as transport along a sigma_eq. -/ - - definition transportD_eq_transport (p : a = a') (c : C a b) : - p ▸D c = transport (λu, C (u.1) (u.2)) (dpair_eq_dpair p !pathover_tr) c := - by induction p; reflexivity - - definition sigma_eq_eq_sigma_eq {p1 q1 : a = a'} {p2 : b =[p1] b'} {q2 : b =[q1] b'} - (r : p1 = q1) (s : p2 =[r] q2) : sigma_eq p1 p2 = sigma_eq q1 q2 := - by induction s; reflexivity - - /- A path between paths in a total space is commonly shown component wise. -/ - definition sigma_eq2 {p q : u = v} (r : p..1 = q..1) (s : p..2 =[r] q..2) - : p = q := - begin - induction p, induction u with u1 u2, - transitivity sigma_eq q..1 q..2, - apply sigma_eq_eq_sigma_eq r s, - apply sigma_eq_eta, - end - - definition sigma_eq2_unc {p q : u = v} (rs : Σ(r : p..1 = q..1), p..2 =[r] q..2) : p = q := - destruct rs sigma_eq2 - - definition ap_dpair_eq_dpair (f : Πa, B a → A') (p : a = a') (q : b =[p] b') - : ap (sigma.rec f) (dpair_eq_dpair p q) = apo011 f p q := - by induction q; reflexivity - - /- Transport -/ - - /- The concrete description of transport in sigmas (and also pis) is rather trickier than in the other types. In particular, these cannot be described just in terms of transport in simpler types; they require also the dependent transport [transportD]. - - In particular, this indicates why `transport` alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type Theory). A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? -/ - - definition sigma_transport (p : a = a') (bc : Σ(b : B a), C a b) - : p ▸ bc = ⟨p ▸ bc.1, p ▸D bc.2⟩ := - by induction p; induction bc; reflexivity - - /- The special case when the second variable doesn't depend on the first is simpler. -/ - definition sigma_transport_nondep {B : Type} {C : A → B → Type} (p : a = a') - (bc : Σ(b : B), C a b) : p ▸ bc = ⟨bc.1, p ▸ bc.2⟩ := - by induction p; induction bc; reflexivity - - /- Or if the second variable contains a first component that doesn't depend on the first. -/ - - definition sigma_transport2_nondep {C : A → Type} {D : Π a:A, B a → C a → Type} (p : a = a') - (bcd : Σ(b : B a) (c : C a), D a b c) : p ▸ bcd = ⟨p ▸ bcd.1, p ▸ bcd.2.1, p ▸D2 bcd.2.2⟩ := - begin - induction p, induction bcd with b cd, induction cd, reflexivity - end - - /- Pathovers -/ - - definition etao (p : a = a') (bc : Σ(b : B a), C a b) - : bc =[p] ⟨p ▸ bc.1, p ▸D bc.2⟩ := - by induction p; induction bc; apply idpo - - definition sigma_pathover (p : a = a') (u : Σ(b : B a), C a b) (v : Σ(b : B a'), C a' b) - (r : u.1 =[p] v.1) (s : u.2 =[apo011 C p r] v.2) : u =[p] v := - begin - induction u, induction v, esimp at *, induction r, - esimp [apo011] at s, induction s using idp_rec_on, apply idpo - end - - /- - TODO: - * define the projections from the type u =[p] v - * show that the uncurried version of sigma_pathover is an equivalence - -/ - - /- Functorial action -/ - variables (f : A → A') (g : Πa, B a → B' (f a)) - - definition sigma_functor [unfold 7] (u : Σa, B a) : Σa', B' a' := - ⟨f u.1, g u.1 u.2⟩ - - definition total [reducible] [unfold 5] {B' : A → Type} (g : Πa, B a → B' a) (u : Σa, B a) - : Σa', B' a' := - sigma_functor id g u - - /- Equivalences -/ - definition is_equiv_sigma_functor [constructor] [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] - : is_equiv (sigma_functor f g) := - adjointify (sigma_functor f g) - (sigma_functor f⁻¹ (λ(a' : A') (b' : B' a'), - ((g (f⁻¹ a'))⁻¹ (transport B' (right_inv f a')⁻¹ b')))) - abstract begin - intro u', induction u' with a' b', - apply sigma_eq (right_inv f a'), - rewrite [▸*,right_inv (g (f⁻¹ a')),▸*], - apply tr_pathover - end end - abstract begin - intro u, - induction u with a b, - apply (sigma_eq (left_inv f a)), - apply pathover_of_tr_eq, - rewrite [▸*,adj f,-(fn_tr_eq_tr_fn (left_inv f a) (λ a, (g a)⁻¹)), - ▸*,tr_compose B' f,tr_inv_tr,left_inv] - end end - - definition sigma_equiv_sigma_of_is_equiv [constructor] - [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] : (Σa, B a) ≃ (Σa', B' a') := - equiv.mk (sigma_functor f g) !is_equiv_sigma_functor - - definition sigma_equiv_sigma [constructor] (Hf : A ≃ A') (Hg : Π a, B a ≃ B' (to_fun Hf a)) : - (Σa, B a) ≃ (Σa', B' a') := - sigma_equiv_sigma_of_is_equiv (to_fun Hf) (λ a, to_fun (Hg a)) - - definition sigma_equiv_sigma_right [constructor] {B' : A → Type} (Hg : Π a, B a ≃ B' a) - : (Σa, B a) ≃ Σa, B' a := - sigma_equiv_sigma equiv.refl Hg - - definition sigma_equiv_sigma_left [constructor] (Hf : A ≃ A') : - (Σa, B a) ≃ (Σa', B (to_inv Hf a')) := - sigma_equiv_sigma Hf (λ a, equiv_ap B !right_inv⁻¹) - - definition ap_sigma_functor_eq_dpair (p : a = a') (q : b =[p] b') : - ap (sigma_functor f g) (sigma_eq p q) = sigma_eq (ap f p) (pathover.rec_on q idpo) := - by induction q; reflexivity - - -- definition ap_sigma_functor_eq (p : u.1 = v.1) (q : u.2 =[p] v.2) - -- : ap (sigma_functor f g) (sigma_eq p q) = - -- sigma_eq (ap f p) - -- ((tr_compose B' f p (g u.1 u.2))⁻¹ ⬝ (fn_tr_eq_tr_fn p g u.2)⁻¹ ⬝ ap (g v.1) q) := - -- by induction u; induction v; apply ap_sigma_functor_eq_dpair - - /- definition 3.11.9(i): Summing up a contractible family of types does nothing. -/ - - definition is_equiv_pr1 [instance] [constructor] (B : A → Type) [H : Π a, is_contr (B a)] - : is_equiv (@pr1 A B) := - adjointify pr1 - (λa, ⟨a, !center⟩) - (λa, idp) - (λu, sigma_eq idp (pathover_idp_of_eq !center_eq)) - - definition sigma_equiv_of_is_contr_right [constructor] [H : Π a, is_contr (B a)] - : (Σa, B a) ≃ A := - equiv.mk pr1 _ - - /- definition 3.11.9(ii): Dually, summing up over a contractible type does nothing. -/ - - definition sigma_equiv_of_is_contr_left [constructor] (B : A → Type) [H : is_contr A] - : (Σa, B a) ≃ B (center A) := - equiv.MK - (λu, (center_eq u.1)⁻¹ ▸ u.2) - (λb, ⟨!center, b⟩) - abstract (λb, ap (λx, x ▸ b) !prop_eq_of_is_contr) end - abstract (λu, sigma_eq !center_eq !tr_pathover) end - - /- Associativity -/ - - --this proof is harder than in Coq because we don't have eta definitionally for sigma - definition sigma_assoc_equiv [constructor] (C : (Σa, B a) → Type) - : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) := - equiv.mk _ (adjointify - (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩) - (λuc, ⟨uc.1.1, uc.1.2, !sigma.eta⁻¹ ▸ uc.2⟩) - abstract begin intro uc, induction uc with u c, induction u, reflexivity end end - abstract begin intro av, induction av with a v, induction v, reflexivity end end) - - open prod prod.ops - definition assoc_equiv_prod [constructor] (C : (A × A') → Type) : (Σa a', C (a,a')) ≃ (Σu, C u) := - equiv.mk _ (adjointify - (λav, ⟨(av.1, av.2.1), av.2.2⟩) - (λuc, ⟨pr₁ (uc.1), pr₂ (uc.1), !prod.eta⁻¹ ▸ uc.2⟩) - abstract proof (λuc, destruct uc (λu, prod.destruct u (λa b c, idp))) qed end - abstract proof (λav, destruct av (λa v, destruct v (λb c, idp))) qed end) - - /- Symmetry -/ - - definition comm_equiv_unc (C : A × A' → Type) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) := - calc - (Σa a', C (a, a')) ≃ Σu, C u : assoc_equiv_prod - ... ≃ Σv, C (flip v) : sigma_equiv_sigma !prod_comm_equiv - (λu, prod.destruct u (λa a', equiv.refl)) - ... ≃ Σa' a, C (a, a') : assoc_equiv_prod - - definition sigma_comm_equiv [constructor] (C : A → A' → Type) - : (Σa a', C a a') ≃ (Σa' a, C a a') := - comm_equiv_unc (λu, C (prod.pr1 u) (prod.pr2 u)) - - definition equiv_prod [constructor] (A B : Type) : (Σ(a : A), B) ≃ A × B := - equiv.mk _ (adjointify - (λs, (s.1, s.2)) - (λp, ⟨pr₁ p, pr₂ p⟩) - proof (λp, prod.destruct p (λa b, idp)) qed - proof (λs, destruct s (λa b, idp)) qed) - - definition comm_equiv_nondep (A B : Type) : (Σ(a : A), B) ≃ Σ(b : B), A := - calc - (Σ(a : A), B) ≃ A × B : equiv_prod - ... ≃ B × A : prod_comm_equiv - ... ≃ Σ(b : B), A : equiv_prod - - definition sigma_assoc_comm_equiv {A : Type} (B C : A → Type) - : (Σ(v : Σa, B a), C v.1) ≃ (Σ(u : Σa, C a), B u.1) := - calc (Σ(v : Σa, B a), C v.1) - ≃ (Σa (b : B a), C a) : !sigma_assoc_equiv⁻¹ᵉ - ... ≃ (Σa, B a × C a) : sigma_equiv_sigma_right (λa, !equiv_prod) - ... ≃ (Σa, C a × B a) : sigma_equiv_sigma_right (λa, !prod_comm_equiv) - ... ≃ (Σa (c : C a), B a) : sigma_equiv_sigma_right (λa, !equiv_prod) - ... ≃ (Σ(u : Σa, C a), B u.1) : sigma_assoc_equiv - - /- Interaction with other type constructors -/ - - definition sigma_empty_left [constructor] (B : empty → Type) : (Σx, B x) ≃ empty := - begin - fapply equiv.MK, - { intro v, induction v, contradiction}, - { intro x, contradiction}, - { intro x, contradiction}, - { intro v, induction v, contradiction}, - end - - definition sigma_empty_right [constructor] (A : Type) : (Σ(a : A), empty) ≃ empty := - begin - fapply equiv.MK, - { intro v, induction v, contradiction}, - { intro x, contradiction}, - { intro x, contradiction}, - { intro v, induction v, contradiction}, - end - - definition sigma_unit_left [constructor] (B : unit → Type) : (Σx, B x) ≃ B star := - !sigma_equiv_of_is_contr_left - - definition sigma_unit_right [constructor] (A : Type) : (Σ(a : A), unit) ≃ A := - !sigma_equiv_of_is_contr_right - - definition sigma_sum_left [constructor] (B : A + A' → Type) - : (Σp, B p) ≃ (Σa, B (inl a)) + (Σa, B (inr a)) := - begin - fapply equiv.MK, - { intro v, - induction v with p b, - induction p, - { apply inl, constructor, assumption }, - { apply inr, constructor, assumption }}, - { intro p, induction p with v v: induction v; constructor; assumption}, - { intro p, induction p with v v: induction v; reflexivity}, - { intro v, induction v with p b, induction p: reflexivity}, - end - - definition sigma_sum_right [constructor] (B C : A → Type) - : (Σa, B a + C a) ≃ (Σa, B a) + (Σa, C a) := - begin - fapply equiv.MK, - { intro v, - induction v with a p, - induction p, - { apply inl, constructor, assumption}, - { apply inr, constructor, assumption}}, - { intro p, - induction p with v v, - { induction v, constructor, apply inl, assumption }, - { induction v, constructor, apply inr, assumption }}, - { intro p, induction p with v v: induction v; reflexivity}, - { intro v, induction v with a p, induction p: reflexivity}, - end - - /- ** Universal mapping properties -/ - /- *** The positive universal property. -/ - - section - definition is_equiv_sigma_rec [instance] (C : (Σa, B a) → Type) - : is_equiv (sigma.rec : (Πa b, C ⟨a, b⟩) → Πab, C ab) := - adjointify _ (λ g a b, g ⟨a, b⟩) - (λ g, proof eq_of_homotopy (λu, destruct u (λa b, idp)) qed) - (λ f, refl f) - - definition equiv_sigma_rec (C : (Σa, B a) → Type) - : (Π(a : A) (b: B a), C ⟨a, b⟩) ≃ (Πxy, C xy) := - equiv.mk sigma.rec _ - - /- *** The negative universal property. -/ - - protected definition coind_unc (fg : Σ(f : Πa, B a), Πa, C a (f a)) (a : A) - : Σ(b : B a), C a b := - ⟨fg.1 a, fg.2 a⟩ - - protected definition coind (f : Π a, B a) (g : Π a, C a (f a)) (a : A) : Σ(b : B a), C a b := - sigma.coind_unc ⟨f, g⟩ a - - --is the instance below dangerous? - --in Coq this can be done without function extensionality - definition is_equiv_coind [instance] (C : Πa, B a → Type) - : is_equiv (@sigma.coind_unc _ _ C) := - adjointify _ (λ h, ⟨λa, (h a).1, λa, (h a).2⟩) - (λ h, proof eq_of_homotopy (λu, !sigma.eta) qed) - (λfg, destruct fg (λ(f : Π (a : A), B a) (g : Π (x : A), C x (f x)), proof idp qed)) - - definition sigma_pi_equiv_pi_sigma : (Σ(f : Πa, B a), Πa, C a (f a)) ≃ (Πa, Σb, C a b) := - equiv.mk sigma.coind_unc _ - end - - /- Subtypes (sigma types whose second components are props) -/ - - definition subtype [reducible] {A : Type} (P : A → Type) [H : Πa, is_prop (P a)] := - Σ(a : A), P a - notation [parsing_only] `{` binder `|` r:(scoped:1 P, subtype P) `}` := r - - /- To prove equality in a subtype, we only need equality of the first component. -/ - definition subtype_eq [H : Πa, is_prop (B a)] {u v : {a | B a}} : u.1 = v.1 → u = v := - sigma_eq_unc ∘ inv pr1 - - definition is_equiv_subtype_eq [H : Πa, is_prop (B a)] (u v : {a | B a}) - : is_equiv (subtype_eq : u.1 = v.1 → u = v) := - !is_equiv_compose - local attribute is_equiv_subtype_eq [instance] - - definition equiv_subtype [H : Πa, is_prop (B a)] (u v : {a | B a}) : (u.1 = v.1) ≃ (u = v) := - equiv.mk !subtype_eq _ - - definition subtype_eq_inv {A : Type} {B : A → Type} [H : Πa, is_prop (B a)] (u v : Σa, B a) - : u = v → u.1 = v.1 := - subtype_eq⁻¹ᶠ - - local attribute subtype_eq_inv [reducible] - definition is_equiv_subtype_eq_inv {A : Type} {B : A → Type} [H : Πa, is_prop (B a)] - (u v : Σa, B a) : is_equiv (subtype_eq_inv u v) := - _ - - /- truncatedness -/ - theorem is_trunc_sigma (B : A → Type) (n : trunc_index) - [HA : is_trunc n A] [HB : Πa, is_trunc n (B a)] : is_trunc n (Σa, B a) := - begin - revert A B HA HB, - induction n with n IH, - { intro A B HA HB, fapply is_trunc_equiv_closed_rev, apply sigma_equiv_of_is_contr_left}, - { intro A B HA HB, apply is_trunc_succ_intro, intro u v, - apply is_trunc_equiv_closed_rev, - apply sigma_eq_equiv, - exact IH _ _ _ _} - end - - theorem is_trunc_subtype (B : A → Prop) (n : trunc_index) - [HA : is_trunc (n.+1) A] : is_trunc (n.+1) (Σa, B a) := - @(is_trunc_sigma B (n.+1)) _ (λa, !is_trunc_succ_of_is_prop) - -end sigma - -attribute sigma.is_trunc_sigma [instance] [priority 1490] -attribute sigma.is_trunc_subtype [instance] [priority 1200] diff --git a/hott/types/sum.hlean b/hott/types/sum.hlean deleted file mode 100644 index 270062c4d3..0000000000 --- a/hott/types/sum.hlean +++ /dev/null @@ -1,384 +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 sums/coproducts/disjoint unions --/ - -import .pi .equiv logic - -open lift eq is_equiv equiv prod prod.ops is_trunc sigma bool - -namespace sum - universe variables u v u' v' - variables {A : Type.{u}} {B : Type.{v}} (z z' : A + B) {P : A → Type.{u'}} {Q : A → Type.{v'}} - - protected definition eta : sum.rec inl inr z = z := - by induction z; all_goals reflexivity - - protected definition code [unfold 3 4] : A + B → A + B → Type.{max u v} - | code (inl a) (inl a') := lift (a = a') - | code (inr b) (inr b') := lift (b = b') - | code _ _ := lift empty - - protected definition decode [unfold 3 4] : Π(z z' : A + B), sum.code z z' → z = z' - | decode (inl a) (inl a') := λc, ap inl (down c) - | decode (inl a) (inr b') := λc, empty.elim (down c) _ - | decode (inr b) (inl a') := λc, empty.elim (down c) _ - | decode (inr b) (inr b') := λc, ap inr (down c) - - protected definition mem_cases : (Σ a, z = inl a) + (Σ b, z = inr b) := - by cases z with a b; exact inl ⟨a, idp⟩; exact inr ⟨b, idp⟩ - - protected definition eqrec {A B : Type} {C : A + B → Type} - (x : A + B) (cl : Π a, x = inl a → C (inl a)) (cr : Π b, x = inr b → C (inr b)) : C x := - by cases x with a b; exact cl a idp; exact cr b idp - - variables {z z'} - protected definition encode [unfold 3 4 5] (p : z = z') : sum.code z z' := - by induction p; induction z; all_goals exact up idp - - variables (z z') - definition sum_eq_equiv [constructor] : (z = z') ≃ sum.code z z' := - equiv.MK sum.encode - !sum.decode - abstract begin - intro c, induction z with a b, all_goals induction z' with a' b', - all_goals (esimp at *; induction c with c), - all_goals induction c, -- c either has type empty or a path - all_goals reflexivity - end end - abstract begin - intro p, induction p, induction z, all_goals reflexivity - end end - - section - variables {a a' : A} {b b' : B} - definition eq_of_inl_eq_inl [unfold 5] (p : inl a = inl a' :> A + B) : a = a' := - down (sum.encode p) - definition eq_of_inr_eq_inr [unfold 5] (p : inr b = inr b' :> A + B) : b = b' := - down (sum.encode p) - definition empty_of_inl_eq_inr (p : inl a = inr b) : empty := down (sum.encode p) - definition empty_of_inr_eq_inl (p : inr b = inl a) : empty := down (sum.encode p) - - /- Transport -/ - - definition sum_transport (p : a = a') (z : P a + Q a) - : p ▸ z = sum.rec (λa, inl (p ▸ a)) (λb, inr (p ▸ b)) z := - by induction p; induction z; all_goals reflexivity - - /- Pathovers -/ - - definition etao (p : a = a') (z : P a + Q a) - : z =[p] sum.rec (λa, inl (p ▸ a)) (λb, inr (p ▸ b)) z := - by induction p; induction z; all_goals constructor - - protected definition codeo (p : a = a') : P a + Q a → P a' + Q a' → Type.{max u' v'} - | codeo (inl x) (inl x') := lift.{u' v'} (x =[p] x') - | codeo (inr y) (inr y') := lift.{v' u'} (y =[p] y') - | codeo _ _ := lift empty - - protected definition decodeo (p : a = a') : Π(z : P a + Q a) (z' : P a' + Q a'), - sum.codeo p z z' → z =[p] z' - | decodeo (inl x) (inl x') := λc, apo (λa, inl) (down c) - | decodeo (inl x) (inr y') := λc, empty.elim (down c) _ - | decodeo (inr y) (inl x') := λc, empty.elim (down c) _ - | decodeo (inr y) (inr y') := λc, apo (λa, inr) (down c) - - variables {z z'} - protected definition encodeo {p : a = a'} {z : P a + Q a} {z' : P a' + Q a'} (q : z =[p] z') - : sum.codeo p z z' := - by induction q; induction z; all_goals exact up idpo - - variables (z z') - definition sum_pathover_equiv [constructor] (p : a = a') (z : P a + Q a) (z' : P a' + Q a') - : (z =[p] z') ≃ sum.codeo p z z' := - equiv.MK sum.encodeo - !sum.decodeo - abstract begin - intro c, induction z with a b, all_goals induction z' with a' b', - all_goals (esimp at *; induction c with c), - all_goals induction c, -- c either has type empty or a pathover - all_goals reflexivity - end end - abstract begin - intro q, induction q, induction z, all_goals reflexivity - end end - end - - /- Functorial action -/ - - variables {A' B' : Type} (f : A → A') (g : B → B') - definition sum_functor [unfold 7] : A + B → A' + B' - | sum_functor (inl a) := inl (f a) - | sum_functor (inr b) := inr (g b) - - /- Equivalences -/ - - definition is_equiv_sum_functor [constructor] [Hf : is_equiv f] [Hg : is_equiv g] - : is_equiv (sum_functor f g) := - adjointify (sum_functor f g) - (sum_functor f⁻¹ g⁻¹) - abstract begin - intro z, induction z, - all_goals (esimp; (apply ap inl | apply ap inr); apply right_inv) - end end - abstract begin - intro z, induction z, - all_goals (esimp; (apply ap inl | apply ap inr); apply right_inv) - end end - - definition sum_equiv_sum_of_is_equiv [constructor] [Hf : is_equiv f] [Hg : is_equiv g] - : A + B ≃ A' + B' := - equiv.mk _ (is_equiv_sum_functor f g) - - definition sum_equiv_sum [constructor] (f : A ≃ A') (g : B ≃ B') : A + B ≃ A' + B' := - equiv.mk _ (is_equiv_sum_functor f g) - - definition sum_equiv_sum_left [constructor] (g : B ≃ B') : A + B ≃ A + B' := - sum_equiv_sum equiv.refl g - - definition sum_equiv_sum_right [constructor] (f : A ≃ A') : A + B ≃ A' + B := - sum_equiv_sum f equiv.refl - - definition flip [unfold 3] : A + B → B + A - | flip (inl a) := inr a - | flip (inr b) := inl b - - definition sum_comm_equiv [constructor] (A B : Type) : A + B ≃ B + A := - begin - fapply equiv.MK, - exact flip, - exact flip, - all_goals (intro z; induction z; all_goals reflexivity) - end - - definition sum_assoc_equiv [constructor] (A B C : Type) : A + (B + C) ≃ (A + B) + C := - begin - fapply equiv.MK, - all_goals try (intro z; induction z with u v; - all_goals try induction u; all_goals try induction v), - exact inl (inl u), - exact inl (inr a), - exact inr a, - exact inl a, - exact inr (inl a), - exact inr (inr v), - all_goals reflexivity - end - - definition sum_empty_equiv [constructor] (A : Type) : A + empty ≃ A := - begin - fapply equiv.MK, - { intro z, induction z, assumption, contradiction}, - { exact inl}, - { intro a, reflexivity}, - { intro z, induction z, reflexivity, contradiction} - end - - definition empty_sum_equiv (A : Type) : empty + A ≃ A := - !sum_comm_equiv ⬝e !sum_empty_equiv - - definition bool_equiv_unit_sum_unit : bool ≃ unit + unit := - begin - fapply equiv.MK, - { intro b, cases b, exact inl unit.star, exact inr unit.star }, - { intro s, cases s, exact bool.ff, exact bool.tt }, - { intro s, cases s, do 2 (cases a; reflexivity) }, - { intro b, cases b, do 2 reflexivity }, - end - - definition sum_prod_right_distrib [constructor] (A B C : Type) : - (A + B) × C ≃ (A × C) + (B × C) := - begin - fapply equiv.MK, - { intro x, cases x with ab c, cases ab with a b, exact inl (a, c), exact inr (b, c) }, - { intro x, cases x with ac bc, cases ac with a c, exact (inl a, c), - cases bc with b c, exact (inr b, c) }, - { intro x, cases x with ac bc, cases ac with a c, reflexivity, cases bc, reflexivity }, - { intro x, cases x with ab c, cases ab with a b, do 2 reflexivity } - end - - definition sum_prod_left_distrib [constructor] (A B C : Type) : - A × (B + C) ≃ (A × B) + (A × C) := - calc A × (B + C) ≃ (B + C) × A : prod_comm_equiv - ... ≃ (B × A) + (C × A) : sum_prod_right_distrib - ... ≃ (A × B) + (C × A) : sum_equiv_sum_right !prod_comm_equiv - ... ≃ (A × B) + (A × C) : sum_equiv_sum_left !prod_comm_equiv - - section - variables (H : unit + A ≃ unit + B) - include H - - open unit decidable sigma.ops - - definition unit_sum_equiv_cancel_map : A → B := - begin - intro a, cases sum.mem_cases (H (inr a)) with u b, rotate 1, exact b.1, - cases u with u Hu, cases sum.mem_cases (H (inl ⋆)) with u' b, rotate 1, exact b.1, - cases u' with u' Hu', exfalso, apply empty_of_inl_eq_inr, - calc inl ⋆ = H⁻¹ (H (inl ⋆)) : (to_left_inv H (inl ⋆))⁻¹ - ... = H⁻¹ (inl u') : {Hu'} - ... = H⁻¹ (inl u) : is_prop.elim - ... = H⁻¹ (H (inr a)) : {Hu⁻¹} - ... = inr a : to_left_inv H (inr a) - end - - definition unit_sum_equiv_cancel_inv (b : B) : - unit_sum_equiv_cancel_map H (unit_sum_equiv_cancel_map H⁻¹ᵉ b) = b := - begin - esimp[unit_sum_equiv_cancel_map], apply sum.rec, - { intro x, cases x with u Hu, esimp, apply sum.rec, - { intro x, exfalso, cases x with u' Hu', apply empty_of_inl_eq_inr, - calc inl ⋆ = H⁻¹ (H (inl ⋆)) : (to_left_inv H (inl ⋆))⁻¹ - ... = H⁻¹ (inl u') : ap H⁻¹ Hu' - ... = H⁻¹ (inl u) : {!is_prop.elim} - ... = H⁻¹ (H (inr _)) : {Hu⁻¹} - ... = inr _ : to_left_inv H }, - { intro x, cases x with b' Hb', esimp, cases sum.mem_cases (H⁻¹ (inr b)) with x x, - { cases x with u' Hu', cases u', apply eq_of_inr_eq_inr, - calc inr b' = H (inl ⋆) : Hb'⁻¹ - ... = H (H⁻¹ (inr b)) : (ap (to_fun H) Hu')⁻¹ - ... = inr b : to_right_inv H (inr b)}, - { exfalso, cases x with a Ha, apply empty_of_inl_eq_inr, - cases u, apply concat, apply Hu⁻¹, apply concat, rotate 1, apply !(to_right_inv H), - apply ap (to_fun H), - apply concat, rotate 1, apply Ha⁻¹, apply ap inr, esimp, - apply sum.rec, intro x, exfalso, apply empty_of_inl_eq_inr, - apply concat, exact x.2⁻¹, apply Ha, - intro x, cases x with a' Ha', esimp, apply eq_of_inr_eq_inr, apply Ha'⁻¹ ⬝ Ha } } }, - { intro x, cases x with b' Hb', esimp, apply eq_of_inr_eq_inr, refine Hb'⁻¹ ⬝ _, - cases sum.mem_cases (to_fun H⁻¹ᵉ (inr b)) with x x, - { cases x with u Hu, esimp, cases sum.mem_cases (to_fun H⁻¹ᵉ (inl ⋆)) with x x, - { cases x with u' Hu', exfalso, apply empty_of_inl_eq_inr, - calc inl ⋆ = H (H⁻¹ (inl ⋆)) : (to_right_inv H (inl ⋆))⁻¹ - ... = H (inl u') : ap H Hu' - ... = H (inl u) : by rewrite [is_prop.elim u' u] - ... = H (H⁻¹ᵉ (inr b)) : ap H Hu⁻¹ - ... = inr b : to_right_inv H (inr b) }, - { cases x with a Ha, exfalso, apply empty_of_inl_eq_inr, - apply concat, rotate 1, exact Hb', - have Ha' : inl ⋆ = H (inr a), by apply !(to_right_inv H)⁻¹ ⬝ ap H Ha, - apply concat Ha', apply ap H, apply ap inr, apply sum.rec, - intro x, cases x with u' Hu', esimp, apply sum.rec, - intro x, cases x with u'' Hu'', esimp, apply empty.rec, - intro x, cases x with a'' Ha'', esimp, krewrite Ha' at Ha'', apply eq_of_inr_eq_inr, - apply !(to_left_inv H)⁻¹ ⬝ Ha'', - intro x, exfalso, cases x with a'' Ha'', apply empty_of_inl_eq_inr, - apply Hu⁻¹ ⬝ Ha'', } }, - { cases x with a' Ha', esimp, refine _ ⬝ !(to_right_inv H), apply ap H, - apply Ha'⁻¹ } } - end - - definition unit_sum_equiv_cancel : A ≃ B := - begin - fapply equiv.MK, apply unit_sum_equiv_cancel_map H, - apply unit_sum_equiv_cancel_map H⁻¹ᵉ, - intro b, apply unit_sum_equiv_cancel_inv, - { intro a, have H = (H⁻¹ᵉ)⁻¹ᵉ, from !equiv.symm_symm⁻¹, rewrite this at {2}, - apply unit_sum_equiv_cancel_inv } - end - - end - - /- universal property -/ - - definition sum_rec_unc [unfold 5] {P : A + B → Type} (fg : (Πa, P (inl a)) × (Πb, P (inr b))) - : Πz, P z := - sum.rec fg.1 fg.2 - - definition is_equiv_sum_rec [constructor] (P : A + B → Type) - : is_equiv (sum_rec_unc : (Πa, P (inl a)) × (Πb, P (inr b)) → Πz, P z) := - begin - apply adjointify sum_rec_unc (λf, (λa, f (inl a), λb, f (inr b))), - intro f, apply eq_of_homotopy, intro z, focus (induction z; all_goals reflexivity), - intro h, induction h with f g, reflexivity - end - - definition equiv_sum_rec [constructor] (P : A + B → Type) - : (Πa, P (inl a)) × (Πb, P (inr b)) ≃ Πz, P z := - equiv.mk _ !is_equiv_sum_rec - - definition imp_prod_imp_equiv_sum_imp [constructor] (A B C : Type) - : (A → C) × (B → C) ≃ (A + B → C) := - !equiv_sum_rec - - /- truncatedness -/ - - variables (A B) - theorem is_trunc_sum (n : trunc_index) [HA : is_trunc (n.+2) A] [HB : is_trunc (n.+2) B] - : is_trunc (n.+2) (A + B) := - begin - apply is_trunc_succ_intro, intro z z', - apply is_trunc_equiv_closed_rev, apply sum_eq_equiv, - induction z with a b, all_goals induction z' with a' b', all_goals esimp, - all_goals exact _, - end - - theorem is_trunc_sum_excluded (n : trunc_index) [HA : is_trunc n A] [HB : is_trunc n B] - (H : A → B → empty) : is_trunc n (A + B) := - begin - induction n with n IH, - { exfalso, exact H !center !center}, - { clear IH, induction n with n IH, - { apply is_prop.mk, intros x y, - induction x, all_goals induction y, all_goals esimp, - all_goals try (exfalso;apply H;assumption;assumption), all_goals apply ap _ !is_prop.elim}, - { apply is_trunc_sum}} - end - - variable {B} - definition is_contr_sum_left [HA : is_contr A] (H : ¬B) : is_contr (A + B) := - is_contr.mk (inl !center) - (λx, sum.rec_on x (λa, ap inl !center_eq) (λb, empty.elim (H b))) - - /- - Sums are equivalent to dependent sigmas where the first component is a bool. - - The current construction only works for A and B in the same universe. - If we need it for A and B in different universes, we need to insert some lifts. - -/ - - definition sum_of_sigma_bool {A B : Type.{u}} (v : Σ(b : bool), bool.rec A B b) : A + B := - by induction v with b x; induction b; exact inl x; exact inr x - - definition sigma_bool_of_sum {A B : Type.{u}} (z : A + B) : Σ(b : bool), bool.rec A B b := - by induction z with a b; exact ⟨ff, a⟩; exact ⟨tt, b⟩ - - definition sum_equiv_sigma_bool [constructor] (A B : Type.{u}) - : A + B ≃ Σ(b : bool), bool.rec A B b := - equiv.MK sigma_bool_of_sum - sum_of_sigma_bool - begin intro v, induction v with b x, induction b, all_goals reflexivity end - begin intro z, induction z with a b, all_goals reflexivity end - -end sum -open sum pi - -namespace decidable - - definition decidable_equiv [constructor] (A : Type) : decidable A ≃ A + ¬A := - begin - fapply equiv.MK:intro a;induction a:try (constructor;assumption;now), - all_goals reflexivity - end - - definition is_trunc_decidable [constructor] (A : Type) (n : trunc_index) [H : is_trunc n A] : - is_trunc n (decidable A) := - begin - apply is_trunc_equiv_closed_rev, - apply decidable_equiv, - induction n with n IH, - { apply is_contr_sum_left, exact λna, na !center}, - { apply is_trunc_sum_excluded, exact λa na, na a} - end - -end decidable - -attribute sum.is_trunc_sum [instance] [priority 1480] - -definition tsum [constructor] {n : trunc_index} (A B : (n.+2)-Type) : (n.+2)-Type := -trunctype.mk (A + B) _ - -infixr `+t`:25 := tsum diff --git a/hott/types/trunc.hlean b/hott/types/trunc.hlean deleted file mode 100644 index 25d62e7813..0000000000 --- a/hott/types/trunc.hlean +++ /dev/null @@ -1,529 +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 - -Properties of is_trunc and trunctype --/ - --- NOTE: the fact that (is_trunc n A) is a mere proposition is proved in .prop_trunc - -import .pointed2 ..function algebra.order types.nat.order - -open eq sigma sigma.ops pi function equiv trunctype - is_equiv prod pointed nat is_trunc algebra - -namespace trunc_index - - definition minus_one_le_succ (n : ℕ₋₂) : -1 ≤ n.+1 := - succ_le_succ (minus_two_le n) - - definition zero_le_of_nat (n : ℕ) : 0 ≤ of_nat n := - succ_le_succ !minus_one_le_succ - - open decidable - protected definition has_decidable_eq [instance] : Π(n m : ℕ₋₂), decidable (n = m) - | has_decidable_eq -2 -2 := inl rfl - | has_decidable_eq (n.+1) -2 := inr (by contradiction) - | has_decidable_eq -2 (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 : ℕ₋₂} (H : n .+1 ≤ -2) : 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.tr_refl}, - { exact trunc_index.le_trans (le.step !le.tr_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 trunc_index.le_trans H1 H2} - end - - protected definition le_succ {n m : ℕ₋₂} (H1 : n ≤ m): n ≤ m.+1 := - le.step H1 - -end trunc_index open trunc_index - -definition weak_order_trunc_index [trans_instance] [reducible] : weak_order trunc_index := -weak_order.mk le trunc_index.le.tr_refl @trunc_index.le_trans @trunc_index.le_antisymm - -namespace trunc_index - - /- more theorems about truncation indices -/ - - definition zero_add (n : ℕ₋₂) : (0 : ℕ₋₂) + n = n := - begin - cases n with n, reflexivity, - cases n with n, reflexivity, - induction n with n IH, reflexivity, exact ap succ IH - end - - definition add_zero (n : ℕ₋₂) : n + (0 : ℕ₋₂) = n := - by reflexivity - - definition succ_add_nat (n : ℕ₋₂) (m : ℕ) : n.+1 + m = (n + m).+1 := - by induction m with m IH; reflexivity; exact ap succ IH - - definition nat_add_succ (n : ℕ) (m : ℕ₋₂) : n + m.+1 = (n + m).+1 := - begin - cases m with m, reflexivity, - cases m with m, reflexivity, - induction m with m IH, reflexivity, exact ap succ IH - end - - definition add_nat_succ (n : ℕ₋₂) (m : ℕ) : n + (nat.succ m) = (n + m).+1 := - by reflexivity - - definition nat_succ_add (n : ℕ) (m : ℕ₋₂) : (nat.succ n) + m = (n + m).+1 := - begin - cases m with m, reflexivity, - cases m with m, reflexivity, - induction m with m IH, reflexivity, exact ap succ IH - end - - definition sub_two_add_two (n : ℕ₋₂) : sub_two (add_two n) = n := - begin - induction n with n IH, - { reflexivity}, - { exact ap succ IH} - end - - definition add_two_sub_two (n : ℕ) : add_two (sub_two n) = n := - begin - induction n with n IH, - { reflexivity}, - { exact ap nat.succ IH} - end - - definition of_nat_add_plus_two_of_nat (n m : ℕ) : n +2+ m = of_nat (n + m + 2) := - begin - induction m with m IH, - { reflexivity}, - { exact ap succ IH} - end - - definition of_nat_add_of_nat (n m : ℕ) : of_nat n + of_nat m = of_nat (n + m) := - begin - induction m with m IH, - { reflexivity}, - { exact ap succ IH} - end - - definition succ_add_plus_two (n m : ℕ₋₂) : n.+1 +2+ m = (n +2+ m).+1 := - begin - induction m with m IH, - { reflexivity}, - { exact ap succ IH} - end - - definition add_plus_two_succ (n m : ℕ₋₂) : n +2+ m.+1 = (n +2+ m).+1 := - idp - - definition add_succ_succ (n m : ℕ₋₂) : n + m.+2 = n +2+ m := - idp - - definition succ_add_succ (n m : ℕ₋₂) : n.+1 + m.+1 = n +2+ m := - begin - cases m with m IH, - { reflexivity}, - { apply succ_add_plus_two} - end - - definition succ_succ_add (n m : ℕ₋₂) : n.+2 + m = n +2+ m := - begin - cases m with m IH, - { reflexivity}, - { exact !succ_add_succ ⬝ !succ_add_plus_two} - end - - definition succ_sub_two (n : ℕ) : (nat.succ n).-2 = n.-2 .+1 := rfl - definition sub_two_succ_succ (n : ℕ) : n.-2.+1.+1 = n := rfl - definition succ_sub_two_succ (n : ℕ) : (nat.succ n).-2.+1 = n := rfl - - definition of_nat_le_of_nat {n m : ℕ} (H : n ≤ m) : (of_nat n ≤ of_nat m) := - begin - induction H with m H IH, - { apply le.refl}, - { exact trunc_index.le_succ IH} - end - - definition sub_two_le_sub_two {n m : ℕ} (H : n ≤ m) : n.-2 ≤ m.-2 := - begin - induction H with m H IH, - { apply le.refl}, - { exact trunc_index.le_succ IH} - end - - definition add_two_le_add_two {n m : ℕ₋₂} (H : n ≤ m) : add_two n ≤ add_two m := - begin - induction H with m H IH, - { reflexivity}, - { constructor, exact IH}, - end - - definition le_of_sub_two_le_sub_two {n m : ℕ} (H : n.-2 ≤ m.-2) : n ≤ m := - begin - rewrite [-add_two_sub_two n, -add_two_sub_two m], - exact add_two_le_add_two H, - end - - definition le_of_of_nat_le_of_nat {n m : ℕ} (H : of_nat n ≤ of_nat m) : n ≤ m := - begin - apply le_of_sub_two_le_sub_two, - exact le_of_succ_le_succ (le_of_succ_le_succ H) - end - -end trunc_index open trunc_index - -namespace is_trunc - - variables {A B : Type} {n : ℕ₋₂} - - /- theorems about trunctype -/ - protected definition trunctype.sigma_char.{l} [constructor] (n : ℕ₋₂) : - (trunctype.{l} n) ≃ (Σ (A : Type.{l}), is_trunc n A) := - begin - fapply equiv.MK, - { intro A, exact (⟨carrier A, struct A⟩)}, - { intro S, exact (trunctype.mk S.1 S.2)}, - { intro S, induction S with S1 S2, reflexivity}, - { intro A, induction A with A1 A2, reflexivity}, - end - - definition trunctype_eq_equiv [constructor] (n : ℕ₋₂) (A B : n-Type) : - (A = B) ≃ (carrier A = carrier B) := - calc - (A = B) ≃ (to_fun (trunctype.sigma_char n) A = to_fun (trunctype.sigma_char n) B) - : eq_equiv_fn_eq_of_equiv - ... ≃ ((to_fun (trunctype.sigma_char n) A).1 = (to_fun (trunctype.sigma_char n) B).1) - : equiv.symm (!equiv_subtype) - ... ≃ (carrier A = carrier B) : equiv.refl - - theorem is_trunc_is_embedding_closed (f : A → B) [Hf : is_embedding f] [HB : is_trunc n B] - (Hn : -1 ≤ n) : is_trunc n A := - begin - induction n with n, - {exfalso, exact not_succ_le_minus_two Hn}, - {apply is_trunc_succ_intro, intro a a', - fapply @is_trunc_is_equiv_closed_rev _ _ n (ap f)} - end - - theorem is_trunc_is_retraction_closed (f : A → B) [Hf : is_retraction f] - (n : ℕ₋₂) [HA : is_trunc n A] : is_trunc n B := - begin - revert A B f Hf HA, - induction n with n IH, - { intro A B f Hf HA, induction Hf with g ε, fapply is_contr.mk, - { exact f (center A)}, - { intro b, apply concat, - { apply (ap f), exact (center_eq (g b))}, - { apply ε}}}, - { intro A B f Hf HA, induction Hf with g ε, - apply is_trunc_succ_intro, intro b b', - fapply (IH (g b = g b')), - { intro q, exact ((ε b)⁻¹ ⬝ ap f q ⬝ ε b')}, - { apply (is_retraction.mk (ap g)), - { intro p, induction p, {rewrite [↑ap, con.left_inv]}}}, - { apply is_trunc_eq}} - end - - definition is_embedding_to_fun (A B : Type) : is_embedding (@to_fun A B) := - λf f', !is_equiv_ap_to_fun - - theorem is_trunc_trunctype [instance] (n : ℕ₋₂) : is_trunc n.+1 (n-Type) := - begin - apply is_trunc_succ_intro, intro X Y, - fapply is_trunc_equiv_closed, - { apply equiv.symm, apply trunctype_eq_equiv}, - fapply is_trunc_equiv_closed, - { apply equiv.symm, apply eq_equiv_equiv}, - induction n, - { apply @is_contr_of_inhabited_prop, - { apply is_trunc_is_embedding_closed, - { apply is_embedding_to_fun} , - { reflexivity}}, - { apply equiv_of_is_contr_of_is_contr}}, - { apply is_trunc_is_embedding_closed, - { apply is_embedding_to_fun}, - { apply minus_one_le_succ}} - end - - - /- theorems about decidable equality and axiom K -/ - theorem is_set_of_axiom_K {A : Type} (K : Π{a : A} (p : a = a), p = idp) : is_set A := - is_set.mk _ (λa b p q, eq.rec_on q K p) - - theorem is_set_of_relation.{u} {A : Type.{u}} (R : A → A → Type.{u}) - (mere : Π(a b : A), is_prop (R a b)) (refl : Π(a : A), R a a) - (imp : Π{a b : A}, R a b → a = b) : is_set A := - is_set_of_axiom_K - (λa p, - have H2 : transport (λx, R a x → a = x) p (@imp a a) = @imp a a, from !apd, - have H3 : Π(r : R a a), transport (λx, a = x) p (imp r) - = imp (transport (λx, R a x) p r), from - to_fun (equiv.symm !heq_pi) H2, - have H4 : imp (refl a) ⬝ p = imp (refl a), from - calc - imp (refl a) ⬝ p = transport (λx, a = x) p (imp (refl a)) : transport_eq_r - ... = imp (transport (λx, R a x) p (refl a)) : H3 - ... = imp (refl a) : is_prop.elim, - cancel_left (imp (refl a)) H4) - - definition relation_equiv_eq {A : Type} (R : A → A → Type) - (mere : Π(a b : A), is_prop (R a b)) (refl : Π(a : A), R a a) - (imp : Π{a b : A}, R a b → a = b) (a b : A) : R a b ≃ a = b := - @equiv_of_is_prop _ _ _ - (@is_trunc_eq _ _ (is_set_of_relation R mere refl @imp) a b) - imp - (λp, p ▸ refl a) - - local attribute not [reducible] - theorem is_set_of_double_neg_elim {A : Type} (H : Π(a b : A), ¬¬a = b → a = b) - : is_set A := - is_set_of_relation (λa b, ¬¬a = b) _ (λa n, n idp) H - - section - open decidable - --this is proven differently in init.hedberg - theorem is_set_of_decidable_eq (A : Type) [H : decidable_eq A] : is_set A := - is_set_of_double_neg_elim (λa b, by_contradiction) - end - - theorem is_trunc_of_axiom_K_of_le {A : Type} (n : ℕ₋₂) (H : -1 ≤ n) - (K : Π(a : A), is_trunc n (a = a)) : is_trunc (n.+1) A := - @is_trunc_succ_intro _ _ (λa b, is_trunc_of_imp_is_trunc_of_le H (λp, eq.rec_on p !K)) - - theorem is_trunc_succ_of_is_trunc_loop (Hn : -1 ≤ n) (Hp : Π(a : A), is_trunc n (a = a)) - : is_trunc (n.+1) A := - begin - apply is_trunc_succ_intro, intros a a', - apply is_trunc_of_imp_is_trunc_of_le Hn, intro p, - induction p, apply Hp - end - - theorem is_prop_iff_is_contr {A : Type} (a : A) : - is_prop A ↔ is_contr A := - iff.intro (λH, is_contr.mk a (is_prop.elim a)) _ - - theorem is_trunc_succ_iff_is_trunc_loop (A : Type) (Hn : -1 ≤ n) : - is_trunc (n.+1) A ↔ Π(a : A), is_trunc n (a = a) := - iff.intro _ (is_trunc_succ_of_is_trunc_loop Hn) - - theorem is_trunc_iff_is_contr_loop_succ (n : ℕ) (A : Type) - : is_trunc n A ↔ Π(a : A), is_contr (Ω[succ n](pointed.Mk a)) := - begin - revert A, induction n with n IH, - { intro A, esimp [iterated_ploop_space], transitivity _, - { apply is_trunc_succ_iff_is_trunc_loop, apply le.refl}, - { apply pi_iff_pi, intro a, esimp, apply is_prop_iff_is_contr, reflexivity}}, - { intro A, esimp [iterated_ploop_space], - transitivity _, - { apply @is_trunc_succ_iff_is_trunc_loop @n, esimp, apply minus_one_le_succ}, - apply pi_iff_pi, intro a, transitivity _, apply IH, - transitivity _, apply pi_iff_pi, intro p, - rewrite [iterated_loop_space_loop_irrel n p], apply iff.refl, esimp, - apply imp_iff, reflexivity} - end - - theorem is_trunc_iff_is_contr_loop (n : ℕ) (A : Type) - : is_trunc (n.-2.+1) A ↔ (Π(a : A), is_contr (Ω[n](pointed.Mk a))) := - begin - induction n with n, - { esimp [sub_two,iterated_ploop_space], apply iff.intro, - intro H a, exact is_contr_of_inhabited_prop a, - intro H, apply is_prop_of_imp_is_contr, exact H}, - { apply is_trunc_iff_is_contr_loop_succ}, - end - - theorem is_contr_loop_of_is_trunc (n : ℕ) (A : Type*) [H : is_trunc (n.-2.+1) A] : - is_contr (Ω[n] A) := - begin - induction A, - apply iff.mp !is_trunc_iff_is_contr_loop H - end - - theorem is_trunc_loop_of_is_trunc (n : ℕ₋₂) (k : ℕ) (A : Type*) [H : is_trunc n A] : - is_trunc n (Ω[k] A) := - begin - induction k with k IH, - { exact H}, - { apply is_trunc_eq} - end - -end is_trunc open is_trunc - -namespace trunc - variable {A : Type} - - protected definition code (n : ℕ₋₂) (aa aa' : trunc n.+1 A) : n-Type := - trunc.rec_on aa (λa, trunc.rec_on aa' (λa', trunctype.mk' n (trunc n (a = a')))) - - protected definition encode (n : ℕ₋₂) (aa aa' : trunc n.+1 A) : aa = aa' → trunc.code n aa aa' := - begin - intro p, induction p, induction aa with a, esimp [trunc.code,trunc.rec_on], exact (tr idp) - end - - protected definition decode (n : ℕ₋₂) (aa aa' : trunc n.+1 A) : trunc.code n aa aa' → aa = aa' := - begin - induction aa' with a', induction aa with a, - esimp [trunc.code, trunc.rec_on], intro x, - induction x with p, exact ap tr p, - end - - definition trunc_eq_equiv [constructor] (n : ℕ₋₂) (aa aa' : trunc n.+1 A) - : aa = aa' ≃ trunc.code n aa aa' := - begin - fapply equiv.MK, - { apply trunc.encode}, - { apply trunc.decode}, - { eapply (trunc.rec_on aa'), eapply (trunc.rec_on aa), - intro a a' x, esimp [trunc.code, trunc.rec_on] at x, - refine (@trunc.rec_on n _ _ x _ _), - intro x, apply is_trunc_eq, - intro p, induction p, reflexivity}, - { intro p, induction p, apply (trunc.rec_on aa), intro a, exact idp}, - end - - definition tr_eq_tr_equiv [constructor] (n : ℕ₋₂) (a a' : A) - : (tr a = tr a' :> trunc n.+1 A) ≃ trunc n (a = a') := - !trunc_eq_equiv - - definition is_trunc_trunc_of_is_trunc [instance] [priority 500] (A : Type) - (n m : ℕ₋₂) [H : is_trunc n A] : is_trunc n (trunc m A) := - begin - revert A m H, eapply (trunc_index.rec_on n), - { clear n, intro A m H, apply is_contr_equiv_closed, - { apply equiv.symm, apply trunc_equiv, apply (@is_trunc_of_le _ -2), apply minus_two_le} }, - { clear n, intro n IH A m H, induction m with m, - { apply (@is_trunc_of_le _ -2), apply minus_two_le}, - { apply is_trunc_succ_intro, intro aa aa', - apply (@trunc.rec_on _ _ _ aa (λy, !is_trunc_succ_of_is_prop)), - eapply (@trunc.rec_on _ _ _ aa' (λy, !is_trunc_succ_of_is_prop)), - intro a a', apply (is_trunc_equiv_closed_rev), - { apply tr_eq_tr_equiv}, - { exact (IH _ _ _)}}} - end - - definition unique_choice {P : A → Type} [H : Πa, is_prop (P a)] (f : Πa, ∥ P a ∥) (a : A) - : P a := - !trunc_equiv (f a) - - /- transport over a truncated family -/ - definition trunc_transport {a a' : A} {P : A → Type} (p : a = a') (n : ℕ₋₂) (x : P a) - : transport (λa, trunc n (P a)) p (tr x) = tr (p ▸ x) := - by induction p; reflexivity - - definition trunc_trunc_equiv_left [constructor] (A : Type) (n m : ℕ₋₂) (H : n ≤ m) - : trunc n (trunc m A) ≃ trunc n A := - begin - note H2 := is_trunc_of_le (trunc n A) H, - fapply equiv.MK, - { intro x, induction x with x, induction x with x, exact tr x}, - { intro x, induction x with x, exact tr (tr x)}, - { intro x, induction x with x, reflexivity}, - { intro x, induction x with x, induction x with x, reflexivity} - end - - definition trunc_trunc_equiv_right [constructor] (A : Type) (n m : ℕ₋₂) (H : n ≤ m) - : trunc m (trunc n A) ≃ trunc n A := - begin - apply trunc_equiv, - exact is_trunc_of_le _ H, - end - - definition image [constructor] {A B : Type} (f : A → B) (b : B) : Prop := ∥ fiber f b ∥ - - definition image.mk [constructor] {A B : Type} {f : A → B} {b : B} (a : A) (p : f a = b) - : image f b := - tr (fiber.mk a p) - - -- truncation of pointed types - definition ptrunc [constructor] (n : ℕ₋₂) (X : Type*) : n-Type* := - ptrunctype.mk (trunc n X) _ (tr pt) - - definition ptrunc_functor [constructor] {X Y : Type*} (n : ℕ₋₂) (f : X →* Y) - : ptrunc n X →* ptrunc n Y := - pmap.mk (trunc_functor n f) (ap tr (respect_pt f)) - - definition ptrunc_pequiv [constructor] (n : ℕ₋₂) {X Y : Type*} (H : X ≃* Y) - : ptrunc n X ≃* ptrunc n Y := - pequiv_of_equiv (trunc_equiv_trunc n H) (ap tr (respect_pt H)) - - definition loop_ptrunc_pequiv [constructor] (n : ℕ₋₂) (A : Type*) : - Ω (ptrunc (n+1) A) ≃* ptrunc n (Ω A) := - pequiv_of_equiv !tr_eq_tr_equiv idp - - definition iterated_loop_ptrunc_pequiv [constructor] (n : ℕ₋₂) (k : ℕ) (A : Type*) : - Ω[k] (ptrunc (n+k) A) ≃* ptrunc n (Ω[k] A) := - begin - revert n, induction k with k IH: intro n, - { reflexivity}, - { refine _ ⬝e* loop_ptrunc_pequiv n (Ω[k] A), - rewrite [iterated_ploop_space_succ], apply loop_pequiv_loop, - refine _ ⬝e* IH (n.+1), - rewrite succ_add_nat} - end - - definition ptrunc_functor_pcompose [constructor] {X Y Z : Type*} (n : ℕ₋₂) (g : Y →* Z) - (f : X →* Y) : ptrunc_functor n (g ∘* f) ~* ptrunc_functor n g ∘* ptrunc_functor n f := - begin - fapply phomotopy.mk, - { apply trunc_functor_compose}, - { esimp, refine !idp_con ⬝ _, refine whisker_right !ap_compose'⁻¹ᵖ _ ⬝ _, - esimp, refine whisker_right (ap_compose' tr g _) _ ⬝ _, exact !ap_con⁻¹}, - end - - definition ptrunc_functor_pid [constructor] (X : Type*) (n : ℕ₋₂) : - ptrunc_functor n (pid X) ~* pid (ptrunc n X) := - begin - fapply phomotopy.mk, - { apply trunc_functor_id}, - { reflexivity}, - end - - definition ptrunc_functor_pcast [constructor] {X Y : Type*} (n : ℕ₋₂) (p : X = Y) : - ptrunc_functor n (pcast p) ~* pcast (ap (ptrunc n) p) := - begin - fapply phomotopy.mk, - { intro x, esimp, refine !trunc_functor_cast ⬝ _, refine ap010 cast _ x, - refine !ap_compose'⁻¹ ⬝ !ap_compose'}, - { induction p, reflexivity}, - end - -end trunc open trunc - -namespace function - variables {A B : Type} - definition is_surjective_of_is_equiv [instance] (f : A → B) [H : is_equiv f] : is_surjective f := - λb, begin esimp, apply center end - - definition is_equiv_equiv_is_embedding_times_is_surjective [constructor] (f : A → B) - : is_equiv f ≃ (is_embedding f × is_surjective f) := - equiv_of_is_prop (λH, (_, _)) - (λP, prod.rec_on P (λH₁ H₂, !is_equiv_of_is_surjective_of_is_embedding)) - -end function diff --git a/hott/types/type_functor.hlean b/hott/types/type_functor.hlean deleted file mode 100644 index 2e7465e236..0000000000 --- a/hott/types/type_functor.hlean +++ /dev/null @@ -1,56 +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 - -Pointed and unpointed type functor, and adjoint pairs. -More or less ported from Evan Cavallo's HoTT-Agda homotopy library. --/ - -import types.pointed - -open equiv function pointed - -structure type_functor : Type := - (fun_ty : Type → Type) - (fun_arr : Π {A B}, (A → B) → (fun_ty A → fun_ty B)) - (respect_id : Π {A}, fun_arr (@id A) = id) - (respect_comp : Π {A B C} (g : B → C) (f : A → B), - fun_arr (g ∘ f) = (fun_arr g) ∘ (fun_arr f)) - -attribute [coercion] type_functor.fun_ty - -section type_adjoint -open type_functor - -structure type_adjoint (F G : type_functor) : Type := - (η : Π X, X → G (F X)) - (ε : Π U, F (G U) → U) - (ηnat : Π X Y (h : X → Y), η Y ∘ h = fun_arr G (fun_arr F h) ∘ η X) - (εnat : Π U V (k : U → V), ε V ∘ fun_arr F (fun_arr G k) = k ∘ ε U) - (εF_Fη : Π X, ε (F X) ∘ fun_arr F (η X) = id) - (Gε_ηG : Π U, fun_arr G (ε U) ∘ η (G U) = id) - -end type_adjoint - -structure Type_functor : Type := - (fun_ty : Type* → Type*) - (fun_arr : Π {A B}, (A →* B) → (fun_ty A →* fun_ty B)) - (respect_id : Π {A}, fun_arr (pid A) = pid (fun_ty A)) - (respect_comp : Π {A B C} (g : B →* C) (f : A →* B), - fun_arr (g ∘* f) = fun_arr g ∘* fun_arr f) - -attribute [coercion] Type_functor.fun_ty - -section Type_adjoint -open Type_functor - -structure Type_adjoint (F G : Type_functor) : Type := - (η : Π (X : Type*), X →* G (F X)) - (ε : Π (U : Type*), F (G U) →* U) - (ηnat : Π {X Y} (h : X →* Y), η Y ∘* h = (fun_arr G (fun_arr F h)) ∘* η X) - (εnat : Π {U V} (k : U →* V), ε V ∘* (fun_arr F (fun_arr G k)) = k ∘* ε U) - (εF_Fη : Π {X}, ε (F X) ∘* (fun_arr F (η X)) = !pid) - (Gε_ηG : Π {U}, (fun_arr G (ε U)) ∘* η (G U) = !pid) - -end Type_adjoint diff --git a/hott/types/types.md b/hott/types/types.md deleted file mode 100644 index 61e07185ef..0000000000 --- a/hott/types/types.md +++ /dev/null @@ -1,33 +0,0 @@ -hott.types -========== - -Types in Martin-Lӧf Type Theory: - -* [unit](unit.hlean) -* [bool](bool.hlean) -* [num](num.hlean) (natural numbers written in binary form) -* [nat](nat/nat.md) (subfolder) -* [int](int/int.md) (subfolder) -* [prod](prod.hlean) -* [sigma](sigma.hlean) -* [sum](sum.hlean) -* [pi](pi.hlean) -* [arrow](arrow.hlean) -* [arrow_2](arrow_2.hlean): alternative development of properties of arrows -* [W](W.hlean): W-types (not loaded by default) -* [lift](lift.hlean) -* [list](list.hlean) -* [fin](fin.hlean): finite types - -The number systems (num, nat, int, ...) are for a large part ported from the standard libary. - -Types in HoTT: - -* [eq](eq.hlean): show that functions related to the identity type are equivalences -* [pointed](pointed.hlean): pointed types, pointed maps, pointed homotopies -* [fiber](fiber.hlean) -* [equiv](equiv.hlean) -* [pointed2](pointed2.hlean): pointed equivalences and pointed truncated types (this is a separate file, because it depends on types.equiv) -* [trunc](trunc.hlean): truncation levels, n-types, truncation -* [pullback](pullback.hlean) -* [univ](univ.hlean) \ No newline at end of file diff --git a/hott/types/unit.hlean b/hott/types/unit.hlean deleted file mode 100644 index 7ce4d19ffc..0000000000 --- a/hott/types/unit.hlean +++ /dev/null @@ -1,30 +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 - -Theorems about the unit type --/ - -open equiv option eq - -namespace unit - - protected definition eta : Π(u : unit), ⋆ = u - | eta ⋆ := idp - - definition unit_equiv_option_empty [constructor] : unit ≃ option empty := - begin - fapply equiv.MK, - { intro u, exact none}, - { intro e, exact star}, - { intro e, cases e, reflexivity, contradiction}, - { intro u, cases u, reflexivity}, - end - - -- equivalences involving unit and other type constructors are in the file - -- of the other constructor - -end unit - -open unit is_trunc diff --git a/hott/types/univ.hlean b/hott/types/univ.hlean deleted file mode 100644 index bf396ba674..0000000000 --- a/hott/types/univ.hlean +++ /dev/null @@ -1,129 +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 the universe --/ - --- see also init.ua - -import .bool .trunc .lift .pullback - -open is_trunc bool lift unit eq pi equiv sum sigma fiber prod pullback is_equiv sigma.ops - pointed -namespace univ - - universe variables u v - variables {A B : Type.{u}} {a : A} {b : B} - - /- Pathovers -/ - - definition eq_of_pathover_ua {f : A ≃ B} (p : a =[ua f] b) : f a = b := - !cast_ua⁻¹ ⬝ tr_eq_of_pathover p - - definition pathover_ua {f : A ≃ B} (p : f a = b) : a =[ua f] b := - pathover_of_tr_eq (!cast_ua ⬝ p) - - definition pathover_ua_equiv (f : A ≃ B) : (a =[ua f] b) ≃ (f a = b) := - equiv.MK eq_of_pathover_ua - pathover_ua - abstract begin - intro p, unfold [pathover_ua,eq_of_pathover_ua], - rewrite [to_right_inv !pathover_equiv_tr_eq, inv_con_cancel_left] - end end - abstract begin - intro p, unfold [pathover_ua,eq_of_pathover_ua], - rewrite [con_inv_cancel_left, to_left_inv !pathover_equiv_tr_eq] - end end - - /- Properties which can be disproven for the universe -/ - - definition not_is_set_type0 : ¬is_set Type₀ := - assume H : is_set Type₀, - absurd !is_set.elim eq_bnot_ne_idp - - definition not_is_set_type : ¬is_set Type.{u} := - assume H : is_set Type, - absurd (is_trunc_is_embedding_closed lift !trunc_index.minus_one_le_succ) not_is_set_type0 - - definition not_double_negation_elimination0 : ¬Π(A : Type₀), ¬¬A → A := - begin - intro f, - have u : ¬¬bool, by exact (λg, g tt), - let H1 := apdo f eq_bnot, - note H2 := apo10 H1 u, - have p : eq_bnot ▸ u = u, from !is_prop.elim, - rewrite p at H2, - note H3 := eq_of_pathover_ua H2, esimp at H3, --TODO: use apply ... at after #700 - exact absurd H3 (bnot_ne (f bool u)), - end - - definition not_double_negation_elimination : ¬Π(A : Type), ¬¬A → A := - begin - intro f, - apply not_double_negation_elimination0, - intro A nna, refine down (f _ _), - intro na, - have ¬A, begin intro a, exact absurd (up a) na end, - exact absurd this nna - end - - definition not_excluded_middle : ¬Π(A : Type), A + ¬A := - begin - intro f, - apply not_double_negation_elimination, - intro A nna, - induction (f A) with a na, - exact a, - exact absurd na nna - end - - definition characteristic_map [unfold 2] {B : Type.{u}} (p : Σ(A : Type.{max u v}), A → B) - (b : B) : Type.{max u v} := - by induction p with A f; exact fiber f b - - definition characteristic_map_inv [unfold 2] {B : Type.{u}} (P : B → Type.{max u v}) : - Σ(A : Type.{max u v}), A → B := - ⟨(Σb, P b), pr1⟩ - - definition sigma_arrow_equiv_arrow_univ [constructor] (B : Type.{u}) : - (Σ(A : Type.{max u v}), A → B) ≃ (B → Type.{max u v}) := - begin - fapply equiv.MK, - { exact characteristic_map}, - { exact characteristic_map_inv}, - { intro P, apply eq_of_homotopy, intro b, esimp, apply ua, apply fiber_pr1}, - { intro p, induction p with A f, fapply sigma_eq: esimp, - { apply ua, apply sigma_fiber_equiv }, - { apply arrow_pathover_constant_right, intro v, - rewrite [-cast_def _ v, cast_ua_fn], - esimp [sigma_fiber_equiv,equiv.trans,equiv.symm,sigma_comm_equiv,comm_equiv_unc], - induction v with b w, induction w with a p, esimp, exact p⁻¹}} - end - - definition is_object_classifier (f : A → B) - : pullback_square (pointed_fiber f) (fiber f) f pType.carrier := - pullback_square.mk - (λa, idp) - (is_equiv_of_equiv_of_homotopy - (calc - A ≃ Σb, fiber f b : sigma_fiber_equiv - ... ≃ Σb (v : ΣX, X = fiber f b), v.1 : sigma_equiv_sigma_right - (λb, !sigma_equiv_of_is_contr_left) - ... ≃ Σb X (p : X = fiber f b), X : sigma_equiv_sigma_right - (λb, !sigma_assoc_equiv) - ... ≃ Σb X (x : X), X = fiber f b : sigma_equiv_sigma_right - (λb, sigma_equiv_sigma_right - (λX, !comm_equiv_nondep)) - ... ≃ Σb (v : ΣX, X), v.1 = fiber f b : sigma_equiv_sigma_right - (λb, !sigma_assoc_equiv⁻¹ᵉ) - ... ≃ Σb (Y : Type*), Y = fiber f b : sigma_equiv_sigma_right - (λb, sigma_equiv_sigma (pType.sigma_char)⁻¹ᵉ - (λv, sigma.rec_on v (λx y, equiv.refl))) - ... ≃ Σ(Y : Type*) b, Y = fiber f b : sigma_comm_equiv - ... ≃ pullback pType.carrier (fiber f) : !pullback.sigma_char⁻¹ᵉ - ) - proof λb, idp qed) - -end univ diff --git a/library/init/meta/environment.lean b/library/init/meta/environment.lean index b4bf39739d..c32492b910 100644 --- a/library/init/meta/environment.lean +++ b/library/init/meta/environment.lean @@ -11,8 +11,6 @@ meta constant environment : Type namespace environment /- Create a standard environment using the given trust level -/ meta constant mk_std : nat → environment -/- Create a HoTT environment -/ -meta constant mk_hott : nat → environment /- Return the trust level of the given environment -/ meta constant trust_lvl : environment → nat /- Return tt iff it is a standard environment -/ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 5699653f27..f2c93dd40a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -32,7 +32,7 @@ option(CROSS_COMPILE "CROSS_COMPILE" OFF) option(CONSERVE_MEMORY "CONSERVE_MEMORY" OFF) # Include MSYS2 required DLLs and binaries in the binary distribution package option(INCLUDE_MSYS2_DLLS "INCLUDE_MSYS2_DLLS" OFF) -# When ON we add lean binary dependency to standard and HOTT libraries +# When ON we add lean binary dependency to standard option(LEAN_BIN_DEP "LEAN_BIN_DEP" ON) # When ON we include githash in the version string option(USE_GITHASH "GIT_HASH" ON) @@ -325,8 +325,6 @@ add_subdirectory(kernel/inductive) set(LEAN_OBJS ${LEAN_OBJS} $) add_subdirectory(kernel/quotient) set(LEAN_OBJS ${LEAN_OBJS} $) -add_subdirectory(kernel/hits) -set(LEAN_OBJS ${LEAN_OBJS} $) add_subdirectory(library) set(LEAN_OBJS ${LEAN_OBJS} $) add_subdirectory(library/tactic) @@ -439,12 +437,6 @@ else() DEPENDS "${CMAKE_BINARY_DIR}/shell/lean" WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../library" ) - # add_custom_target( - # hott_lib ALL - # COMMAND "${PYTHON_EXECUTABLE}" "${LEAN_SOURCE_DIR}/../bin/linja" all - # DEPENDS "${CMAKE_BINARY_DIR}/shell/lean" - # WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../hott" - # ) endif() add_custom_target(clean-std-lib @@ -452,13 +444,8 @@ add_custom_target(clean-std-lib COMMAND "${CMAKE_COMMAND}" -P "${CMAKE_MODULE_PATH}/CleanOlean.cmake" ) -add_custom_target(clean-hott-lib - WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../hott" - COMMAND "${CMAKE_COMMAND}" -P "${CMAKE_MODULE_PATH}/CleanOlean.cmake" - ) - add_custom_target(clean-olean - DEPENDS clean-std-lib clean-hott-lib) + DEPENDS clean-std-lib) install(FILES "${CMAKE_SOURCE_DIR}/../bin/linja" DESTINATION bin diff --git a/src/api/env.cpp b/src/api/env.cpp index e1fc1e42d6..4f033614c1 100644 --- a/src/api/env.cpp +++ b/src/api/env.cpp @@ -6,7 +6,6 @@ Author: Leonardo de Moura */ #include "kernel/environment.h" #include "library/standard_kernel.h" -#include "library/hott_kernel.h" #include "library/module.h" #include "api/decl.h" #include "api/string.h" @@ -20,12 +19,6 @@ lean_bool lean_env_mk_std(unsigned t, lean_env * r, lean_exception * ex) { LEAN_CATCH; } -lean_bool lean_env_mk_hott(unsigned t, lean_env * r, lean_exception * ex) { - LEAN_TRY; - *r = of_env(new environment(mk_hott_environment(t))); - LEAN_CATCH; -} - lean_bool lean_env_add_univ(lean_env e, lean_name u, lean_env * r, lean_exception * ex) { LEAN_TRY; check_nonnull(e); diff --git a/src/api/lean_env.h b/src/api/lean_env.h index d30cdae2cf..15dbdf2344 100644 --- a/src/api/lean_env.h +++ b/src/api/lean_env.h @@ -24,8 +24,6 @@ extern "C" { /** \brief Create a standard environment (i.e., proof irrelevant, and containing an impredicative Prop) with trust level \c t. If the trust level is 0, then all imported modules are retype-checked, and declarations containing macros are rejected. */ lean_bool lean_env_mk_std(unsigned t, lean_env * r, lean_exception * ex); -/** \brief Create a HoTT environment (i.e., proof relevant, no Prop) with trust level \c t. */ -lean_bool lean_env_mk_hott(unsigned t, lean_env * r, lean_exception * ex); /** Trust all macros implemented in Lean, and do no retype-check imported modules */ #define LEAN_TRUST_HIGH 100000 diff --git a/src/frontends/lean/builtin_cmds.cpp b/src/frontends/lean/builtin_cmds.cpp index d44773e156..3252dfdcbf 100644 --- a/src/frontends/lean/builtin_cmds.cpp +++ b/src/frontends/lean/builtin_cmds.cpp @@ -377,12 +377,6 @@ static environment init_quotient_cmd(parser & p) { return module::declare_quotient(p.env()); } -static environment init_hits_cmd(parser & p) { - if (p.env().prop_proof_irrel() || p.env().impredicative()) - throw parser_error("invalid init_hits command, this command is only available for proof relevant and predicative kernels", p.cmd_pos()); - return module::declare_hits(p.env()); -} - // register_simp_ext ([priority ]) static environment register_simp_ext_cmd(parser & p) { environment env = p.env(); @@ -584,7 +578,6 @@ void init_cmd_table(cmd_table & r) { add_cmd(r, cmd_info("local", "define local attributes or notation", local_cmd)); add_cmd(r, cmd_info("help", "brief description of available commands and options", help_cmd)); add_cmd(r, cmd_info("init_quotient", "initialize quotient type computational rules", init_quotient_cmd)); - add_cmd(r, cmd_info("init_hits", "initialize builtin HITs", init_hits_cmd)); add_cmd(r, cmd_info("declare_trace", "declare a new trace class (for debugging Lean tactics)", declare_trace_cmd)); add_cmd(r, cmd_info("register_simp_ext", "register simplifier extension", register_simp_ext_cmd)); add_cmd(r, cmd_info("add_key_equivalence", "register that to symbols are equivalence for key-matching", add_key_equivalence_cmd)); diff --git a/src/frontends/lean/print_cmd.cpp b/src/frontends/lean/print_cmd.cpp index ffc4fa222c..d95bb40750 100644 --- a/src/frontends/lean/print_cmd.cpp +++ b/src/frontends/lean/print_cmd.cpp @@ -11,7 +11,6 @@ Author: Leonardo de Moura #include "kernel/for_each_fn.h" #include "kernel/inductive/inductive.h" #include "kernel/quotient/quotient.h" -#include "kernel/hits/hits.h" #include "library/util.h" #include "library/class.h" #include "library/aliases.h" @@ -383,8 +382,6 @@ bool print_id_info(parser & p, name const & id, bool show_value, pos_info const print_constant(p, "eliminator", d); } else if (is_quotient_decl(env, c)) { print_constant(p, "builtin-quotient-type-constant", d); - } else if (is_hits_decl(env, c)) { - print_constant(p, "builtin-HIT-constant", d); } else if (d.is_axiom()) { print_constant(p, "axiom", d); } else { diff --git a/src/init/init.cpp b/src/init/init.cpp index affeb2e67d..e5cbf3f63c 100644 --- a/src/init/init.cpp +++ b/src/init/init.cpp @@ -12,7 +12,6 @@ Author: Leonardo de Moura #include "kernel/init_module.h" #include "kernel/inductive/inductive.h" #include "kernel/quotient/quotient.h" -#include "kernel/hits/hits.h" #include "library/init_module.h" #include "library/tactic/init_module.h" #include "library/constructions/init_module.h" @@ -34,7 +33,6 @@ void initialize() { initialize_kernel_module(); initialize_inductive_module(); initialize_quotient_module(); - initialize_hits_module(); init_default_print_fn(); initialize_library_core_module(); initialize_vm_core_module(); @@ -61,7 +59,6 @@ void finalize() { finalize_library_module(); finalize_vm_core_module(); finalize_library_core_module(); - finalize_hits_module(); finalize_quotient_module(); finalize_inductive_module(); finalize_kernel_module(); diff --git a/src/kernel/hits/CMakeLists.txt b/src/kernel/hits/CMakeLists.txt deleted file mode 100644 index 6e447bec0e..0000000000 --- a/src/kernel/hits/CMakeLists.txt +++ /dev/null @@ -1 +0,0 @@ -add_library(hits OBJECT hits.cpp) diff --git a/src/kernel/hits/hits.cpp b/src/kernel/hits/hits.cpp deleted file mode 100644 index 2299aaea35..0000000000 --- a/src/kernel/hits/hits.cpp +++ /dev/null @@ -1,176 +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 - -Builtin HITs: - - n-truncation - - type quotients (non-truncated quotients) -*/ -#include "util/sstream.h" -#include "kernel/kernel_exception.h" -#include "kernel/environment.h" -#include "kernel/abstract_type_context.h" -#include "kernel/hits/hits.h" - -namespace lean { -static name * g_hits_extension = nullptr; -static name * g_trunc = nullptr; -static name * g_trunc_tr = nullptr; -static name * g_trunc_rec = nullptr; -static name * g_trunc_is_trunc_trunc = nullptr; -static name * g_hit_quotient = nullptr; -static name * g_hit_quotient_class_of = nullptr; -static name * g_hit_quotient_rec = nullptr; -static name * g_hit_quotient_eq_of_rel = nullptr; -static name * g_hit_quotient_rec_eq_of_rel = nullptr; - -struct hits_env_ext : public environment_extension { - bool m_initialized; - hits_env_ext():m_initialized(false){} -}; - -/** \brief Auxiliary object for registering the environment extension */ -struct hits_env_ext_reg { - unsigned m_ext_id; - hits_env_ext_reg() { m_ext_id = environment::register_extension(std::make_shared()); } -}; - -static hits_env_ext_reg * g_ext = nullptr; - -/** \brief Retrieve environment extension */ -static hits_env_ext const & get_extension(environment const & env) { - return static_cast(env.get_extension(g_ext->m_ext_id)); -} - -/** \brief Update environment extension */ -static environment update(environment const & env, hits_env_ext const & ext) { - return env.update(g_ext->m_ext_id, std::make_shared(ext)); -} - -environment declare_hits(environment const & env) { - hits_env_ext ext = get_extension(env); - ext.m_initialized = true; - return update(env, ext); -} - -optional hits_normalizer_extension::operator()(expr const & e, abstract_type_context & ctx) const { - environment const & env = ctx.env(); - expr const & fn = get_app_fn(e); - if (!is_constant(fn)) - return none_expr(); - hits_env_ext const & ext = get_extension(env); - if (!ext.m_initialized) - return none_expr(); - unsigned mk_pos; - name * mk_name; - unsigned f_pos; - if (const_name(fn) == *g_trunc_rec) { - mk_pos = 5; - mk_name = g_trunc_tr; - f_pos = 4; - } else if (const_name(fn) == *g_hit_quotient_rec) { - mk_pos = 5; - mk_name = g_hit_quotient_class_of; - f_pos = 3; - } else { - return none_expr(); - } - - buffer args; - get_app_args(e, args); - if (args.size() <= mk_pos) - return none_expr(); - - expr mk = ctx.whnf(args[mk_pos]); - expr const & mk_fn = get_app_fn(mk); - if (!is_constant(mk_fn)) - return none_expr(); - if (const_name(mk_fn) != *mk_name) - return none_expr(); - - expr const & f = args[f_pos]; - expr r = mk_app(f, app_arg(mk)); - unsigned elim_arity = mk_pos+1; - if (args.size() > elim_arity) - r = mk_app(r, args.size() - elim_arity, args.begin() + elim_arity); - return some_expr(r); -} - -template -optional is_hits_meta_app_core(Ctx & ctx, expr const & e) { - expr const & fn = get_app_fn(e); - if (!is_constant(fn)) - return none_expr(); - unsigned mk_pos; - if (const_name(fn) == *g_trunc_rec) { - mk_pos = 5; - } else if (const_name(fn) == *g_hit_quotient_rec) { - mk_pos = 5; - } else { - return none_expr(); - } - - buffer args; - get_app_args(e, args); - if (args.size() <= mk_pos) - return none_expr(); - - expr mk_app = ctx.whnf(args[mk_pos]); - return ctx.is_stuck(mk_app); -} - -optional hits_normalizer_extension::is_stuck(expr const & e, abstract_type_context & ctx) const { - return is_hits_meta_app_core(ctx, e); -} - -bool hits_normalizer_extension::supports(name const & feature) const { - return feature == *g_hits_extension; -} - -bool hits_normalizer_extension::is_recursor(environment const &, name const & n) const { - return n == *g_trunc_rec || n == *g_hit_quotient_rec; -} - -bool hits_normalizer_extension::is_builtin(environment const & env, name const & n) const { - return is_hits_decl(env, n); -} - -bool is_hits_decl(environment const & env, name const & n) { - if (!get_extension(env).m_initialized) - return false; - return - n == *g_trunc || n == *g_trunc_tr || n == *g_trunc_rec || - n == *g_hit_quotient || n == *g_hit_quotient_class_of || - n == *g_hit_quotient_rec; -} - -void initialize_hits_module() { - g_hits_extension = new name("hits_extension"); - g_trunc = new name{"trunc"}; - g_trunc_tr = new name{"trunc", "tr"}; - g_trunc_rec = new name{"trunc", "rec"}; - g_trunc_is_trunc_trunc = new name{"trunc", "is_trunc_trunc"}; - g_hit_quotient = new name{"quotient"}; - g_hit_quotient_class_of = new name{"quotient", "class_of"}; - g_hit_quotient_rec = new name{"quotient", "rec"}; - g_hit_quotient_eq_of_rel = new name{"quotient", "eq_of_rel"}; - g_hit_quotient_rec_eq_of_rel = new name{"quotient", "rec_eq_of_rel"}; - g_ext = new hits_env_ext_reg(); -} - -void finalize_hits_module() { - delete g_ext; - delete g_hits_extension; - delete g_trunc; - delete g_trunc_tr; - delete g_trunc_rec; - delete g_trunc_is_trunc_trunc; - delete g_hit_quotient; - delete g_hit_quotient_class_of; - delete g_hit_quotient_rec; - delete g_hit_quotient_eq_of_rel; - delete g_hit_quotient_rec_eq_of_rel; -} -} diff --git a/src/kernel/hits/hits.h b/src/kernel/hits/hits.h deleted file mode 100644 index 08d5c072d1..0000000000 --- a/src/kernel/hits/hits.h +++ /dev/null @@ -1,30 +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 - -Builtin HITs: - - n-truncation - - type quotients (non-truncated quotients) -*/ -#pragma once - -namespace lean { -/** \brief Normalizer extension for applying builtin HITs computational rules. */ -class hits_normalizer_extension : public normalizer_extension { -public: - virtual optional operator()(expr const & e, abstract_type_context & ctx) const; - virtual optional is_stuck(expr const & e, abstract_type_context & ctx) const; - virtual bool supports(name const & feature) const; - virtual bool is_recursor(environment const & env, name const & n) const; - virtual bool is_builtin(environment const & env, name const & n) const; -}; - -/** \brief The following function must be invoked to register the builtin HITs computation rules in the kernel. */ -environment declare_hits(environment const & env); -/** \brief Return true iff \c n is one of the HITs builtin constants. */ -bool is_hits_decl(environment const & env, name const & n); -void initialize_hits_module(); -void finalize_hits_module(); -} diff --git a/src/library/CMakeLists.txt b/src/library/CMakeLists.txt index 72b049fb4a..b2e38aeee2 100644 --- a/src/library/CMakeLists.txt +++ b/src/library/CMakeLists.txt @@ -6,7 +6,7 @@ add_library(library OBJECT deep_copy.cpp expr_lt.cpp io_state.cpp explicit.cpp num.cpp string.cpp head_map.cpp definition_cache.cpp class.cpp util.cpp print.cpp annotation.cpp quote.cpp typed_expr.cpp protected.cpp reducible.cpp init_module.cpp - exception.cpp fingerprint.cpp flycheck.cpp hott_kernel.cpp pp_options.cpp + exception.cpp fingerprint.cpp flycheck.cpp pp_options.cpp unfold_macros.cpp app_builder.cpp projection.cpp relation_manager.cpp export.cpp user_recursors.cpp idx_metavar.cpp noncomputable.cpp aux_recursors.cpp norm_num.cpp trace.cpp diff --git a/src/library/hott_kernel.cpp b/src/library/hott_kernel.cpp deleted file mode 100644 index 058ad2f62e..0000000000 --- a/src/library/hott_kernel.cpp +++ /dev/null @@ -1,22 +0,0 @@ -/* -Copyright (c) 2014-2015 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. - -Author: Leonardo de Moura -*/ -#include "kernel/inductive/inductive.h" -#include "kernel/hits/hits.h" - -namespace lean { -using inductive::inductive_normalizer_extension; -/** \brief Create Lean environment for Homotopy Type Theory */ -environment mk_hott_environment(unsigned trust_lvl) { - return environment(trust_lvl, - false /* Type.{0} is not proof irrelevant */, - true /* Eta */, - false /* Type.{0} is not impredicative */, - /* builtin support for inductive and hits */ - compose(std::unique_ptr(new inductive_normalizer_extension()), - std::unique_ptr(new hits_normalizer_extension()))); -} -} diff --git a/src/library/hott_kernel.h b/src/library/hott_kernel.h deleted file mode 100644 index 7b7f119a73..0000000000 --- a/src/library/hott_kernel.h +++ /dev/null @@ -1,13 +0,0 @@ -/* -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. - -Author: Leonardo de Moura -*/ -#pragma once -#include "kernel/environment.h" - -namespace lean { -/** \brief Create Lean environment for Homotopy Type Theory */ -environment mk_hott_environment(unsigned trust_lvl = 0); -} diff --git a/src/library/module.cpp b/src/library/module.cpp index cffe4e72f7..a6d648e981 100644 --- a/src/library/module.cpp +++ b/src/library/module.cpp @@ -22,7 +22,6 @@ Author: Leonardo de Moura #include "util/file_lock.h" #include "kernel/type_checker.h" #include "kernel/quotient/quotient.h" -#include "kernel/hits/hits.h" #include "library/module.h" #include "library/noncomputable.h" #include "library/sorry.h" @@ -182,7 +181,6 @@ static std::string * g_glvl_key = nullptr; static std::string * g_decl_key = nullptr; static std::string * g_inductive = nullptr; static std::string * g_quotient = nullptr; -static std::string * g_hits = nullptr; namespace module { environment add(environment const & env, std::string const & k, std::function const & wr) { @@ -245,19 +243,6 @@ static void quotient_reader(deserializer &, shared_environment & senv, }); } -environment declare_hits(environment const & env) { - environment new_env = ::lean::declare_hits(env); - return add(new_env, *g_hits, [=](environment const &, serializer &) {}); -} - -static void hits_reader(deserializer &, shared_environment & senv, - std::function &, - std::function &) { - senv.update([&](environment const & env) { - return ::lean::declare_hits(env); - }); -} - using inductive::certified_inductive_decl; environment add_inductive(environment env, @@ -627,16 +612,13 @@ void initialize_module() { g_decl_key = new std::string("decl"); g_inductive = new std::string("ind"); g_quotient = new std::string("quot"); - g_hits = new std::string("hits"); register_module_object_reader(*g_inductive, module::inductive_reader); register_module_object_reader(*g_quotient, module::quotient_reader); - register_module_object_reader(*g_hits, module::hits_reader); } void finalize_module() { delete g_inductive; delete g_quotient; - delete g_hits; delete g_decl_key; delete g_glvl_key; delete g_object_readers; diff --git a/src/library/vm/vm_environment.cpp b/src/library/vm/vm_environment.cpp index e063d97150..0e2a3d9b7f 100644 --- a/src/library/vm/vm_environment.cpp +++ b/src/library/vm/vm_environment.cpp @@ -7,7 +7,6 @@ Author: Leonardo de Moura #include "kernel/type_checker.h" #include "kernel/inductive/inductive.h" #include "library/standard_kernel.h" -#include "library/hott_kernel.h" #include "library/module.h" #include "library/util.h" #include "library/relation_manager.h" @@ -42,10 +41,6 @@ vm_obj environment_mk_std(vm_obj const & l) { return to_obj(mk_environment(force_to_unsigned(l, 0))); } -vm_obj environment_mk_hott(vm_obj const & l) { - return to_obj(mk_hott_environment(force_to_unsigned(l, 0))); -} - vm_obj environment_trust_lvl(vm_obj const & env) { return mk_vm_nat(to_env(env).trust_lvl()); } @@ -191,7 +186,6 @@ vm_obj environment_symm_for(vm_obj const & env, vm_obj const & n) { void initialize_vm_environment() { DECLARE_VM_BUILTIN(name({"environment", "mk_std"}), environment_mk_std); - DECLARE_VM_BUILTIN(name({"environment", "mk_hott"}), environment_mk_hott); DECLARE_VM_BUILTIN(name({"environment", "trust_lvl"}), environment_trust_lvl); DECLARE_VM_BUILTIN(name({"environment", "is_std"}), environment_is_std); DECLARE_VM_BUILTIN(name({"environment", "add"}), environment_add); diff --git a/src/shell/CMakeLists.txt b/src/shell/CMakeLists.txt index 778c2347d0..c3bd158f46 100644 --- a/src/shell/CMakeLists.txt +++ b/src/shell/CMakeLists.txt @@ -15,8 +15,6 @@ endif() add_library(shell OBJECT emscripten.cpp) # add_test(example1_stdin1 ${LEAN_SOURCE_DIR}/cmake/redirect.sh ${CMAKE_CURRENT_BINARY_DIR}/lean "${LEAN_SOURCE_DIR}/../tests/lean/single.lean") -# add_test(example1_stdin2 ${LEAN_SOURCE_DIR}/cmake/redirect.sh ${CMAKE_CURRENT_BINARY_DIR}/lean "-l" "${LEAN_SOURCE_DIR}/../tests/lean/single.lean") -# add_test(example1_stdin3 ${LEAN_SOURCE_DIR}/cmake/redirect.sh ${CMAKE_CURRENT_BINARY_DIR}/lean "--lean" "${LEAN_SOURCE_DIR}/../tests/lean/single.lean") # add_test(lean_export ${CMAKE_CURRENT_BINARY_DIR}/lean "-o simple.olean" "${LEAN_SOURCE_DIR}/../tests/lean/run/simple.lean") add_test(lean_help1 "${CMAKE_CURRENT_BINARY_DIR}/lean" --help) add_test(lean_help2 "${CMAKE_CURRENT_BINARY_DIR}/lean" -h) diff --git a/src/shell/lean.cpp b/src/shell/lean.cpp index 7dabd233d3..02d1ea9866 100644 --- a/src/shell/lean.cpp +++ b/src/shell/lean.cpp @@ -26,7 +26,6 @@ Author: Leonardo de Moura #include "kernel/type_checker.h" #include "kernel/formatter.h" #include "library/standard_kernel.h" -#include "library/hott_kernel.h" #include "library/module.h" #include "library/flycheck.h" #include "library/type_context.h" @@ -51,7 +50,6 @@ using lean::io_state; using lean::io_state_stream; using lean::regular; using lean::mk_environment; -using lean::mk_hott_environment; using lean::definition_cache; using lean::pos_info; using lean::pos_info_provider; @@ -65,8 +63,6 @@ using lean::exclusive_file_lock; using lean::type_context; using lean::type_checker; -enum class input_kind { Unspecified, Lean, HLean, Trace }; - static void display_header(std::ostream & out) { out << "Lean (version " << LEAN_VERSION_MAJOR << "." << LEAN_VERSION_MINOR << "." << LEAN_VERSION_PATCH; @@ -83,11 +79,7 @@ static void display_header(std::ostream & out) { static void display_help(std::ostream & out) { display_header(out); std::cout << "Input format:\n"; - std::cout << " --lean use parser for Lean default input format for files,\n"; - std::cout << " with unknown extension (default)\n"; - std::cout << " --hlean use parser for Lean default input format \n"; - std::cout << " and use HoTT compatible kernel for files, with unknown extension\n"; - std::cout << " --smt2 use lean as an smt-solver, interpreting all files as smt2 files\n"; + std::cout << " --smt2 interpret files as SMT-Lib2 files\n"; std::cout << "Miscellaneous:\n"; std::cout << " --help -h display this message\n"; std::cout << " --version -v display version number\n"; @@ -127,25 +119,9 @@ static void display_help(std::ostream & out) { std::cout << " --export-all=file -A export final environment (and all dependencies) as textual low-level file\n"; } -static char const * get_file_extension(char const * fname) { - if (fname == 0) - return 0; - char const * last_dot = 0; - while (true) { - char const * tmp = strchr(fname, '.'); - if (tmp == 0) { - return last_dot; - } - last_dot = tmp + 1; - fname = last_dot; - } -} - static struct option g_long_options[] = { {"version", no_argument, 0, 'v'}, {"help", no_argument, 0, 'h'}, - {"lean", no_argument, 0, 'l'}, - {"hlean", no_argument, 0, 'H'}, {"smt2", no_argument, 0, 'Y'}, {"path", no_argument, 0, 'p'}, {"githash", no_argument, 0, 'g'}, @@ -178,7 +154,7 @@ static struct option g_long_options[] = { {0, 0, 0, 0} }; -#define OPT_STR "PHFdD:qlupgvhk:012t:012o:E:c:L:012O:012GZAIT:B:" +#define OPT_STR "PFdD:qupgvhk:012t:012o:E:c:L:012O:012GZAIT:B:" #if defined(LEAN_TRACK_MEMORY) #define OPT_STR2 OPT_STR "M:012" @@ -257,7 +233,6 @@ int main(int argc, char ** argv) { bool show_goal = false; bool show_hole = false; bool show_info = false; - input_kind default_k = input_kind::Unspecified; while (true) { int c = getopt_long(argc, argv, g_opt_str, g_long_options, NULL); if (c == -1) @@ -275,21 +250,10 @@ int main(int argc, char ** argv) { case 'h': display_help(std::cout); return 0; - case 'l': - default_k = input_kind::Lean; - break; - case 'H': - default_k = input_kind::HLean; - break; - case 'R': - default_k = input_kind::Trace; - break; case 'Y': smt2 = true; break; case 'p': - if (default_k == input_kind::HLean) - lean::initialize_lean_path(true); std::cout << lean::get_lean_path() << "\n"; return 0; case 's': @@ -404,35 +368,7 @@ int main(int argc, char ** argv) { return ok ? 0 : 1; } - bool has_lean = (default_k == input_kind::Lean); - bool has_hlean = (default_k == input_kind::HLean); - for (int i = optind; i < argc; i++) { - char const * ext = get_file_extension(argv[i]); - if (ext && strcmp(ext, "lean") == 0) { - has_lean = true; - if (has_hlean) { - std::cerr << ".hlean file cannot be mixed with .lean files\n"; - return 1; - } - if (default_k == input_kind::Unspecified) - default_k = input_kind::Lean; - } else if (ext && strcmp(ext, "hlean") == 0) { - has_hlean = true; - if (has_lean) { - std::cerr << ".lean file cannot be mixed with .hlean files\n"; - return 1; - } - if (default_k == input_kind::Unspecified) - default_k = input_kind::HLean; - } - } - if (default_k == input_kind::Unspecified) - default_k = input_kind::Lean; - - if (has_hlean) - lean::initialize_lean_path(true); - - environment env = has_hlean ? mk_hott_environment(trust_lvl) : mk_environment(trust_lvl); + environment env = mk_environment(trust_lvl); io_state ios(opts, lean::mk_pretty_formatter_factory()); definition_cache cache; definition_cache * cache_ptr = nullptr; @@ -461,29 +397,12 @@ int main(int argc, char ** argv) { bool ok = true; for (int i = optind; i < argc; i++) { try { - char const * ext = get_file_extension(argv[i]); - input_kind k = default_k; - if (ext) { - if (strcmp(ext, "lean") == 0) { - k = input_kind::Lean; - } else if (strcmp(ext, "hlean") == 0) { - k = input_kind::HLean; - } - } - switch (k) { - case input_kind::Lean: - case input_kind::HLean: - if (only_deps) { - if (!display_deps(env, std::cout, std::cerr, argv[i])) - ok = false; - } else if (!parse_commands(env, ios, argv[i], base_dir, false, num_threads, - cache_ptr)) { + if (only_deps) { + if (!display_deps(env, std::cout, std::cerr, argv[i])) ok = false; - } - break; - default: - lean_unreachable(); - break; + } else if (!parse_commands(env, ios, argv[i], base_dir, false, num_threads, + cache_ptr)) { + ok = false; } } catch (lean::exception & ex) { simple_pos_info_provider pp(argv[i]); diff --git a/src/tests/kernel/CMakeLists.txt b/src/tests/kernel/CMakeLists.txt index 16301ada7f..68b815820a 100644 --- a/src/tests/kernel/CMakeLists.txt +++ b/src/tests/kernel/CMakeLists.txt @@ -1,4 +1,4 @@ -set(kernel_tst_objs $ $ $ $ $ $ $ $) +set(kernel_tst_objs $ $ $ $ $ $ $) add_executable(level level.cpp ${kernel_tst_objs}) target_link_libraries(level ${EXTRA_LIBS}) add_test(level "${CMAKE_CURRENT_BINARY_DIR}/level") diff --git a/src/tests/library/CMakeLists.txt b/src/tests/library/CMakeLists.txt index 9a101dc490..238d94c40e 100644 --- a/src/tests/library/CMakeLists.txt +++ b/src/tests/library/CMakeLists.txt @@ -1,4 +1,4 @@ -set(library_tst_objs $ $ $ $ $ $ $ $) +set(library_tst_objs $ $ $ $ $ $ $) add_executable(expr_lt expr_lt.cpp ${library_tst_objs}) target_link_libraries(expr_lt ${EXTRA_LIBS}) add_test(expr_lt "${CMAKE_CURRENT_BINARY_DIR}/expr_lt")