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

feat(hott): port nat and int from the standard library

Browse source
This commit is contained in:
Floris van Doorn 2015-12-09 00:02:05 -05:00 committed by Leonardo de Moura
parent 46739c8b70
commit 2325d23f68
44 changed files with 2626 additions and 1766 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
hott/algebra/binary.hlean
View file

@ -84,3 +84,34 @@ namespace binary
{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 equiv.ops
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

11
hott/algebra/category/functor/examples.hlean
View file

@ -35,7 +35,7 @@ namespace functor
apply nat_trans_eq,
intro d, calc
natural_map (Fhom F (f' ∘ f)) d = F (f' ∘ f, id) : by esimp
... = F (f' ∘ f, id ∘ id) : by rewrite id_id
... = 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
@ -119,10 +119,11 @@ namespace functor
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 (id ∘ f, g ∘ id) : by krewrite [-respect_comp F (id,g) (f,id)]
... = F (f, g ∘ id) : by rewrite id_left
... = F (f,g) : by rewrite id_right,
(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)

15
hott/algebra/field.hlean
View file

@ -3,7 +3,7 @@ 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.
Structures with multiplicative prod additive components, including division rings prod fields.
The development is modeled after Isabelle's library.
-/
import algebra.binary algebra.group algebra.ring
@ -73,7 +73,7 @@ section division_ring
absurd C1 Ha
theorem mul_ne_zero_comm (H : a * b ≠ 0) : b * a ≠ 0 :=
have H2 : a ≠ 0 × b ≠ 0, from ne_zero_and_ne_zero_of_mul_ne_zero H,
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 :=
@ -222,7 +222,7 @@ section field
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_and_ne_zero_of_mul_ne_zero H),
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
@ -324,10 +324,10 @@ section discrete_field
include s
variables {a b c d : A}
-- many of the theorems in discrete_field are the same as theorems in field or division ring,
-- but with fewer hypotheses since 0⁻¹ = 0 and equality is decidable.
-- many of the theorems in discrete_field are the same as theorems in field sum division ring,
-- but with fewer hypotheses since 0⁻¹ = 0 prod equality is decidable.
theorem discrete_field.eq_zero_or_eq_zero_of_mul_eq_zero
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)
@ -337,7 +337,7 @@ section discrete_field
definition discrete_field.to_integral_domain [trans_instance] [reducible] :
integral_domain A :=
⦃ integral_domain, s,
eq_zero_or_eq_zero_of_mul_eq_zero := discrete_field.eq_zero_or_eq_zero_of_mul_eq_zero⦄
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
@ -524,5 +524,4 @@ theorem subst_into_div [s : has_div A] (a₁ b₁ a₂ b₂ v : A) (H : a₁ / b
by rewrite [H1, H2, H]
end norm_num
end algebra

14
hott/algebra/group.hlean
View file

@ -9,7 +9,7 @@ Various multiplicative and additive structures. Partially modeled on Isabelle's
import algebra.binary algebra.priority
open eq eq.ops -- note: ⁻¹ will be overloaded
open binary algebra
open binary algebra is_trunc
set_option class.force_new true
variable {A : Type}
@ -19,8 +19,11 @@ variable {A : Type}
namespace algebra
structure semigroup [class] (A : Type) extends has_mul A :=
(is_hset_carrier : is_hset A)
(mul_assoc : Πa b c, mul (mul a b) c = mul a (mul b c))
attribute semigroup.is_hset_carrier [instance]
theorem mul.assoc [s : semigroup A] (a b c : A) : a * b * c = a * (b * c) :=
!semigroup.mul_assoc
@ -57,8 +60,11 @@ abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel
/- additive semigroup -/
structure add_semigroup [class] (A : Type) extends has_add A :=
(is_hset_carrier : is_hset A)
(add_assoc : Πa b c, add (add a b) c = add a (add b c))
attribute add_semigroup.is_hset_carrier [instance]
theorem add.assoc [s : add_semigroup A] (a b c : A) : a + b + c = a + (b + c) :=
!add_semigroup.add_assoc
@ -121,7 +127,8 @@ definition add_monoid.to_monoid {A : Type} [s : add_monoid A] : monoid A :=
mul_assoc := add_monoid.add_assoc,
one := add_monoid.zero A,
mul_one := add_monoid.add_zero,
one_mul := add_monoid.zero_add
one_mul := add_monoid.zero_add,
is_hset_carrier := _
⦄
definition add_comm_monoid.to_comm_monoid {A : Type} [s : add_comm_monoid A] : comm_monoid A :=
@ -577,7 +584,8 @@ definition group_of_add_group (A : Type) [G : add_group A] : group A :=
one_mul := zero_add,
mul_one := add_zero,
inv := has_neg.neg,
mul_left_inv := add.left_inv⦄
mul_left_inv := add.left_inv,
is_hset_carrier := _⦄
namespace norm_num
reveal add.assoc

3
hott/algebra/homotopy_group.hlean
View file

@ -65,8 +65,7 @@ namespace eq
fapply Group_eq,
{ apply equiv_of_eq, exact ap (λ(X : Type*), trunc 0 X) (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, ↑[group_homotopy_group, group.to_monoid,
monoid.to_semigroup, semigroup.to_has_mul, trunc_mul], trunc_transport], apply ap tr,
rewrite [▸*,-+tr_eq_cast_ap, +trunc_transport], refine !trunc_transport ⬝ _, apply ap tr,
apply loop_space_succ_eq_in_concat end end},
end

13
hott/algebra/hott.hlean
View file

@ -6,11 +6,20 @@ Author: Floris van Doorn
Theorems about algebra specific to HoTT
-/
import .group arity types.pi hprop_trunc types.unit
import .group arity types.pi hprop_trunc types.unit .bundled
open equiv eq equiv.ops is_trunc
open equiv eq equiv.ops 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
notation `G0` := Trivial_group
open Group has_mul has_inv
-- we prove under which conditions two groups are equal

71
hott/algebra/order.hlean
View file

@ -3,11 +3,11 @@ 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.
Weak orders "≤", strict orders "<", prod structures that include both.
-/
import algebra.binary algebra.priority
open eq eq.ops algebra
--set_option class.force_new true
-- set_option class.force_new true
variable {A : Type}
@ -25,6 +25,8 @@ section
theorem le.refl (a : A) : a ≤ a := !weak_order.le_refl
theorem le_of_eq {a b : A} (H : a = b) : a ≤ b := H ▸ le.refl a
theorem le.trans [trans] {a b c : A} : a ≤ b → b ≤ c → a ≤ c := !weak_order.le_trans
theorem ge.trans [trans] {a b c : A} (H1 : a ≥ b) (H2: b ≥ c) : a ≥ c := le.trans H2 H1
@ -83,9 +85,7 @@ 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
definition wf.ind_on := @wf.rec_on
/- structures with a weak and a strict order -/
/- structures with a weak prod 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)
@ -126,36 +126,36 @@ section
end
structure strong_order_pair [class] (A : Type) extends weak_order A, has_lt A :=
(le_iff_lt_or_eq : Πa b, le a b ↔ lt a b ⊎ a = b)
(le_iff_lt_sum_eq : Πa b, le a b ↔ lt a b ⊎ a = b)
(lt_irrefl : Π a, ¬ lt a a)
theorem le_iff_lt_or_eq [s : strong_order_pair A] {a b : A} : a ≤ b ↔ a < b ⊎ a = b :=
!strong_order_pair.le_iff_lt_or_eq
theorem 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_or_eq_of_le [s : strong_order_pair A] {a b : A} (le_ab : a ≤ b) : a < b ⊎ a = b :=
iff.mp le_iff_lt_or_eq le_ab
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_or_eq [s : strong_order_pair A] {a b : A} (lt_or_eq : a < b ⊎ a = b) : a ≤ b :=
iff.mpr le_iff_lt_or_eq lt_or_eq
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 theorem 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_or_eq (sum.inl Hlt)
take Hlt, le_of_lt_sum_eq (sum.inl Hlt)
private theorem lt_iff_le_and_ne [s : strong_order_pair A] {a b : A} : a < b ↔ (a ≤ b × a ≠ b) :=
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_or_eq (sum.inl Hlt)) (take Hab, absurd (Hab ▸ Hlt) !lt_irrefl'))
(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_or_eq_of_le (prod.pr1 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_and_ne (pair H1 H2)
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_and_ne _ _ _ _) H)
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,
@ -166,7 +166,7 @@ have ne_ac : a ≠ c, from
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_and_ne) (pair le_ac ne_ac)
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,
@ -177,7 +177,7 @@ have ne_ac : a ≠ c, from
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_and_ne) (pair le_ac ne_ac)
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] [reducible]
[s : strong_order_pair A] : order_pair A :=
@ -206,18 +206,21 @@ section
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_or_eq _ _ _ _) H) (assume H1, sum.inl H1) (assume H1, sum.inr (sum.inl H1)))
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_or_eq _ _ _ _) H)
sum.elim (iff.mp !le_iff_lt_sum_eq H)
(assume H1, sum.inr (sum.inr H1))
(assume H1, sum.inr (sum.inl (H1⁻¹))))
theorem lt.by_cases {a b : A} {P : Type}
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')
@ -227,16 +230,16 @@ section
(assume H', absurd (H' ▸ !le.refl) H)
(assume H', H')
theorem lt_or_ge : a < b ⊎ a ≥ b :=
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_or_gt : a ≤ b ⊎ a > b :=
!sum.swap (lt_or_ge b a)
theorem le_sum_gt : a ≤ b ⊎ a > b :=
!sum.swap (lt_sum_ge b a)
theorem lt_or_gt_of_ne {a b : A} (H : a ≠ b) : a < b ⊎ a > b :=
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
@ -272,12 +275,12 @@ section
(assume H : ¬ a ≤ b,
(inr (assume H1 : a = b, H (H1 ▸ !le.refl))))
theorem eq_or_lt_of_not_lt {a b : A} (H : ¬ a < b) : a = b ⊎ b < a :=
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_or_lt_of_le {a b : A} (H : a ≤ b) : a = b ⊎ a < b :=
theorem eq_sum_lt_of_le {a b : A} (H : a ≤ b) : a = b ⊎ a < b :=
begin
cases eq_or_lt_of_not_lt (not_lt_of_ge H),
cases eq_sum_lt_of_not_lt (not_lt_of_ge H),
exact sum.inl a_1⁻¹,
exact sum.inr a_1
end
@ -301,7 +304,7 @@ section
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 -/
/- these show min prod max form a lattice -/
theorem min_le_left (a b : A) : min a b ≤ a :=
by_cases
@ -339,7 +342,7 @@ section
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 -/
/- these are also proved for lattices, but with inf prod sup in place of min prod 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 :=
@ -420,12 +423,12 @@ section
/- 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_or_gt
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_or_gt
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

5
hott/algebra/ordered_field.hlean
View file

@ -5,6 +5,7 @@ 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
@ -339,7 +340,7 @@ section linear_ordered_field
apply one_div_pos_of_pos He
end
theorem exists_add_lt_and_pos_of_lt (H : b < a) : Σ c : A, b + c < a × c > 0 :=
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 (assert H2 : a + a > (b + b) + (a - b), from calc
a + a > b + a : add_lt_add_right H
@ -356,7 +357,7 @@ section linear_ordered_field
begin
apply le_of_not_gt,
intro Hb,
cases exists_add_lt_and_pos_of_lt Hb with [c, Hc],
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

8
hott/algebra/ordered_group.hlean
View file

@ -13,6 +13,7 @@ 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 :=
@ -122,7 +123,7 @@ section
!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_and_eq_zero_of_nonneg_of_nonneg
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,
@ -336,7 +337,7 @@ section
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 proof iff.symm (!add_le_add_right_iff) qed,
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 :=
@ -718,7 +719,7 @@ section
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_or_gt_of_ne H) abs_pos_of_neg abs_pos_of_pos
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)
@ -820,5 +821,4 @@ section
end
end
end algebra

16
hott/algebra/ordered_ring.hlean
View file

@ -4,16 +4,15 @@ 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
order prod an associated strict order. Our numeric structures (int, rat, prod 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
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)
@ -335,7 +334,7 @@ definition linear_ordered_ring.to_linear_ordered_semiring [trans_instance] [redu
structure linear_ordered_comm_ring [class] (A : Type) extends linear_ordered_ring A, comm_monoid A
theorem linear_ordered_comm_ring.eq_zero_or_eq_zero_of_mul_eq_zero [s : linear_ordered_comm_ring 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,
@ -374,8 +373,8 @@ lt.by_cases
definition linear_ordered_comm_ring.to_integral_domain [trans_instance] [reducible]
[s: linear_ordered_comm_ring A] : integral_domain A :=
⦃ integral_domain, s,
eq_zero_or_eq_zero_of_mul_eq_zero :=
@linear_ordered_comm_ring.eq_zero_or_eq_zero_of_mul_eq_zero A 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]
@ -389,7 +388,7 @@ section
theorem zero_le_one : 0 ≤ (1:A) := one_mul 1 ▸ mul_self_nonneg 1
theorem pos_and_pos_or_neg_and_neg_of_mul_pos {a b : A} (Hab : a * b > 0) :
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,
@ -712,7 +711,7 @@ section
end
/- TODO: Multiplication and one, starting with mult_right_le_one_le. -/
/- TODO: Multiplication prod one, starting with mult_right_le_one_le. -/
namespace norm_num
@ -740,5 +739,4 @@ theorem nonzero_of_neg_helper [s : linear_ordered_ring A] (a : A) (H : a ≠ 0)
begin intro Ha, apply H, apply eq_of_neg_eq_neg, rewrite neg_zero, exact Ha end
end norm_num
end algebra

16
hott/algebra/port.md
View file

@ -1,9 +1,9 @@
We have ported a lot of algebra files from the standard library to the HoTT library.
We port a lot of algebra files from the standard library to the HoTT library.
Port instructions for the abstract structures:
- use the script port.pl in scripts/ to port the file. e.g. execute in the scripts file:
`./port.pl ../library/algebra/lattice.lean ../hott/algebra/lattice.hlean`
- remove imports starting with `data.` or `logic.`
- open namespace algebra, and put every identifier in namespace algebra
- add option `set_option class.force_new true`
- fix all remaining errors (open namespace `eq` if needed)
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)
- All of the algebraic hierarchy is in the algebra namespace in the HoTT library.
- Open namespaces `eq` and `algebra` if needed
- (optional) add option `set_option class.force_new true`
- fix all remaining errors

33
hott/algebra/ring.hlean
View file

@ -3,19 +3,18 @@ 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.
Structures with multiplicative prod additive components, including semirings, rings, prod fields.
The development is modeled after Isabelle's library.
-/
import algebra.group
open algebra eq
variable {A : Type}
import algebra.binary algebra.group
open eq eq.ops algebra
set_option class.force_new true
variable {A : Type}
namespace algebra
/- auxiliary classes -/
namespace algebra
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))
@ -247,7 +246,7 @@ section
... = 0 : mul_zero,
symm (neg_eq_of_add_eq_zero this)
theorem ne_zero_and_ne_zero_of_mul_ne_zero {a b : A} (H : a * b ≠ 0) : a ≠ 0 × b ≠ 0 :=
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],
@ -256,7 +255,7 @@ section
(suppose b = 0,
have a * b = 0, by rewrite [this, mul_zero],
absurd this H),
pair `a ≠ 0` `b ≠ 0`
prod.mk `a ≠ 0` `b ≠ 0`
end
structure comm_ring [class] (A : Type) extends ring A, comm_semigroup A
@ -327,11 +326,11 @@ end
/- integral domains -/
structure no_zero_divisors [class] (A : Type) extends has_mul A, has_zero A :=
(eq_zero_or_eq_zero_of_mul_eq_zero : Πa b, mul a b = zero → a = zero ⊎ b = zero)
(eq_zero_sum_eq_zero_of_mul_eq_zero : Πa b, mul a b = zero → a = zero ⊎ b = zero)
theorem eq_zero_or_eq_zero_of_mul_eq_zero {A : Type} [s : no_zero_divisors A] {a b : A}
theorem 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_or_eq_zero_of_mul_eq_zero H
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
@ -342,18 +341,18 @@ section
theorem mul_ne_zero {a b : A} (H1 : a ≠ 0) (H2 : b ≠ 0) : a * b ≠ 0 :=
suppose a * b = 0,
sum.elim (eq_zero_or_eq_zero_of_mul_eq_zero this) (assume H3, H1 H3) (assume H4, H2 H4)
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, using this, by rewrite [mul_sub_right_distrib, this],
have b - c = 0, from sum_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero this) Ha,
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, using this, by rewrite [mul_sub_left_distrib, this],
have b - c = 0, from sum_resolve_right (eq_zero_or_eq_zero_of_mul_eq_zero this) Ha,
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?
@ -363,7 +362,7 @@ section
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_or_eq_zero_of_mul_eq_zero this) `b - 1 ≠ 0`
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₂)
@ -373,7 +372,7 @@ section
(suppose a * a = b * b,
have (a - b) * (a + b) = 0,
by rewrite [mul.comm, -mul_self_sub_mul_self_eq, this, sub_self],
assert a - b = 0 ⊎ a + b = 0, from !eq_zero_or_eq_zero_of_mul_eq_zero this,
assert 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)))
@ -385,7 +384,7 @@ section
assert 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
-- TODO: c - b * c → c = 0 ⊎ b = 1 prod 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

12
hott/homotopy/circle.hlean
View file

@ -10,7 +10,7 @@ import .sphere
import types.bool types.int.hott types.equiv
import algebra.homotopy_group algebra.hott
open eq susp bool sphere_index is_equiv equiv equiv.ops is_trunc pi
open eq susp bool sphere_index is_equiv equiv equiv.ops is_trunc pi algebra
definition circle : Type₀ := sphere 1
@ -227,16 +227,18 @@ namespace circle
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) :=
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
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 equiv.ops
definition fg_carrier_equiv_int : π[1](S¹.) ≃ ℤ :=
trunc_equiv_trunc 0 base_eq_base_equiv ⬝e !trunc_equiv
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])

24
hott/homotopy/sphere.hlean
View file

@ -36,10 +36,16 @@ 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)
-/
definition has_zero_sphere_index [instance] [reducible] : has_zero sphere_index :=
has_zero.mk (succ minus_one)
definition has_one_sphere_index [instance] [reducible] : has_one sphere_index :=
has_one.mk (succ (succ minus_one))
postfix `.+1`:(max+1) := sphere_index.succ
postfix `.+2`:(max+1) := λ(n : sphere_index), (n .+1 .+1)
notation `-1` := minus_one
export [coercions] nat
notation `ℕ₋₁` := sphere_index
definition add (n m : sphere_index) : sphere_index :=
@ -50,11 +56,11 @@ namespace sphere_index
infix `+1+`:65 := sphere_index.add
notation x <= y := sphere_index.leq x y
notation x ≤ y := sphere_index.leq x y
definition has_le_sphere_index [instance] [reducible] : has_le sphere_index :=
has_le.mk leq
definition succ_le_succ {n m : sphere_index} (H : n ≤ m) : n.+1 ≤ m.+1 := H
definition le_of_succ_le_succ {n m : sphere_index} (H : n.+1 ≤ m.+1) : n ≤ m := H
definition succ_le_succ {n m : sphere_index} (H : n ≤ m) : n.+1 ≤ m.+1 := proof H qed
definition le_of_succ_le_succ {n m : sphere_index} (H : n.+1 ≤ m.+1) : n ≤ m := proof H qed
definition minus_two_le (n : sphere_index) : -1 ≤ n := star
definition empty_of_succ_le_minus_two {n : sphere_index} (H : n .+1 ≤ -1) : empty := H
@ -104,17 +110,17 @@ namespace sphere
definition bool_of_sphere : S 0 → bool :=
susp.rec ff tt (λx, empty.elim x)
proof susp.rec ff tt (λx, empty.elim x) qed
definition sphere_of_bool : bool → S 0
| ff := north
| tt := south
| 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, susp.rec_on x idp idp (empty.rec _))
(λx, proof susp.rec_on x idp idp (empty.rec _) qed)
definition sphere_eq_bool : S 0 = bool :=
ua sphere_equiv_bool

2
hott/homotopy/susp.hlean
View file

@ -169,7 +169,7 @@ namespace susp
(!ap_con ⬝
whisker_left _ !ap_inv) ⬝
(!elim_merid ◾ inverse2 !elim_merid)},
{ rewrite [▸*,inverse2_right_inv (elim_merid function.id idp)],
{ 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

155
hott/init/connectives.hlean Normal file
View file

@ -0,0 +1,155 @@
/-
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

6
hott/init/default.hlean
View file

@ -7,13 +7,15 @@ 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
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 empty unit sum
export bool unit
export empty (hiding elim)
export sum (hiding elim)
export sigma (hiding pr1 pr2)
export [notations] prod
export [notations] nat

3
hott/init/function.hlean
View file

@ -24,9 +24,6 @@ definition compose_right [reducible] [unfold_full] (f : B → B → 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 id [reducible] [unfold_full] (a : A) : A :=
a
definition on_fun [reducible] [unfold_full] (f : B → B → C) (g : A → B) : A → A → C :=
λx y, f (g x) (g y)

720
hott/init/logic.hlean
View file

@ -8,6 +8,9 @@ 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
@ -19,24 +22,20 @@ empty.rec (λ e, b) (H₂ H₁)
definition mt {a b : Type} (H₁ : a → b) (H₂ : ¬b) : ¬a :=
assume Ha : a, absurd (H₁ Ha) H₂
protected definition not_empty : ¬ empty :=
definition not_empty : ¬empty :=
assume H : empty, H
definition not_not_intro {a : Type} (Ha : a) : ¬¬a :=
definition non_contradictory (a : Type) : Type := ¬¬a
definition non_contradictory_intro {a : Type} (Ha : a) : ¬¬a :=
assume Hna : ¬a, absurd Ha Hna
theorem not_of_not_not_not {a : Type} (H : ¬¬¬a) : ¬a :=
λ Ha, absurd (not_not_intro Ha) H
definition not.elim {a : Type} (H₁ : ¬a) (H₂ : a) : empty := H₁ H₂
definition not.intro {a : Type} (H : a → empty) : ¬a := H
definition not_not_of_not_implies {a b : Type} (H : ¬(a → b)) : ¬¬a :=
assume Hna : ¬a, absurd (assume Ha : a, absurd Ha Hna) H
/- empty -/
definition not_of_not_implies {a b : Type} (H : ¬(a → b)) : ¬b :=
assume Hb : b, absurd (assume Ha : a, Hb) H
definition empty.elim {c : Type} (H : empty) : c :=
empty.rec _ H
/- eq -/
@ -55,10 +54,10 @@ namespace eq
definition symm [unfold 4] (H : a = b) : b = a :=
subst H (refl a)
theorem mp {a b : Type} : (a = b) → a → b :=
definition mp {a b : Type} : (a = b) → a → b :=
eq.rec_on
theorem mpr {a b : Type} : (a = b) → b → a :=
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
@ -75,13 +74,13 @@ 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)
theorem congr_fun {A : Type} {B : A → Type} {f g : Π x, B x} (H : f = g) (a : A) : f a = g a :=
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))
theorem congr_arg {A B : Type} (a a' : A) (f : A → B) (Ha : a = a') : f a = 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
theorem 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' :=
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
@ -110,318 +109,563 @@ end lift
/- ne -/
definition ne {A : Type} (a b : A) := ¬(a = b)
infix ≠ := 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 : (a = b → empty) → a ≠ b :=
assume H, H
definition intro (H : a = b → empty) : a ≠ b := H
definition elim : a ≠ b → a = b → empty :=
assume H₁ H₂, H₁ H₂
definition elim (H : a ≠ b) : a = b → empty := H
definition irrefl : a ≠ a → empty :=
assume H, H rfl
definition irrefl (H : a ≠ a) : empty := H rfl
definition symm : a ≠ b → b ≠ a :=
assume (H : a ≠ b) (H₁ : b = a), H H₁⁻¹
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 {A : Type} {a b c : A}
variables {p : Type₀}
definition empty.of_ne : a ≠ a → empty :=
assume H, H rfl
definition ne_empty_of_self : p → p ≠ empty :=
assume (Hp : p) (Heq : p = empty), Heq ▸ Hp
definition ne.of_eq_of_ne : a = b → b ≠ c → a ≠ c :=
assume H₁ H₂, H₁⁻¹ ▸ H₂
definition ne_unit_of_not : ¬p → p ≠ unit :=
assume (Hnp : ¬p) (Heq : p = unit), (Heq ▸ Hnp) star
definition ne.of_ne_of_eq : a ≠ b → b = c → a ≠ c :=
assume H₁ H₂, H₂ ▸ H₁
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
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) := prod (a → b) (b → a)
definition iff (a b : Type) := (a → b) × (b → a)
infix <-> := iff
infix ↔ := iff
variables {a b c : Type}
notation a <-> b := iff a b
notation a ↔ b := iff a b
namespace iff
definition iff.intro : (a → b) → (b → a) → (a ↔ b) := prod.mk
definition def : (a ↔ b) = (prod (a → b) (b → a)) :=
rfl
attribute iff.intro [intro!]
definition intro (H₁ : a → b) (H₂ : b → a) : a ↔ b :=
prod.mk H₁ H₂
definition iff.elim : ((a → b) → (b → a) → c) → (a ↔ b) → c := prod.rec
definition elim (H₁ : (a → b) → (b → a) → c) (H₂ : a ↔ b) : c :=
prod.rec H₁ H₂
attribute iff.elim [recursor 5] [elim]
definition elim_left (H : a ↔ b) : a → b :=
elim (assume H₁ H₂, H₁) H
definition iff.elim_left : (a ↔ b) → a → b := prod.pr1
definition mp := @elim_left
definition iff.mp := @iff.elim_left
definition elim_right (H : a ↔ b) : b → a :=
elim (assume H₁ H₂, H₂) H
definition iff.elim_right : (a ↔ b) → b → a := prod.pr2
definition mpr := @elim_right
definition iff.mpr := @iff.elim_right
definition flip_sign (H₁ : a ↔ b) : ¬a ↔ ¬b :=
intro
(assume Hna, mt (elim_right H₁) Hna)
(assume Hnb, mt (elim_left H₁) Hnb)
definition iff.refl [refl] (a : Type) : a ↔ a :=
iff.intro (assume H, H) (assume H, H)
definition refl (a : Type) : a ↔ a :=
intro (assume H, H) (assume H, H)
definition iff.rfl {a : Type} : a ↔ a :=
iff.refl a
definition rfl {a : Type} : a ↔ a :=
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_of_eq (a b : Type) (p : a = b) : a ↔ b :=
eq.rec rfl p
definition iff.symm [symm] (H : a ↔ b) : b ↔ a :=
iff.intro (iff.elim_right H) (iff.elim_left H)
definition trans (H₁ : a ↔ b) (H₂ : b ↔ c) : a ↔ c :=
intro
(assume Ha, elim_left H₂ (elim_left H₁ Ha))
(assume Hc, elim_right H₁ (elim_right H₂ Hc))
definition iff.comm : (a ↔ b) ↔ (b ↔ a) :=
iff.intro iff.symm iff.symm
definition symm (H : a ↔ b) : b ↔ a :=
intro
(assume Hb, elim_right H Hb)
(assume Ha, elim_left H Ha)
definition iff.of_eq {a b : Type} (H : a = b) : a ↔ b :=
eq.rec_on H iff.rfl
definition unit_elim (H : a ↔ unit) : a :=
mp (symm H) unit.star
definition empty_elim (H : a ↔ empty) : ¬a :=
assume Ha : a, mp H Ha
open eq.ops
definition of_eq {a b : Type} (H : a = b) : a ↔ b :=
iff.intro (λ Ha, H ▸ Ha) (λ Hb, H⁻¹ ▸ Hb)
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))
theorem imp_iff {P : Type} (Q : Type) (p : P) : (P → Q) ↔ Q :=
iff.intro (λf, f p) (λq p, q)
end iff
theorem not_iff_not_of_iff (H₁ : a ↔ b) : ¬a ↔ ¬b :=
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))
theorem of_iff_unit (H : a ↔ unit) : a :=
definition of_iff_unit (H : a ↔ unit) : a :=
iff.mp (iff.symm H) star
theorem not_of_iff_empty : (a ↔ empty) → ¬a := iff.mp
definition not_of_iff_empty : (a ↔ empty) → ¬a := iff.mp
theorem iff_unit_intro (H : a) : a ↔ unit :=
definition iff_unit_intro (H : a) : a ↔ unit :=
iff.intro
(λ Hl, star)
(λ Hr, H)
theorem iff_empty_intro (H : ¬a) : a ↔ empty :=
definition iff_empty_intro (H : ¬a) : a ↔ empty :=
iff.intro H (empty.rec _)
theorem not_non_contradictory_iff_absurd (a : Type) : ¬¬¬a ↔ ¬a :=
definition not_non_contradictory_iff_absurd (a : Type) : ¬¬¬a ↔ ¬a :=
iff.intro
(λ (Hl : ¬¬¬a) (Ha : a), Hl (λf, f Ha))
(λ (Hl : ¬¬¬a) (Ha : a), Hl (non_contradictory_intro Ha))
absurd
attribute iff.refl [refl]
attribute iff.trans [trans]
attribute iff.symm [symm]
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 [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
namespace inhabited
protected definition inhabited.value {A : Type} : inhabited A → A :=
inhabited.rec (λa, a)
protected definition destruct {A : Type} {B : Type} (H1 : inhabited A) (H2 : A → B) : B :=
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.destruct H (λb, mk (λ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) :=
mk (λa, inhabited.destruct (H a) (λb, b))
inhabited.mk (λa, !default)
definition default (A : Type) [H : inhabited A] : A := inhabited.destruct H (take a, a)
protected definition bool.is_inhabited [instance] : inhabited bool :=
inhabited.mk ff
end inhabited
protected definition pos_num.is_inhabited [instance] : inhabited pos_num :=
inhabited.mk pos_num.one
/- decidable -/
protected definition num.is_inhabited [instance] : inhabited num :=
inhabited.mk num.zero
inductive decidable.{l} [class] (p : Type.{l}) : Type.{l} :=
| inl : p → decidable p
| inr : ¬p → decidable p
inductive nonempty [class] (A : Type) : Type :=
intro : A → nonempty A
namespace decidable
variables {p q : Type}
protected definition nonempty.elim {A : Type} {B : Type} (H1 : nonempty A) (H2 : A → B) : B :=
nonempty.rec H2 H1
definition pos_witness [C : decidable p] (H : p) : p :=
decidable.rec_on C (λ Hp, Hp) (λ Hnp, absurd H Hnp)
theorem nonempty_of_inhabited [instance] {A : Type} [H : inhabited A] : nonempty A :=
nonempty.intro !default
definition neg_witness [C : decidable p] (H : ¬ p) : ¬ p :=
decidable.rec_on C (λ Hp, absurd Hp H) (λ Hnp, Hnp)
theorem nonempty_of_exists {A : Type} {P : A → Type} : (sigma P) → nonempty A :=
sigma.rec (λw H, nonempty.intro w)
definition by_cases {q : Type} [C : decidable p] (Hpq : p → q) (Hnpq : ¬p → q) : q :=
decidable.rec_on C (assume Hp, Hpq Hp) (assume Hnp, Hnpq Hnp)
/- subsingleton -/
definition em (p : Type) [H : decidable p] : sum p ¬p :=
by_cases (λ Hp, sum.inl Hp) (λ Hnp, sum.inr Hnp)
inductive subsingleton [class] (A : Type) : Type :=
intro : (Π a b : A, a = b) → subsingleton A
definition by_contradiction [Hp : decidable p] (H : ¬p → empty) : p :=
by_cases
(assume H₁ : p, H₁)
(assume H₁ : ¬p, empty.rec (λ e, p) (H H₁))
protected definition subsingleton.elim {A : Type} [H : subsingleton A] : Π(a b : A), a = b :=
subsingleton.rec (λp, p) H
definition decidable_iff_equiv (Hp : decidable p) (H : p ↔ q) : decidable q :=
decidable.rec_on Hp
(assume Hp : p, inl (iff.elim_left H Hp))
(assume Hnp : ¬p, inr (iff.elim_left (iff.flip_sign H) Hnp))
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"
definition decidable_eq_equiv.{l} {p q : Type.{l}} (Hp : decidable p) (H : p = q) : decidable q :=
decidable_iff_equiv Hp (iff.of_eq H)
end decidable
section
variables {p q : Type}
open decidable (rec_on inl inr)
definition decidable_unit [instance] : decidable unit :=
inl unit.star
definition decidable_empty [instance] : decidable empty :=
inr not_empty
definition decidable_prod [instance] [Hp : decidable p] [Hq : decidable q] : decidable (prod p q) :=
rec_on Hp
(assume Hp : p, rec_on Hq
(assume Hq : q, inl (prod.mk Hp Hq))
(assume Hnq : ¬q, inr (λ H : prod p q, prod.rec_on H (λ Hp Hq, absurd Hq Hnq))))
(assume Hnp : ¬p, inr (λ H : prod p q, prod.rec_on H (λ Hp Hq, absurd Hp Hnp)))
definition decidable_sum [instance] [Hp : decidable p] [Hq : decidable q] : decidable (sum p q) :=
rec_on Hp
(assume Hp : p, inl (sum.inl Hp))
(assume Hnp : ¬p, rec_on Hq
(assume Hq : q, inl (sum.inr Hq))
(assume Hnq : ¬q, inr (λ H : sum p q, sum.rec_on H (λ Hp, absurd Hp Hnp) (λ Hq, absurd Hq Hnq))))
definition decidable_not [instance] [Hp : decidable p] : decidable (¬p) :=
rec_on Hp
(assume Hp, inr (not_not_intro Hp))
(assume Hnp, inl Hnp)
definition decidable_implies [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p → q) :=
rec_on Hp
(assume Hp : p, rec_on Hq
(assume Hq : q, inl (assume H, Hq))
(assume Hnq : ¬q, inr (assume H : p → q, absurd (H Hp) Hnq)))
(assume Hnp : ¬p, inl (assume Hp, absurd Hp Hnp))
definition decidable_if [instance] [Hp : decidable p] [Hq : decidable q] : decidable (p ↔ q) :=
show decidable (prod (p → q) (q → p)), from _
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] : decidable_rel (@ne A) :=
show Π x y : A, decidable (x = y → empty), from _
definition ite (c : Type) [H : decidable c] {A : Type} (t e : A) : A :=
decidable.rec_on H (λ Hc, t) (λ Hnc, e)
definition if_pos {c : Type} [H : decidable c] (Hc : c) {A : Type} {t e : A} : (if c then t else e) = t :=
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
definition if_neg {c : Type} [H : decidable c] (Hnc : ¬c) {A : Type} {t e : A} : (if c then t else e) = e :=
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
definition if_t_t (c : Type) [H : decidable c] {A : Type} (t : A) : (if c then t else t) = t :=
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
definition if_unit {A : Type} (t e : A) : (if unit then t else e) = t :=
if_pos unit.star
definition if_empty {A : Type} (t e : A) : (if empty then t else e) = e :=
if_neg not_empty
section
open eq.ops
definition if_cond_congr {c₁ c₂ : Type} [H₁ : decidable c₁] [H₂ : decidable c₂] (Heq : c₁ ↔ c₂) {A : Type} (t e : A)
: (if c₁ then t else e) = (if c₂ then t else e) :=
decidable.rec_on H₁
(λ Hc₁ : c₁, decidable.rec_on H₂
(λ Hc₂ : c₂, if_pos Hc₁ ⬝ (if_pos Hc₂)⁻¹)
(λ Hnc₂ : ¬c₂, absurd (iff.elim_left Heq Hc₁) Hnc₂))
(λ Hnc₁ : ¬c₁, decidable.rec_on H₂
(λ Hc₂ : c₂, absurd (iff.elim_right Heq Hc₂) Hnc₁)
(λ Hnc₂ : ¬c₂, if_neg Hnc₁ ⬝ (if_neg Hnc₂)⁻¹))
definition if_congr_aux {c₁ c₂ : Type} [H₁ : decidable c₁] [H₂ : decidable c₂] {A : Type} {t₁ t₂ e₁ e₂ : A}
(Hc : c₁ ↔ c₂) (Ht : t₁ = t₂) (He : e₁ = e₂) :
(if c₁ then t₁ else e₁) = (if c₂ then t₂ else e₂) :=
Ht ▸ He ▸ (if_cond_congr Hc t₁ e₁)
definition if_congr {c₁ c₂ : Type} [H₁ : decidable c₁] {A : Type} {t₁ t₂ e₁ e₂ : A} (Hc : c₁ ↔ c₂) (Ht : t₁ = t₂) (He : e₁ = e₂) :
(if c₁ then t₁ else e₁) = (@ite c₂ (decidable.decidable_iff_equiv H₁ Hc) A t₂ e₂) :=
have H2 [visible] : decidable c₂, from (decidable.decidable_iff_equiv H₁ Hc),
if_congr_aux Hc Ht He
theorem implies_of_if_pos {c t e : Type} [H : decidable c] (h : if c then t else e) : c → t :=
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 : if c then t else e) : ¬c → e :=
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
-- 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} (t : c → A) (e : ¬ c → A) : A :=
decidable.rec_on H (λ Hc, t Hc) (λ Hnc, e Hnc)
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))
definition dif_pos {c : Type} [H : decidable c] (Hc : c) {A : Type} {t : c → A} {e : ¬ c → A} : (if H : c then t H else e H) = t (decidable.pos_witness Hc) :=
decidable.rec
(λ Hc : c, eq.refl (@dite c (decidable.inl Hc) A t e))
(λ Hnc : ¬c, absurd Hc Hnc)
H
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)
definition dif_neg {c : Type} [H : decidable c] (Hnc : ¬c) {A : Type} {t : c → A} {e : ¬ c → A} : (if H : c then t H else e H) = e (decidable.neg_witness Hnc) :=
decidable.rec
(λ Hc : c, absurd Hc Hnc)
(λ Hnc : ¬c, eq.refl (@dite c (decidable.inr Hnc) A t e))
H
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
-- Remark: dite and ite are "definitionally equal" when we ignore the proofs.
definition dite_ite_eq (c : Type) [H : decidable c] {A : Type} (t : A) (e : A) : dite c (λh, t) (λh, e) = ite c t 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 prod 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
end
open eq.ops unit
definition is_unit (c : Type) [H : decidable c] : Type₀ :=
if c then unit else empty
@ -429,16 +673,26 @@ if c then unit else empty
definition is_empty (c : Type) [H : decidable c] : Type₀ :=
if c then empty else unit
theorem of_is_unit {c : Type} [H₁ : decidable c] (H₂ : is_unit c) : c :=
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_trivial` := of_is_unit star
notation `dec_star` := of_is_unit star
theorem not_of_not_is_unit {c : Type} [H₁ : decidable c] (H₂ : ¬ is_unit c) : ¬ c :=
decidable.rec_on H₁ (λ Hc, absurd star (if_pos Hc ▸ H₂)) (λ Hnc, Hnc)
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 :=
decidable.rec_on H₁ (λ Hc, empty.rec _ (if_pos Hc ▸ H₂)) (λ Hnc, Hnc)
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 :=
decidable.rec_on H₁ (λ Hc, Hc) (λ Hnc, absurd star (if_neg Hnc ▸ H₂))
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

12
hott/init/nat.hlean
View file

@ -179,10 +179,10 @@ namespace nat
theorem lt_zero_iff_empty [simp] (a : ℕ) : a < 0 ↔ empty :=
iff_empty_intro (not_lt_zero a)
protected theorem eq_or_lt_of_le {a b : ℕ} (H : a ≤ b) : a = b ⊎ a < b :=
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_or_lt {a b : ℕ} (H : a = b ⊎ a < b) : a ≤ b :=
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
-- less-than is well-founded
@ -222,13 +222,13 @@ namespace nat
definition decidable_lt [instance] [priority nat.prio] : Π a b : nat, decidable (a < b) :=
λ a b, decidable_le (succ a) b
protected theorem lt_or_ge (a b : ℕ) : a < b ⊎ 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_or_lt_of_le h) (λe, inl (eq.subst e !nat.le_refl)) inr)) b
(λ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_or_ge (λa, absurd a h) (λa, a)))
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 :=
@ -238,7 +238,7 @@ namespace nat
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_or_lt_of_not_lt {a b : ℕ} (hnlt : ¬ a < b) : a = b ⊎ b < a :=
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)

4
hott/init/reserved_notation.hlean
View file

@ -155,8 +155,8 @@ reserve infixr ` ▹ `:75
/- types and type constructors -/
reserve infixr ` ⊎ `:25
reserve infixr ` × `:30
reserve infixr ` ⊎ `:30
reserve infixr ` × `:35
/- arithmetic operations -/

20
hott/init/trunc.hlean
View file

@ -28,6 +28,9 @@ namespace is_trunc
definition has_zero_trunc_index [instance] [reducible] : has_zero trunc_index :=
has_zero.mk (succ (succ minus_two))
definition has_one_trunc_index [instance] [reducible] : has_one trunc_index :=
has_one.mk (succ (succ (succ minus_two)))
/-
notation for trunc_index is -2, -1, 0, 1, ...
from 0 and up this comes from a coercion from num to trunc_index (via nat)
@ -44,15 +47,17 @@ namespace is_trunc
definition leq (n m : trunc_index) : Type₀ :=
trunc_index.rec_on n (λm, unit) (λ n p m, trunc_index.rec_on m (λ p, empty) (λ m q p, p m) p) m
infix <= := trunc_index.leq
infix ≤ := trunc_index.leq
definition has_le_trunc_index [instance] [reducible] : has_le trunc_index :=
has_le.mk leq
end trunc_index
infix `+2+`:65 := trunc_index.add
namespace trunc_index
definition succ_le_succ {n m : trunc_index} (H : n ≤ m) : n.+1 ≤ m.+1 := H
definition le_of_succ_le_succ {n m : trunc_index} (H : n.+1 ≤ m.+1) : n ≤ m := H
definition succ_le_succ {n m : trunc_index} (H : n ≤ m) : n.+1 ≤ m.+1 := proof H qed
definition le_of_succ_le_succ {n m : trunc_index} (H : n.+1 ≤ m.+1) : n ≤ m := proof H qed
definition minus_two_le (n : trunc_index) : -2 ≤ n := star
definition le.refl (n : trunc_index) : n ≤ n := by induction n with n IH; exact star; exact IH
definition empty_of_succ_le_minus_two {n : trunc_index} (H : n .+1 ≤ -2) : empty := H
@ -101,6 +106,10 @@ namespace is_trunc
(n : trunc_index) [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)
definition is_trunc_eq_zero [instance] [priority 1250] [H : is_trunc 1 A] (x y : A)
: is_hset (x = y) :=
@is_trunc_eq A 0 H x y
/- contractibility -/
definition is_contr.mk (center : A) (center_eq : Π(a : A), center = a) : is_contr A :=
@ -134,6 +143,9 @@ namespace is_trunc
A H
--in the proof the type of H is given explicitly to make it available for class inference
theorem is_trunc_succ_zero [instance] [priority 950] (A : Type) [H : is_hset A] : is_trunc 1 A :=
!is_trunc_succ
theorem is_trunc_of_leq.{l} (A : Type.{l}) {n m : trunc_index} (Hnm : n ≤ m)
[Hn : is_trunc n A] : is_trunc m A :=
have base : ∀k A, k ≤ -2 → is_trunc k A → (is_trunc -2 A), from

178
hott/init/types.hlean
View file

@ -11,13 +11,6 @@ open iff
-- Empty type
-- ----------
namespace empty
protected theorem elim {A : Type} (H : empty) : A :=
empty.rec (λe, A) H
end empty
protected definition empty.has_decidable_eq [instance] : decidable_eq empty :=
take (a b : empty), decidable.inl (!empty.elim a)
@ -48,8 +41,6 @@ end sigma
-- Sum type
-- --------
infixr ⊎ := sum
infixr + := sum
namespace sum
infixr [parsing_only] `+t`:25 := sum -- notation which is never overloaded
@ -60,8 +51,6 @@ namespace sum
variables {a b c d : Type}
protected definition elim (H : a ⊎ b) (f : a → c) (g : b → c) := sum.rec_on H f g
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))
@ -81,8 +70,6 @@ end sum
-- Product type
-- ------------
abbreviation pair [constructor] := @prod.mk
infixr × := prod
namespace prod
@ -168,168 +155,9 @@ namespace prod
end prod
/- logic using prod and sum -/
/- logic (ported from standard library as second half of logic file) -/
/- iff -/
variables {a b c d : Type}
open prod sum unit
/- prod -/
definition not_prod_of_not_left (b : Type) (Hna : ¬a) : ¬(a × b) :=
assume H : a × b, absurd (pr1 H) Hna
definition not_prod_of_not_right (a : Type) {b : Type} (Hnb : ¬b) : ¬(a × b) :=
assume H : a × b, absurd (pr2 H) Hnb
definition prod.swap (H : a × b) : b × a :=
pair (pr2 H) (pr1 H)
definition prod_of_prod_of_imp_of_imp (H₁ : a × b) (H₂ : a → c) (H₃ : b → d) : c × d :=
by cases H₁ with aa bb; exact (H₂ aa, H₃ bb)
definition prod_of_prod_of_imp_left (H₁ : a × c) (H : a → b) : b × c :=
by cases H₁ with aa cc; exact (H aa, cc)
definition prod_of_prod_of_imp_right (H₁ : c × a) (H : a → b) : c × b :=
by cases H₁ with cc aa; exact (cc, H aa)
definition prod.comm : a × b ↔ b × a :=
iff.intro (λH, prod.swap H) (λH, prod.swap H)
definition prod.assoc : (a × b) × c ↔ a × (b × c) :=
iff.intro
(assume H, pair
(pr1 (pr1 H))
(pair (pr2 (pr1 H)) (pr2 H)))
(assume H, pair
(pair (pr1 H) (pr1 (pr2 H)))
(pr2 (pr2 H)))
definition prod_unit (a : Type) : a × unit ↔ a :=
iff.intro (assume H, pr1 H) (assume H, pair H star)
definition unit_prod (a : Type) : unit × a ↔ a :=
iff.intro (assume H, pr2 H) (assume H, pair star H)
definition prod_empty (a : Type) : a × empty ↔ empty :=
iff.intro (assume H, pr2 H) (assume H, !empty.elim H)
definition empty_prod (a : Type) : empty × a ↔ empty :=
iff.intro (assume H, pr1 H) (assume H, !empty.elim H)
definition prod_self (a : Type) : a × a ↔ a :=
iff.intro (assume H, pr1 H) (assume H, pair H H)
/- sum -/
definition not_sum (Hna : ¬a) (Hnb : ¬b) : ¬(a ⊎ b) :=
assume H : a ⊎ b, sum.rec_on H
(assume Ha, absurd Ha Hna)
(assume Hb, absurd Hb Hnb)
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₂))
definition sum.elim3 (H : a ⊎ b ⊎ c) (Ha : a → d) (Hb : b → d) (Hc : c → d) : d :=
sum.rec_on H Ha (assume H₂, sum.rec_on H₂ Hb Hc)
definition sum_resolve_right (H₁ : a ⊎ b) (H₂ : ¬a) : b :=
sum.rec_on H₁ (assume Ha, absurd Ha H₂) (assume Hb, Hb)
definition sum_resolve_left (H₁ : a ⊎ b) (H₂ : ¬b) : a :=
sum.rec_on H₁ (assume Ha, Ha) (assume Hb, absurd Hb H₂)
definition sum.swap (H : a ⊎ b) : b ⊎ a :=
sum.rec_on H (assume Ha, sum.inr Ha) (assume Hb, sum.inl Hb)
definition sum.comm : a ⊎ b ↔ b ⊎ a :=
iff.intro (λH, sum.swap H) (λH, sum.swap H)
definition sum.assoc : (a ⊎ b) ⊎ c ↔ a ⊎ (b ⊎ c) :=
iff.intro
(assume H, sum.rec_on H
(assume H₁, sum.rec_on H₁
(assume Ha, sum.inl Ha)
(assume Hb, sum.inr (sum.inl Hb)))
(assume Hc, sum.inr (sum.inr Hc)))
(assume H, sum.rec_on H
(assume Ha, (sum.inl (sum.inl Ha)))
(assume H₁, sum.rec_on H₁
(assume Hb, sum.inl (sum.inr Hb))
(assume Hc, sum.inr Hc)))
definition sum_unit (a : Type) : a ⊎ unit ↔ unit :=
iff.intro (assume H, star) (assume H, sum.inr H)
definition unit_sum (a : Type) : unit ⊎ a ↔ unit :=
iff.intro (assume H, star) (assume H, sum.inl H)
definition sum_empty (a : Type) : a ⊎ empty ↔ a :=
iff.intro
(assume H, sum.rec_on H (assume H1 : a, H1) (assume H1 : empty, !empty.elim H1))
(assume H, sum.inl H)
definition empty_sum (a : Type) : empty ⊎ a ↔ a :=
iff.intro
(assume H, sum.rec_on H (assume H1 : empty, !empty.elim H1) (assume H1 : a, H1))
(assume H, sum.inr H)
definition sum_self (a : Type) : a ⊎ a ↔ a :=
iff.intro
(assume H, sum.rec_on H (assume H1, H1) (assume H1, H1))
(assume H, sum.inl H)
/- TODO
theorem sum.right_comm (a b c : Type) : (a + b) + c ↔ (a + c) + b :=
calc
(a + b) + c ↔ a + (b + c) : sum.assoc
... ↔ a + (c + b) : {sum.comm}
... ↔ (a + c) + b : iff.symm sum.assoc
theorem sum.left_comm (a b c : Type) : a + (b + c) ↔ b + (a + c) :=
calc
a + (b + c) ↔ (a + b) + c : iff.symm sum.assoc
... ↔ (b + a) + c : {sum.comm}
... ↔ b + (a + c) : sum.assoc
theorem prod.right_comm (a b c : Type) : (a × b) × c ↔ (a × c) × b :=
calc
(a × b) × c ↔ a × (b × c) : prod.assoc
... ↔ a × (c × b) : _
... ↔ (a × c) × b : iff.symm prod.assoc
theorem prod_not_self_iff {a : Type} : a × ¬ a ↔ false :=
iff.intro (assume H, (prod.right H) (prod.left H)) (assume H, false.elim H)
theorem not_prod_self_iff {a : Type} : ¬ a × a ↔ false :=
!prod.comm ▸ !prod_not_self_iff
theorem prod.left_comm [simp] (a b c : Type) : a × (b × c) ↔ b × (a × c) :=
calc
a × (b × c) ↔ (a × b) × c : iff.symm prod.assoc
... ↔ (b × a) × c : {prod.comm}
... ↔ b × (a × c) : prod.assoc
-/
theorem imp.syl (H : a → b) (H₂ : c → a) (Hc : c) : b :=
H (H₂ Hc)
theorem sum.imp_distrib : ((a + b) → c) ↔ ((a → c) × (b → c)) :=
iff.intro
(λH, prod.mk (imp.syl H sum.inl) (imp.syl H sum.inr))
(prod.rec sum.rec)
theorem not_sum_iff_not_prod_not {a b : Type} : ¬(a + b) ↔ ¬a × ¬b :=
sum.imp_distrib

15
hott/tools/helper_tactics.hlean Normal file
View file

@ -0,0 +1,15 @@
-- 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

6
hott/tools/tools.md Normal file
View file

@ -0,0 +1,6 @@
tools
=====
Various additional tools.
* [helper_tactics](helper_tactics.lean) : useful tactics

142
hott/types/bool.hlean
View file

@ -1,24 +1,146 @@
/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
Author: Leonardo de Moura, Floris van Doorn
Theorems about the booleans
Partially ported from the standard library
-/
open is_equiv eq equiv function is_trunc option unit decidable
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 ff_ne_tt : ff = tt → empty
| [none]
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)),
-- all_goals (focus (intro b;cases b;all_goals reflexivity)),
end
definition bnot_ne : Π(b : bool), bnot b ≠ b
@ -43,10 +165,4 @@ namespace bool
{ intro b, cases b, reflexivity, reflexivity},
end
protected definition has_decidable_eq [instance] : ∀ x y : bool, decidable (x = y)
| has_decidable_eq ff ff := inl rfl
| has_decidable_eq ff tt := inr (by contradiction)
| has_decidable_eq tt ff := inr (by contradiction)
| has_decidable_eq tt tt := inl rfl
end bool

986
hott/types/int/basic.hlean
View file

File diff suppressed because it is too large Load diff

41
hott/types/int/hott.hlean
View file

@ -6,11 +6,12 @@ Author: Floris van Doorn
Theorems about the integers specific to HoTT
-/
import .basic types.eq arity
open core eq is_equiv equiv equiv.ops
import .basic types.eq arity algebra.bundled
open core eq is_equiv equiv equiv.ops algebra is_trunc
open nat (hiding pred)
namespace int
section
open algebra
definition group_integers : Group :=
@ -21,7 +22,7 @@ namespace int
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 :=
definition is_equiv_neg [instance] : is_equiv (neg : ℤ → ℤ) :=
adjointify neg neg (λx, !neg_neg) (λa, !neg_neg)
definition equiv_neg : ℤ ≃ ℤ := equiv.mk neg _
@ -90,8 +91,9 @@ namespace eq
idp
(λn IH, idp)
(λn IH, calc
power p (-succ n) ⬝ p = (power p (-n) ⬝ p⁻¹) ⬝ p : by rewrite [↑power,-rec_nat_on_neg]
... = power p (-n) : inv_con_cancel_right
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) :=
@ -101,7 +103,8 @@ namespace eq
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 (-succ n) ⬝ p⁻¹ = power p (-succ (succ n)) : by rewrite [↑power,-rec_nat_on_neg]
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) :=
@ -111,12 +114,12 @@ namespace eq
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 (-succ n)
= p ⬝ (power p (-n) ⬝ p⁻¹) : by rewrite [↑power,rec_nat_on_neg]
... = (p ⬝ power p (-n)) ⬝ p⁻¹ : con.assoc
... = power p (succ (-n)) ⬝ p⁻¹ : by rewrite IH
... = power p (pred (succ (-n))) : power_con_inv
... = power p (succ (-succ n)) : by rewrite [succ_neg_nat_succ,int.pred_succ])
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
@ -127,18 +130,20 @@ namespace eq
... = 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 (-succ n) = p⁻¹ ⬝ (power p (-n) ⬝ p⁻¹) : by rewrite [↑power,rec_nat_on_neg]
... = (p⁻¹ ⬝ power p (-n)) ⬝ p⁻¹ : con.assoc
... = power p (pred (-n)) ⬝ p⁻¹ : by rewrite IH
... = power p (-succ n) ⬝ p⁻¹ : by rewrite -neg_succ
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,int.add.assoc,int.add.comm 1 n])
(λ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,int.add.assoc,int.add.comm (-1) (-n)])
+sub_eq_add_neg,add.assoc,add.comm (-n)])
end eq

2
hott/types/list.hlean
View file

@ -10,7 +10,7 @@ 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
open eq lift nat is_trunc pi pointed sum function prod option sigma algebra
inductive list (T : Type) : Type :=
| nil {} : list T

301
hott/types/nat/basic.hlean
View file

@ -1,13 +1,13 @@
/-
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 file data.nat.basic on May 02, 2015)
(Ported from standard library)
Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad
Basic operations on the natural numbers.
-/
import algebra.ring
open core prod binary
import ..num algebra.ring
open prod binary eq algebra lift is_trunc
namespace nat
@ -17,7 +17,7 @@ definition addl (x y : ℕ) : ℕ :=
nat.rec y (λ n r, succ r) x
infix ` ⊕ `:65 := addl
definition addl_succ_right (n m : ℕ) : n ⊕ succ m = succ (n ⊕ m) :=
theorem addl_succ_right (n m : ℕ) : n ⊕ succ m = succ (n ⊕ m) :=
nat.rec_on n
rfl
(λ n₁ ih, calc
@ -25,115 +25,120 @@ nat.rec_on n
... = succ (succ (n₁ ⊕ m)) : ih
... = succ (succ n₁ ⊕ m) : rfl)
definition add_eq_addl (x : ℕ) : ∀y, x + y = x ⊕ y :=
theorem add_eq_addl (x : ℕ) : Πy, x + y = x ⊕ y :=
nat.rec_on x
(λ y, nat.rec_on y
rfl
(λ y₁ ih, calc
zero + succ y₁ = succ (zero + y₁) : rfl
... = succ (zero ⊕ y₁) : {ih}
... = zero ⊕ (succ y₁) : rfl))
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₁ + zero = succ (x₁ + zero) : rfl
... = succ (x₁ ⊕ zero) : {ih₁ zero}
... = succ x₁ ⊕ zero : rfl)
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 -/
/- successor prod predecessor -/
definition succ_ne_zero (n : ℕ) : succ n ≠ 0 :=
theorem succ_ne_zero (n : ℕ) : succ n ≠ 0 :=
by contradiction
-- add_rewrite succ_ne_zero
definition pred_zero : pred 0 = 0 :=
theorem pred_zero [simp] : pred 0 = 0 :=
rfl
definition pred_succ (n : ℕ) : pred (succ n) = n :=
theorem pred_succ [simp] (n : ℕ) : pred (succ n) = n :=
rfl
definition eq_zero_or_eq_succ_pred (n : ℕ) : n = 0 ⊎ n = succ (pred n) :=
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 rfl)
(take m IH, sum.inr
(show succ m = succ (pred (succ m)), from ap succ !pred_succ⁻¹))
definition exists_eq_succ_of_ne_zero {n : ℕ} (H : n ≠ 0) : Σk : ℕ, n = succ k :=
sigma.mk _ (sum_resolve_right !eq_zero_or_eq_succ_pred H)
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)
definition succ.inj {n m : ℕ} (H : succ n = succ m) : n = m :=
lift.down (nat.no_confusion H (λe, e))
theorem succ.inj {n m : ℕ} (H : succ n = succ m) : n = m :=
down (nat.no_confusion H imp.id)
definition succ_ne_self {n : ℕ} : succ n ≠ n :=
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))
definition discriminate {B : Type} {n : ℕ} (H1: n = 0 → B) (H2 : ∀m, n = succ m → B) : B :=
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
definition two_step_induction_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 :=
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 pr1 IH,
have IH2 : P (succ k), from pr2 IH,
have IH1 : P k, from prod.pr1 IH,
have IH2 : P (succ k), from prod.pr2 IH,
pair IH2 (H3 k IH1 IH2)),
pr1 stronger
prod.pr1 stronger
definition 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
(take m : ℕ, H1 m)
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,
assume IH : Πm, P k m,
take m : ℕ,
nat.cases_on m (H2 k) (take l, (H3 k l (IH l)))),
general m
/- addition -/
definition add_zero (n : ℕ) : n + 0 = n :=
protected theorem add_zero [simp] (n : ℕ) : n + 0 = n :=
rfl
definition add_succ (n m : ℕ) : n + succ m = succ (n + m) :=
theorem add_succ [simp] (n m : ℕ) : n + succ m = succ (n + m) :=
rfl
definition zero_add (n : ℕ) : 0 + n = n :=
protected theorem zero_add [simp] (n : ℕ) : 0 + n = n :=
nat.rec_on n
!add_zero
!nat.add_zero
(take m IH, show 0 + succ m = succ m, from
calc
0 + succ m = succ (0 + m) : add_succ
... = succ m : IH)
definition succ_add (n m : ℕ) : (succ n) + m = succ (n + m) :=
theorem succ_add [simp] (n m : ℕ) : (succ n) + m = succ (n + m) :=
nat.rec_on m
(rfl)
(take k IH, eq.ap succ IH)
(!nat.add_zero ▸ !nat.add_zero)
(take k IH, calc
succ n + succ k = succ (succ n + k) : add_succ
... = succ (succ (n + k)) : IH
... = succ (n + succ k) : add_succ)
definition add.comm (n m : ℕ) : n + m = m + n :=
protected theorem add_comm [simp] (n m : ℕ) : n + m = m + n :=
nat.rec_on m
(!add_zero ⬝ !zero_add⁻¹)
(by rewrite [nat.add_zero, nat.zero_add])
(take k IH, calc
n + succ k = succ (n+k) : add_succ
... = succ (k + n) : IH
... = succ k + n : succ_add)
definition succ_add_eq_succ_add (n m : ℕ) : succ n + m = n + succ m :=
theorem succ_add_eq_succ_add (n m : ℕ) : succ n + m = n + succ m :=
!succ_add ⬝ !add_succ⁻¹
definition add.assoc (n m k : ℕ) : (n + m) + k = n + (m + k) :=
protected theorem add_assoc [simp] (n m k : ℕ) : (n + m) + k = n + (m + k) :=
nat.rec_on k
(!add_zero ▸ !add_zero)
(by rewrite +nat.add_zero)
(take l IH,
calc
(n + m) + succ l = succ ((n + m) + l) : add_succ
@ -141,33 +146,30 @@ nat.rec_on k
... = n + succ (m + l) : add_succ
... = n + (m + succ l) : add_succ)
definition add.left_comm (n m k : ℕ) : n + (m + k) = m + (n + k) :=
left_comm add.comm add.assoc n m k
protected theorem add_left_comm : Π (n m k : ℕ), n + (m + k) = m + (n + k) :=
left_comm nat.add_comm nat.add_assoc
definition add.right_comm (n m k : ℕ) : n + m + k = n + k + m :=
right_comm add.comm add.assoc n m k
protected theorem add_right_comm : Π (n m k : ℕ), n + m + k = n + k + m :=
right_comm nat.add_comm nat.add_assoc
theorem add.comm4 : Π {n m k l : ℕ}, n + m + (k + l) = n + k + (m + l) :=
comm4 add.comm add.assoc
definition add.cancel_left {n m k : ℕ} : n + m = n + k → m = k :=
protected theorem add_left_cancel {n m k : ℕ} : n + m = n + k → m = k :=
nat.rec_on n
(take H : 0 + m = 0 + k,
!zero_add⁻¹ ⬝ H ⬝ !zero_add)
!nat.zero_add⁻¹ ⬝ H ⬝ !nat.zero_add)
(take (n : ℕ) (IH : n + m = n + k → m = k) (H : succ n + m = succ n + k),
have H2 : 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 H3 : n + m = n + k, from succ.inj H2,
IH H3)
have n + m = n + k, from succ.inj this,
IH this)
definition add.cancel_right {n m k : ℕ} (H : n + m = k + m) : n = k :=
have H2 : m + n = m + k, from !add.comm ⬝ H ⬝ !add.comm,
add.cancel_left H2
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
definition eq_zero_of_add_eq_zero_right {n m : ℕ} : n + m = 0 → n = 0 :=
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,
@ -178,99 +180,98 @@ nat.rec_on n
... = 0 : H)
!succ_ne_zero)
definition eq_zero_of_add_eq_zero_left {n m : ℕ} (H : n + m = 0) : m = 0 :=
eq_zero_of_add_eq_zero_right (!add.comm ⬝ H)
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)
definition eq_zero_and_eq_zero_of_add_eq_zero {n m : ℕ} (H : n + m = 0) : n = 0 × m = 0 :=
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)
definition add_one (n : ℕ) : n + 1 = succ n :=
!add_zero ▸ !add_succ
theorem add_one [simp] (n : ℕ) : n + 1 = succ n := rfl
definition one_add (n : ℕ) : 1 + n = succ n :=
!zero_add ▸ !succ_add
theorem one_add (n : ℕ) : 1 + n = succ n :=
!nat.zero_add ▸ !succ_add
/- multiplication -/
definition mul_zero (n : ℕ) : n * 0 = 0 :=
protected theorem mul_zero [simp] (n : ℕ) : n * 0 = 0 :=
rfl
definition mul_succ (n m : ℕ) : n * succ m = n * m + n :=
theorem mul_succ [simp] (n m : ℕ) : n * succ m = n * m + n :=
rfl
-- commutativity, distributivity, associativity, identity
definition zero_mul (n : ℕ) : 0 * n = 0 :=
protected theorem zero_mul [simp] (n : ℕ) : 0 * n = 0 :=
nat.rec_on n
!mul_zero
(take m IH, !mul_succ ⬝ !add_zero ⬝ IH)
!nat.mul_zero
(take m IH, !mul_succ ⬝ !nat.add_zero ⬝ IH)
definition succ_mul (n m : ℕ) : (succ n) * m = (n * m) + m :=
theorem succ_mul [simp] (n m : ℕ) : (succ n) * m = (n * m) + m :=
nat.rec_on m
(!mul_zero ⬝ !mul_zero⁻¹ ⬝ !add_zero⁻¹)
(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) : add.assoc
... = n * k + (succ n + k) : add.comm
... = 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 : add.assoc
... = n * k + n + succ k : nat.add_assoc
... = n * succ k + succ k : mul_succ)
definition mul.comm (n m : ℕ) : n * m = m * n :=
protected theorem mul_comm [simp] (n m : ℕ) : n * m = m * n :=
nat.rec_on m
(!mul_zero ⬝ !zero_mul⁻¹)
(!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)
definition mul.right_distrib (n m k : ℕ) : (n + m) * k = n * k + m * k :=
protected theorem right_distrib (n m k : ℕ) : (n + m) * k = n * k + m * k :=
nat.rec_on k
(calc
(n + m) * 0 = 0 : mul_zero
... = 0 + 0 : add_zero
... = n * 0 + 0 : mul_zero
... = n * 0 + m * 0 : mul_zero)
(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 : add.assoc
... = n * l + n + m * l + m : add.right_comm
... = n * l + n + (m * l + m) : add.assoc
... = 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)
definition mul.left_distrib (n m k : ℕ) : n * (m + k) = n * m + n * k :=
protected theorem 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 : mul.right_distrib
... = n * m + k * n : mul.comm
... = n * m + n * k : mul.comm
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
definition mul.assoc (n m k : ℕ) : (n * m) * k = n * (m * k) :=
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) : mul_zero)
(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) : mul.left_distrib
... = n * (m * l + m) : nat.left_distrib
... = n * (m * succ l) : mul_succ)
definition mul_one (n : ℕ) : n * 1 = n :=
protected theorem mul_one [simp] (n : ℕ) : n * 1 = n :=
calc
n * 1 = n * 0 + n : mul_succ
... = 0 + n : mul_zero
... = n : zero_add
... = 0 + n : nat.mul_zero
... = n : nat.zero_add
definition one_mul (n : ℕ) : 1 * n = n :=
protected theorem one_mul [simp] (n : ℕ) : 1 * n = n :=
calc
1 * n = n * 1 : mul.comm
... = n : mul_one
1 * n = n * 1 : nat.mul_comm
... = n : nat.mul_one
definition eq_zero_or_eq_zero_of_mul_eq_zero {n m : ℕ} : n * m = 0 → n = 0 ⊎ m = 0 :=
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',
@ -279,72 +280,38 @@ nat.cases_on n
(take m',
assume H : succ n' * succ m' = 0,
absurd
((calc
(calc
0 = succ n' * succ m' : H
... = succ n' * m' + succ n' : mul_succ
... = succ (succ n' * m' + n') : add_succ)⁻¹)
... = succ (succ n' * m' + n') : add_succ)⁻¹
!succ_ne_zero))
section
open [classes] algebra
protected definition comm_semiring [instance] [reducible] : algebra.comm_semiring nat :=
⦃algebra.comm_semiring,
add := add,
add_assoc := add.assoc,
zero := zero,
zero_add := zero_add,
add_zero := add_zero,
add_comm := add.comm,
mul := mul,
mul_assoc := mul.assoc,
one := succ zero,
one_mul := one_mul,
mul_one := mul_one,
left_distrib := mul.left_distrib,
right_distrib := mul.right_distrib,
zero_mul := zero_mul,
mul_zero := mul_zero,
mul_comm := mul.comm,
is_hset_carrier := is_hset_of_decidable_eq⦄
end
section port_algebra
open [classes] algebra
definition mul.left_comm : ∀a b c : ℕ, a * (b * c) = b * (a * c) := algebra.mul.left_comm
definition mul.right_comm : ∀a b c : ℕ, (a * b) * c = (a * c) * b := algebra.mul.right_comm
definition dvd (a b : ℕ) : Type₀ := algebra.dvd a b
notation a ∣ b := dvd a b
definition dvd.intro : ∀{a b c : ℕ} (H : a * c = b), a ∣ b := @algebra.dvd.intro _ _
definition dvd.intro_left : ∀{a b c : ℕ} (H : c * a = b), a ∣ b := @algebra.dvd.intro_left _ _
definition exists_eq_mul_right_of_dvd : ∀{a b : ℕ} (H : a ∣ b), Σc, b = a * c :=
@algebra.exists_eq_mul_right_of_dvd _ _
definition dvd.elim : ∀{P : Type} {a b : ℕ} (H₁ : a ∣ b) (H₂ : ∀c, b = a * c → P), P :=
@algebra.dvd.elim _ _
definition exists_eq_mul_left_of_dvd : ∀{a b : ℕ} (H : a ∣ b), Σc, b = c * a :=
@algebra.exists_eq_mul_left_of_dvd _ _
definition dvd.elim_left : ∀{P : Type} {a b : ℕ} (H₁ : a ∣ b) (H₂ : ∀c, b = c * a → P), P :=
@algebra.dvd.elim_left _ _
definition dvd.refl : ∀a : ℕ, a ∣ a := algebra.dvd.refl
definition dvd.trans : ∀{a b c : ℕ}, a ∣ b → b ∣ c → a ∣ c := @algebra.dvd.trans _ _
definition eq_zero_of_zero_dvd : ∀{a : ℕ}, 0 ∣ a → a = 0 := @algebra.eq_zero_of_zero_dvd _ _
definition dvd_zero : ∀a : ℕ, a ∣ 0 := algebra.dvd_zero
definition one_dvd : ∀a : ℕ, 1 ∣ a := algebra.one_dvd
definition dvd_mul_right : ∀a b : ℕ, a ∣ a * b := algebra.dvd_mul_right
definition dvd_mul_left : ∀a b : ℕ, a ∣ b * a := algebra.dvd_mul_left
definition dvd_mul_of_dvd_left : ∀{a b : ℕ} (H : a ∣ b) (c : ℕ), a ∣ b * c :=
@algebra.dvd_mul_of_dvd_left _ _
definition dvd_mul_of_dvd_right : ∀{a b : ℕ} (H : a ∣ b) (c : ℕ), a ∣ c * b :=
@algebra.dvd_mul_of_dvd_right _ _
definition mul_dvd_mul : ∀{a b c d : ℕ}, a ∣ b → c ∣ d → a * c ∣ b * d :=
@algebra.mul_dvd_mul _ _
definition dvd_of_mul_right_dvd : ∀{a b c : ℕ}, a * b ∣ c → a ∣ c :=
@algebra.dvd_of_mul_right_dvd _ _
definition dvd_of_mul_left_dvd : ∀{a b c : ℕ}, a * b ∣ c → b ∣ c :=
@algebra.dvd_of_mul_left_dvd _ _
definition dvd_add : ∀{a b c : ℕ}, a ∣ b → a ∣ c → a ∣ b + c := @algebra.dvd_add _ _
end port_algebra
protected definition comm_semiring [reducible] [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_hset_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

11
hott/types/nat/hott.hlean
View file

@ -6,9 +6,9 @@ Author: Floris van Doorn
Theorems about the natural numbers specific to HoTT
-/
import .basic
import .order
open is_trunc unit empty eq equiv
open is_trunc unit empty eq equiv algebra
namespace nat
definition is_hprop_le [instance] (n m : ℕ) : is_hprop (n ≤ m) :=
@ -25,6 +25,8 @@ namespace nat
{ exact ap le.step !v_0}},
end
definition is_hprop_lt [instance] (n m : ℕ) : is_hprop (n < m) := !is_hprop_le
definition le_equiv_succ_le_succ (n m : ℕ) : (n ≤ m) ≃ (succ n ≤ succ m) :=
equiv_of_is_hprop succ_le_succ le_of_succ_le_succ
definition le_succ_equiv_pred_le (n m : ℕ) : (n ≤ succ m) ≃ (pred n ≤ m) :=
@ -73,8 +75,9 @@ namespace nat
unfold [lt_ge_by_cases,lt.by_cases], induction (lt.trichotomy n m) with H' H',
{ esimp, apply ap H1 !is_hprop.elim},
{ cases H' with H' H',
esimp, exact !Heq⁻¹ ⬝ ap H1 !is_hprop.elim,
exfalso, apply lt.irrefl, apply lt_of_le_of_lt H H'}
{ esimp, induction H', esimp, symmetry,
exact ap H1 !is_hprop.elim ⬝ Heq idp ⬝ ap H2 !is_hprop.elim},
{ exfalso, apply lt.irrefl, apply lt_of_le_of_lt H H'}}
end
protected definition code [reducible] [unfold 1 2] : ℕ → ℕ → Type₀

565
hott/types/nat/order.hlean
View file

@ -4,180 +4,158 @@ 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.
Note: this file has significant differences than the standard library version
-/
import .basic algebra.ordered_ring
open prod decidable sum eq sigma sigma.ops
open eq eq.ops algebra algebra
namespace nat
/- lt and le -/
/- lt prod le -/
theorem le_of_lt_or_eq {m n : ℕ} (H : m < n ⊎ m = n) : m ≤ n :=
sum.rec_on H (take H1, le_of_lt H1) (take H1, H1 ▸ !le.refl)
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)
theorem lt_or_eq_of_le {m n : ℕ} (H : m ≤ n) : m < n ⊎ m = n :=
lt.by_cases
(assume H1 : m < n, sum.inl H1)
(assume H1 : m = n, sum.inr H1)
(assume H1 : m > n, absurd (lt_of_le_of_lt H H1) !lt.irrefl)
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)
theorem le_iff_lt_or_eq (m n : ℕ) : m ≤ n ↔ m < n ⊎ m = n :=
iff.intro lt_or_eq_of_le le_of_lt_or_eq
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
theorem lt_of_le_and_ne {m n : ℕ} (H1 : m ≤ n) (H2 : m ≠ n) : m < n :=
sum.rec_on (lt_or_eq_of_le H1)
(take H3 : m < n, H3)
(take H3 : m = n, absurd H3 H2)
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)
theorem lt_iff_le_and_ne (m n : ℕ) : m < n ↔ m ≤ n × m ≠ n :=
protected theorem lt_iff_le_prod_ne (m n : ℕ) : m < n ↔ m ≤ n × m ≠ n :=
iff.intro
(take H, pair (le_of_lt H) (take H1, lt.irrefl _ (H1 ▸ H)))
(take H, lt_of_le_and_ne (pr1 H) (pr2 H))
(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_on k
(calc n ≤ n : le.refl n
... = n + zero : add_zero)
(λ k (ih : n ≤ n + k), calc
n ≤ succ (n + k) : le_succ_of_le ih
... = n + succ k : add_succ)
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 n k
h ▸ !le_add_right
theorem le.elim {n m : ℕ} (h : n ≤ m) : Σk, n + k = m :=
by induction h with m h ih;exact ⟨0, idp⟩;exact ⟨succ ih.1, ap succ ih.2⟩
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)))
theorem le.total {m n : ℕ} : m ≤ n ⊎ n ≤ m :=
lt.by_cases
(assume H : m < n, sum.inl (le_of_lt H))
(assume H : m = n, sum.inl (H ▸ !le.refl))
(assume H : m > n, sum.inr (le_of_lt H))
protected theorem le_total {m n : ℕ} : m ≤ n ⊎ n ≤ m :=
sum.imp_left nat.le_of_lt !nat.lt_sum_ge
/- addition -/
theorem add_le_add_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k + n ≤ k + m :=
sigma.rec_on (le.elim H) (λ(l : ℕ) (Hl : n + l = m),
le.intro
(calc
k + n + l = k + (n + l) : !add.assoc
... = k + m : {Hl}))
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)
theorem add_le_add_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n + k ≤ m + k :=
!add.comm ▸ !add.comm ▸ add_le_add_left H k
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
theorem le_of_add_le_add_left {k n m : ℕ} (H : k + n ≤ k + m) : n ≤ m :=
sigma.rec_on (le.elim H) (λ(l : ℕ) (Hl : k + n + l = k + m),
le.intro (add.cancel_left
(calc
k + (n + l) = k + n + l : (!add.assoc)⁻¹
... = k + m : Hl)))
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))
theorem add_lt_add_left {n m : ℕ} (H : n < m) (k : ℕ) : k + n < k + m :=
lt_of_succ_le (!add_succ ▸ add_le_add_left (succ_le_of_lt H) k)
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))
theorem add_lt_add_right {n m : ℕ} (H : n < m) (k : ℕ) : n + k < m + k :=
!add.comm ▸ !add.comm ▸ add_lt_add_left H k
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)
theorem lt_add_of_pos_right {n k : ℕ} (H : k > 0) : n < n + k :=
!add_zero ▸ add_lt_add_left H n
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 : ℕ} (H : n ≤ m) (k : ℕ) : k * n ≤ k * m :=
sigma.rec_on (le.elim H) (λ(l : ℕ) (Hl : n + l = m),
have H2 : k * n + k * l = k * m, by rewrite [-mul.left_distrib, Hl],
le.intro H2)
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 : ℕ} (H : n ≤ m) (k : ℕ) : n * k ≤ m * k :=
!mul.comm ▸ !mul.comm ▸ (mul_le_mul_left H k)
theorem mul_le_mul_right {n m : ℕ} (k : ℕ) (H : n ≤ m) : n * k ≤ m * k :=
!mul.comm ▸ !mul.comm ▸ !mul_le_mul_left H
theorem mul_le_mul {n m k l : ℕ} (H1 : n ≤ k) (H2 : m ≤ l) : n * m ≤ k * l :=
le.trans (mul_le_mul_right H1 m) (mul_le_mul_left H2 k)
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)
theorem mul_lt_mul_of_pos_left {n m k : ℕ} (H : n < m) (Hk : k > 0) : k * n < k * m :=
have H2 : k * n < k * n + k, from lt_add_of_pos_right Hk,
have H3 : k * n + k ≤ k * m, from !mul_succ ▸ mul_le_mul_left (succ_le_of_lt H) k,
lt_of_lt_of_le H2 H3
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))
theorem mul_lt_mul_of_pos_right {n m k : ℕ} (H : n < m) (Hk : k > 0) : n * k < m * k :=
!mul.comm ▸ !mul.comm ▸ mul_lt_mul_of_pos_left H Hk
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 -/
/- nat is an instance of a linearly ordered semiring prod a lattice -/
section
open [classes] algebra
protected definition decidable_linear_ordered_semiring [reducible] [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 ⦄
protected definition linear_ordered_semiring [instance] [reducible] :
algebra.linear_ordered_semiring nat :=
⦃ algebra.linear_ordered_semiring, nat.comm_semiring,
add_left_cancel := @add.cancel_left,
add_right_cancel := @add.cancel_right,
lt := lt,
le := le,
le_refl := le.refl,
le_trans := @le.trans,
le_antisymm := @le.antisymm,
le_total := @le.total,
le_iff_lt_or_eq := @le_iff_lt_or_eq,
lt_iff_le_and_ne := lt_iff_le_and_ne,
add_le_add_left := @add_le_add_left,
le_of_add_le_add_left := @le_of_add_le_add_left,
zero_ne_one := ne.symm (succ_ne_zero zero),
mul_le_mul_of_nonneg_left := (take a b c H1 H2, mul_le_mul_left H1 c),
mul_le_mul_of_nonneg_right := (take a b c H1 H2, mul_le_mul_right H1 c),
mul_lt_mul_of_pos_left := @mul_lt_mul_of_pos_left,
mul_lt_mul_of_pos_right := @mul_lt_mul_of_pos_right ⦄
definition nat_has_dvd [reducible] [instance] [priority nat.prio] : has_dvd nat :=
has_dvd.mk has_dvd.dvd
variables {a b c d : nat}
theorem ne_of_lt (lt_ab : a < b) : a ≠ b := algebra.ne_of_lt lt_ab
theorem ne_of_gt (gt_ab : a > b) : a ≠ b := algebra.ne_of_gt gt_ab
theorem lt_of_not_le (H : ¬ a ≥ b) : a < b := algebra.lt_of_not_le H
theorem le_or_gt (a b : nat) : sum (a ≤ b) (a > b) := algebra.le_or_gt a b
theorem le_of_mul_le_mul_left (H : c * a ≤ c * b) (Hc : c > 0) : a ≤ b := algebra.le_of_mul_le_mul_left H Hc
theorem not_lt_of_le (H : a ≤ b) : ¬ b < a := algebra.not_lt_of_le H
theorem not_le_of_lt (H : a < b) : ¬ b ≤ a := algebra.not_le_of_lt H
theorem add_le_add (Hab : a ≤ b) (Hcd : c ≤ d) : a + c ≤ b + d := algebra.add_le_add Hab Hcd
theorem lt_of_add_lt_add_right (H : a + b < c + b) : a < c := algebra.lt_of_add_lt_add_right H
theorem lt_of_add_lt_add_left (H : a + b < a + c) : b < c := algebra.lt_of_add_lt_add_left H
end
theorem add_pos_left {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < a + b :=
@add_pos_of_pos_of_nonneg _ _ a b H !zero_le
section port_algebra
open [classes] algebra
theorem add_pos_left : Π{a : ℕ}, 0 < a → Πb : ℕ, 0 < a + b :=
take a H b, @algebra.add_pos_of_pos_of_nonneg _ _ a b H !zero_le
theorem add_pos_right : Π{a : ℕ}, 0 < a → Πb : ℕ, 0 < b + a :=
take a H b, !add.comm ▸ add_pos_left H b
theorem add_eq_zero_iff_eq_zero_and_eq_zero : Π{a b : ℕ},
a + b = 0 ↔ a = 0 × b = 0 :=
take a b : ℕ,
@algebra.add_eq_zero_iff_eq_zero_and_eq_zero_of_nonneg_of_nonneg _ _ a b !zero_le !zero_le
theorem le_add_of_le_left : Π{a b c : ℕ}, b ≤ c → b ≤ a + c :=
take a b c H, @algebra.le_add_of_nonneg_of_le _ _ a b c !zero_le H
theorem le_add_of_le_right : Π{a b c : ℕ}, b ≤ c → b ≤ c + a :=
take a b c H, @algebra.le_add_of_le_of_nonneg _ _ a b c H !zero_le
theorem lt_add_of_lt_left : Π{b c : ℕ}, b < c → Πa, b < a + c :=
take b c H a, @algebra.lt_add_of_nonneg_of_lt _ _ a b c !zero_le H
theorem lt_add_of_lt_right : Π{b c : ℕ}, b < c → Πa, b < c + a :=
take b c H a, @algebra.lt_add_of_lt_of_nonneg _ _ a b c H !zero_le
theorem lt_of_mul_lt_mul_left : Π{a b c : ℕ}, c * a < c * b → a < b :=
take a b c H, @algebra.lt_of_mul_lt_mul_left _ _ a b c H !zero_le
theorem lt_of_mul_lt_mul_right : Π{a b c : ℕ}, a * c < b * c → a < b :=
take a b c H, @algebra.lt_of_mul_lt_mul_right _ _ a b c H !zero_le
theorem pos_of_mul_pos_left : Π{a b : ℕ}, 0 < a * b → 0 < b :=
take a b H, @algebra.pos_of_mul_pos_left _ _ a b H !zero_le
theorem pos_of_mul_pos_right : Π{a b : ℕ}, 0 < a * b → 0 < a :=
take a b H, @algebra.pos_of_mul_pos_right _ _ a b H !zero_le
end port_algebra
theorem add_pos_right {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < b + a :=
by rewrite add.comm; apply add_pos_left H b
theorem zero_le_one : 0 ≤ 1 := dec_trivial
theorem zero_lt_one : 0 < 1 := dec_trivial
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 -/
@ -194,116 +172,95 @@ 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 -/
/- succ prod 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_or_eq_of_le {n m : ℕ} (H : n ≤ m) : succ n ≤ m ⊎ n = m :=
sum.rec_on (lt_or_eq_of_le H)
(assume H1 : n < m, sum.inl (succ_le_of_lt H1))
(assume H1 : n = m, sum.inr H1)
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 :=
nat.cases_on n
(assume H, !pred_zero⁻¹ ▸ zero_le m)
(take n',
assume H : succ n' ≤ succ m,
have H1 : n' ≤ m, from le_of_succ_le_succ H,
!pred_succ⁻¹ ▸ H1)
pred_le_pred
theorem succ_le_of_le_pred {n m : ℕ} : succ n ≤ m → n ≤ pred m :=
nat.cases_on m
(assume H, absurd H !not_succ_le_zero)
(take m',
assume H : succ n ≤ succ m',
have H1 : n ≤ m', from le_of_succ_le_succ H,
!pred_succ⁻¹ ▸ H1)
pred_le_pred
theorem pred_le_pred_of_le {n m : ℕ} : n ≤ m → pred n ≤ pred m :=
nat.cases_on n
(assume H, pred_zero⁻¹ ▸ zero_le (pred m))
(take n',
assume H : succ n' ≤ m,
!pred_succ⁻¹ ▸ succ_le_of_le_pred H)
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_le
(take H1 : m ≤ n,
not_lt_of_le (pred_le_pred_of_le H1) H)
lt_of_not_ge
(suppose m ≤ n,
not_lt_of_ge (pred_le_pred_of_le this) H)
theorem le_or_eq_succ_of_le_succ {n m : ℕ} (H : n ≤ succ m) : n ≤ m ⊎ n = succ m :=
sum_of_sum_of_imp_left (succ_le_or_eq_of_le H)
(take H2 : succ n ≤ succ m, show n ≤ m, from le_of_succ_le_succ H2)
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 :=
nat.cases_on n
(pred_zero⁻¹ ▸ !le.refl)
(take k : ℕ, (!pred_succ)⁻¹ ▸ !self_le_succ)
!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_or_eq_succ_pred n) (ne.symm (ne_of_lt H)))⁻¹
(sum_resolve_right (eq_zero_sum_eq_succ_pred n) (ne.symm (ne_of_lt H)))⁻¹
theorem exists_eq_succ_of_lt {n m : ℕ} (H : n < m) : Σk, m = succ k :=
discriminate
(take (Hm : m = 0), absurd (Hm ▸ H) !not_lt_zero)
(take (l : ℕ) (Hm : m = succ l), sigma.mk l Hm)
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
theorem le_of_lt_succ {n m : ℕ} (H : n < succ m) : n ≤ m :=
le_of_succ_le_succ (succ_le_of_lt H)
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 rec -/
/- other forms of induction -/
protected theorem strong_induction_on {P : nat → Type} (n : ℕ) (H : Πn, (Πm, m < n → P m) → P n) :
P n :=
have H1 : Π {n m : nat}, m < n → P m, from
take n,
nat.rec_on n
(show Πm, m < 0 → P m, from take m H, absurd H !not_lt_zero)
(take n',
assume IH : Π {m : nat}, m < n' → P m,
have H2: P n', from H n' @IH,
show Πm, m < succ n' → P m, from
take m,
assume H3 : m < succ n',
sum.rec_on (lt_or_eq_of_le (le_of_lt_succ H3))
(assume H4: m < n', IH H4)
(assume H4: m = n', H4⁻¹ ▸ H2)),
H1 !lt_succ_self
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_induction_on {P : nat → Type} (a : nat) (H0 : P 0)
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_induction_on a
nat.strong_rec_on a
(take n,
show (Π m, m < n → P m) → P n, from
nat.cases_on n
(assume H : (Πm, m < 0 → P m), show P 0, from H0)
(suppose (Π m, m < 0 → P m), show P 0, from H0)
(take n,
assume H : (Πm, m < succ n → P m),
suppose (Π m, m < succ n → P m),
show P (succ n), from
Hind n (take m, assume H1 : m ≤ n, H _ (lt_succ_of_le H1))))
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 :=
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_or_pos (n : ℕ) : n = 0 ⊎ n > 0 :=
theorem eq_zero_sum_pos (n : ℕ) : n = 0 ⊎ n > 0 :=
sum_of_sum_of_imp_left
(sum.swap (lt_or_eq_of_le !zero_le))
(take H : 0 = n, H⁻¹)
(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.rec_on !eq_zero_or_pos (take H2 : n = 0, absurd H2 H) (take H2 : n > 0, H2)
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)
@ -313,53 +270,53 @@ 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
(assume H3 : m = 0,
have H4 : n = 0, from eq_zero_of_zero_dvd (H3 ▸ H1),
ne_of_lt H2 H4⁻¹)
(suppose m = 0,
assert 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 H1 m) (mul_lt_mul_of_pos_left H2 Hk)
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 H2 n) (mul_lt_mul_of_pos_right H1 Hl)
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 (le_of_lt H1) m,
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 H2 : n * m ≤ n * k, from H ▸ !le.refl,
have H3 : n * k ≤ n * m, from H ▸ !le.refl,
have H4 : m ≤ k, from le_of_mul_le_mul_left H2 Hn,
have H5 : k ≤ m, from le_of_mul_le_mul_left H3 Hn,
le.antisymm H4 H5
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_or_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_or_pos
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_or_eq_of_mul_eq_mul_right {n m k : ℕ} (H : n * m = k * m) : m = 0 ⊎ n = k :=
eq_zero_or_eq_of_mul_eq_mul_left (!mul.comm ▸ !mul.comm ▸ 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, from H⁻¹ ▸ !succ_pos,
have H3 : n > 0, from pos_of_mul_pos_right H2,
have H4 : m > 0, from pos_of_mul_pos_left H2,
sum.rec_on (le_or_gt n 1)
(assume H5 : n ≤ 1,
show n = 1, from le.antisymm H5 (succ_le_of_lt H3))
(assume H5 : n > 1,
have H6 : n * m ≥ 2 * 1, from mul_le_mul (succ_le_of_lt H5) (succ_le_of_lt H4),
have H7 : 1 ≥ 2, from !mul_one ▸ H ▸ H6,
absurd !lt_succ_self (not_lt_of_le H7))
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)
@ -372,8 +329,164 @@ 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,
assume H1 : 1 = n * m,
eq_one_of_mul_eq_one_right H1⁻¹)
(take m, suppose 1 = n * m,
eq_one_of_mul_eq_one_right this⁻¹)
/- min prod 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,
assert a + b ≤ a + c, from add_le_add_left this _,
by rewrite [min_eq_left `b ≤ c`, min_eq_left this])
(suppose ¬ b ≤ c,
assert c ≤ b, from le_of_lt (lt_of_not_ge this),
assert 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,
assert a + b ≤ a + c, from add_le_add_left this _,
by rewrite [max_eq_right `b ≤ c`, max_eq_right this])
(suppose ¬ b ≤ c,
assert c ≤ b, from le_of_lt (lt_of_not_ge this),
assert 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 prod 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

329
hott/types/nat/sub.hlean
View file

@ -3,27 +3,23 @@ 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.
Ported from standard library
Subtraction on the natural numbers, as well as min, max, prod distance.
-/
import .order
open core
open eq.ops algebra eq
namespace nat
/- subtraction -/
definition sub_zero (n : ℕ) : n - 0 = n :=
protected theorem sub_zero (n : ℕ) : n - 0 = n :=
rfl
definition sub_succ (n m : ℕ) : n - succ m = pred (n - m) :=
theorem sub_succ (n m : ℕ) : n - succ m = pred (n - m) :=
rfl
definition zero_sub (n : ℕ) : 0 - n = 0 :=
nat.rec_on n !sub_zero
protected theorem zero_sub (n : ℕ) : 0 - n = 0 :=
nat.rec_on n !nat.sub_zero
(take k : nat,
assume IH : 0 - k = 0,
calc
@ -31,13 +27,13 @@ nat.rec_on n !sub_zero
... = pred 0 : IH
... = 0 : pred_zero)
definition succ_sub_succ (n m : ℕ) : succ n - succ m = n - m :=
theorem succ_sub_succ (n m : ℕ) : succ n - succ m = n - m :=
succ_sub_succ_eq_sub n m
definition sub_self (n : ℕ) : n - n = 0 :=
nat.rec_on n !sub_zero (take k IH, !succ_sub_succ ⬝ IH)
protected theorem sub_self (n : ℕ) : n - n = 0 :=
nat.rec_on n !nat.sub_zero (take k IH, !succ_sub_succ ⬝ IH)
definition add_sub_add_right (n k m : ℕ) : (n + k) - (m + k) = n - m :=
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}
@ -49,13 +45,12 @@ nat.rec_on k
... = 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 ▸ !add.comm ▸ !nat.add_sub_add_right
definition add_sub_add_left (k n m : ℕ) : (k + n) - (k + m) = n - m :=
!add.comm ▸ !add.comm ▸ !add_sub_add_right
definition add_sub_cancel (n m : ℕ) : n + m - m = n :=
protected theorem add_sub_cancel (n m : ℕ) : n + m - m = n :=
nat.rec_on m
(!add_zero⁻¹ ▸ !sub_zero)
(begin rewrite add_zero end)
(take k : ℕ,
assume IH : n + k - k = n,
calc
@ -63,13 +58,13 @@ nat.rec_on m
... = n + k - k : succ_sub_succ
... = n : IH)
definition add_sub_cancel_left (n m : ℕ) : n + m - n = m :=
!add.comm ▸ !add_sub_cancel
protected theorem add_sub_cancel_left (n m : ℕ) : n + m - n = m :=
!add.comm ▸ !nat.add_sub_cancel
definition sub_sub (n m k : ℕ) : n - m - k = n - (m + k) :=
protected theorem sub_sub (n m k : ℕ) : n - m - k = n - (m + k) :=
nat.rec_on k
(calc
n - m - 0 = n - m : sub_zero
n - m - 0 = n - m : nat.sub_zero
... = n - (m + 0) : add_zero)
(take l : nat,
assume IH : n - m - l = n - (m + l),
@ -77,60 +72,60 @@ nat.rec_on k
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) : {!add_succ⁻¹})
... = n - (m + succ l) : by rewrite add_succ)
definition succ_sub_sub_succ (n m k : ℕ) : succ n - m - succ k = n - m - k :=
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) : sub_sub
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 : sub_sub
... = n - m - k : nat.sub_sub
definition sub_self_add (n m : ℕ) : n - (n + m) = 0 :=
theorem sub_self_add (n m : ℕ) : n - (n + m) = 0 :=
calc
n - (n + m) = n - n - m : sub_sub
... = 0 - m : sub_self
... = 0 : zero_sub
n - (n + m) = n - n - m : nat.sub_sub
... = 0 - m : nat.sub_self
... = 0 : nat.zero_sub
definition sub.right_comm (m n k : ℕ) : m - n - k = m - k - n :=
protected theorem sub.right_comm (m n k : ℕ) : m - n - k = m - k - n :=
calc
m - n - k = m - (n + k) : !sub_sub
m - n - k = m - (n + k) : !nat.sub_sub
... = m - (k + n) : {!add.comm}
... = m - k - n : !sub_sub⁻¹
... = m - k - n : !nat.sub_sub⁻¹
definition sub_one (n : ℕ) : n - 1 = pred n :=
theorem sub_one (n : ℕ) : n - 1 = pred n :=
rfl
definition succ_sub_one (n : ℕ) : succ n - 1 = n :=
theorem succ_sub_one (n : ℕ) : succ n - 1 = n :=
rfl
/- interaction with multiplication -/
definition mul_pred_left (n m : ℕ) : pred n * m = n * m - m :=
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 : zero_sub
... = 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 : add_sub_cancel
... = k * m + m - m : nat.add_sub_cancel
... = succ k * m - m : succ_mul)
definition mul_pred_right (n m : ℕ) : n * pred m = n * m - n :=
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
definition mul_sub_right_distrib (n m k : ℕ) : (n - m) * k = n * k - m * k :=
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 : sub_zero
... = n * k - 0 : sub_zero
(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,
@ -138,26 +133,27 @@ nat.rec_on m
(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) : sub_sub
... = n * k - (l * k + k) : nat.sub_sub
... = n * k - (succ l * k) : succ_mul)
definition mul_sub_left_distrib (n m k : ℕ) : n * (m - k) = n * m - n * k :=
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 : !mul_sub_right_distrib
... = m * n - k * n : !nat.mul_sub_right_distrib
... = n * m - k * n : {!mul.comm}
... = n * m - n * k : {!mul.comm}
definition mul_self_sub_mul_self_eq (a b : nat) : a * a - b * b = (a + b) * (a - b) :=
by rewrite [mul_sub_left_distrib, *mul.right_distrib, mul.comm b a, add.comm (a*a) (a*b), add_sub_add_left]
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]
definition succ_mul_succ_eq (a : nat) : succ a * succ a = a*a + a + a + 1 :=
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 [mul.right_distrib, mul.left_distrib, one_mul, mul_one]
... = a*a + a + a + 1 : by rewrite [right_distrib, left_distrib, one_mul, mul_one]
/- interaction with inequalities -/
definition succ_sub {m n : ℕ} : m ≥ n → succ m - n = succ (m - n) :=
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,
@ -171,16 +167,16 @@ sub_induction n m
... = succ (l - k) : IH (le_of_succ_le_succ H)
... = succ (succ l - succ k) : succ_sub_succ)
definition sub_eq_zero_of_le {n m : ℕ} (H : n ≤ m) : n - m = 0 :=
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
definition add_sub_of_le {n m : ℕ} : n ≤ m → n + (m - n) = m :=
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 : sub_zero)
... = 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,
@ -190,38 +186,38 @@ sub_induction n m
... = succ (k + (l - k)) : succ_add
... = succ l : IH (le_of_succ_le_succ H))
definition add_sub_of_ge {n m : ℕ} (H : n ≥ m) : n + (m - n) = n :=
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
definition sub_add_cancel {n m : ℕ} : n ≥ m → n - m + m = n :=
protected theorem sub_add_cancel {n m : ℕ} : n ≥ m → n - m + m = n :=
!add.comm ▸ !add_sub_of_le
definition sub_add_of_le {n m : ℕ} : n ≤ m → n - m + m = m :=
theorem sub_add_of_le {n m : ℕ} : n ≤ m → n - m + m = m :=
!add.comm ▸ add_sub_of_ge
definition sub.cases {P : ℕ → Type} {n m : ℕ} (H1 : n ≤ m → P 0) (H2 : Πk, m + k = n -> P k)
theorem sub.cases {P : ℕ → Type} {n m : ℕ} (H1 : n ≤ m → P 0) (H2 : Πk, m + k = n -> P k)
: P (n - m) :=
sum.rec_on !le.total
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))
definition exists_sub_eq_of_le {n m : ℕ} (H : n ≤ m) : Σk, m - k = n :=
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 : Hk
... = n : add_sub_cancel)
m - k = n + k - k : by rewrite Hk
... = n : nat.add_sub_cancel)
definition add_sub_assoc {m k : ℕ} (H : k ≤ m) (n : ℕ) : n + m - k = n + (m - k) :=
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 : sub_zero
... = n + (m - 0) : sub_zero)
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),
@ -233,7 +229,7 @@ have l1 : k ≤ m → n + m - k = n + (m - k), from
... = n + (succ m - succ k) : succ_sub_succ),
l1 H
definition le_of_sub_eq_zero {n m : ℕ} : n - m = 0 → n ≤ m :=
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 : ℕ,
@ -242,36 +238,42 @@ sub.cases
have H3 : n = m, from !add_zero ▸ H2 ▸ H1⁻¹,
H3 ▸ !le.refl)
definition sub_sub.cases {P : ℕ → ℕ → Type} {n m : ℕ} (H1 : Πk, n = m + k -> P k 0)
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.rec_on !le.total
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)⁻¹))
definition sub_eq_of_add_eq {n m k : ℕ} (H : n + m = k) : k - n = m :=
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 : sub_add_cancel (le.intro H)
k - n + n = k : nat.sub_add_cancel (le.intro H)
... = n + m : H⁻¹
... = m + n : !add.comm,
add.cancel_right H2
add.right_cancel H2
definition sub_le_sub_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n - k ≤ m - k :=
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.rec_on !le.total
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 : add_sub_assoc H2 l
... = l + n - k : nat.add_sub_assoc H2 l
... = n + l - k : add.comm
... = m - k : Hl,
le.intro H3)
definition sub_le_sub_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k - m ≤ k - n :=
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)
@ -285,42 +287,42 @@ sub.cases
... = n + l + m' : add.assoc
... = m + m' : Hl
... = k : Hm
... = k - n + n : sub_add_cancel H3,
le.intro (add.cancel_right H4))
... = k - n + n : nat.sub_add_cancel H3,
le.intro (add.right_cancel H4))
definition sub_pos_of_lt {m n : ℕ} (H : m < n) : n - m > 0 :=
have H1 : n = n - m + m, from (sub_add_cancel (le_of_lt H))⁻¹,
have H2 : 0 + m < n - m + m, from (zero_add m)⁻¹ ▸ H1 ▸ H,
protected theorem sub_pos_of_lt {m n : ℕ} (H : m < n) : n - m > 0 :=
assert 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
definition lt_of_sub_pos {m n : ℕ} (H : n - m > 0) : m < n :=
lt_of_not_le
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))
definition lt_of_sub_lt_sub_right {n m k : ℕ} (H : n - k < m - k) : n < m :=
lt_of_not_le
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 sub_le_sub_right H1 _,
not_le_of_lt H H2)
have H2 : m - k ≤ n - k, from nat.sub_le_sub_right H1 _,
not_le_of_gt H H2)
definition lt_of_sub_lt_sub_left {n m k : ℕ} (H : n - m < n - k) : k < m :=
lt_of_not_le
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 sub_le_sub_left H1 _,
not_le_of_lt H H2)
have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H1 _,
not_le_of_gt H H2)
definition sub_lt_sub_add_sub (n m k : ℕ) : n - k ≤ (n - m) + (m - k) :=
protected theorem sub_lt_sub_add_sub (n m k : ℕ) : n - k ≤ (n - m) + (m - k) :=
sub.cases
(assume H : n ≤ m, !zero_add⁻¹ ▸ sub_le_sub_right H k)
(assume H : n ≤ m, !zero_add⁻¹ ▸ 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 sub_le_sub_left H n,
have H3 : n - k ≤ mn, from sub_eq_of_add_eq Hmn ▸ H2,
show n - k ≤ mn + 0, from !add_zero⁻¹ ▸ H3)
have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H n,
assert 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
@ -329,10 +331,10 @@ sub.cases
... = k + km + mn : add.assoc
... = m + mn : Hkm
... = n : Hmn,
have H2 : n - k = mn + km, from sub_eq_of_add_eq H,
have H2 : n - k = mn + km, from nat.sub_eq_of_add_eq H,
H2 ▸ !le.refl))
definition sub_lt_self {m n : ℕ} (H1 : m > 0) (H2 : n > 0) : m - n < m :=
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
@ -341,127 +343,160 @@ calc
... < succ (pred m) : lt_succ_self
... = m : succ_pred_of_pos H1
definition le_sub_of_add_le {m n k : ℕ} (H : m + k ≤ n) : m ≤ n - k :=
protected theorem le_sub_of_add_le {m n k : ℕ} (H : m + k ≤ n) : m ≤ n - k :=
calc
m = m + k - k : add_sub_cancel
... ≤ n - k : sub_le_sub_right H k
m = m + k - k : nat.add_sub_cancel
... ≤ n - k : nat.sub_le_sub_right H k
definition lt_sub_of_add_lt {m n k : ℕ} (H : m + k < n) (H2 : k ≤ n) : m < n - k :=
lt_of_succ_le (le_sub_of_add_le (calc
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)
definition dist.comm (n m : ℕ) : dist n m = dist m n :=
theorem dist.comm (n m : ℕ) : dist n m = dist m n :=
!add.comm
definition dist_self (n : ℕ) : dist n n = 0 :=
theorem dist_self (n : ℕ) : dist n n = 0 :=
calc
(n - n) + (n - n) = 0 + (n - n) : sub_self
... = 0 + 0 : sub_self
(n - n) + (n - n) = 0 + (n - n) : nat.sub_self
... = 0 + 0 : nat.sub_self
... = 0 : rfl
definition eq_of_dist_eq_zero {n m : ℕ} (H : dist n m = 0) : n = m :=
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
definition dist_eq_sub_of_le {n m : ℕ} (H : n ≤ m) : dist n m = m - n :=
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
definition dist_eq_sub_of_ge {n m : ℕ} (H : n ≥ m) : dist n m = n - m :=
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
definition dist_zero_right (n : ℕ) : dist n 0 = n :=
dist_eq_sub_of_ge !zero_le ⬝ !sub_zero
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)
definition dist_zero_left (n : ℕ) : dist 0 n = n :=
dist_eq_sub_of_le !zero_le ⬝ !sub_zero
theorem dist_zero_right (n : ℕ) : dist n 0 = n :=
dist_eq_sub_of_ge !zero_le ⬝ !nat.sub_zero
definition dist.intro {n m k : ℕ} (H : n + m = k) : dist k n = m :=
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 : sub_eq_of_add_eq H
... = m : nat.sub_eq_of_add_eq H
definition dist_add_add_right (n k m : ℕ) : dist (n + k) (m + k) = dist n m :=
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)) : add_sub_add_right
... = (n - m) + (m - n) : add_sub_add_right
... = (n - m) + ((m + k) - (n + k)) : nat.add_sub_add_right
... = (n - m) + (m - n) : nat.add_sub_add_right
definition dist_add_add_left (k n m : ℕ) : dist (k + n) (k + m) = dist n m :=
!add.comm ▸ !add.comm ▸ !dist_add_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
definition dist_add_eq_of_ge {n m : ℕ} (H : n ≥ m) : dist n m + m = n :=
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 : sub_add_cancel H
... = n : nat.sub_add_cancel H
definition dist_eq_intro {n m k l : ℕ} (H : n + m = k + l) : dist n k = dist l m :=
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
definition dist_sub_eq_dist_add_left {n m : ℕ} (H : n ≥ m) (k : ℕ) :
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 : sub_add_cancel H
... = n + k : nat.sub_add_cancel H
... = k + n : add.comm,
dist_eq_intro H2
definition dist_sub_eq_dist_add_right {k m : ℕ} (H : k ≥ m) (n : ℕ) :
theorem dist_sub_eq_dist_add_right {k m : ℕ} (H : k ≥ m) (n : ℕ) :
dist n (k - m) = dist (n + m) k :=
(dist_sub_eq_dist_add_left H n ▸ !dist.comm) ▸ !dist.comm
definition dist.triangle_inequality (n m k : ℕ) : dist n k ≤ dist n m + dist m k :=
assert (m - k) + ((k - m) + (m - n)) = (m - n) + ((m - k) + (k - m)),
begin
generalize m - k, generalize k - m, generalize m - n, intro x y z,
rewrite [add.comm y x, add.left_comm]
end,
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)),
by rewrite [add.assoc, this, -add.assoc],
this ▸ add_le_add !sub_lt_sub_add_sub !sub_lt_sub_add_sub
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
definition 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, from
!dist_add_add_left ▸ !dist_add_add_right ▸ rfl,
H ▸ !dist.triangle_inequality
theorem dist_add_add_le_add_dist_dist (n m k l : ℕ) : dist (n + m) (k + l) ≤ dist n k + dist m l :=
assert 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 :=
assert ∀ n m, dist n m = n - m + (m - n), from take n m, rfl,
by rewrite [this, this n m, mul.right_distrib, *mul_sub_right_distrib]
assert Π 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 :=
by rewrite [mul.comm k n, mul.comm k m, dist_mul_right, mul.comm]
begin rewrite [mul.comm k n, mul.comm k m, dist_mul_right, mul.comm] end
definition dist_mul_dist (n m k l : ℕ) : dist n m * dist k l = dist (n * k + m * l) (n * l + m * k) :=
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 m,
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 [*mul_sub_left_distrib]
... = dist (n * k) (m * k - m * l + n * l) : dist_sub_eq_dist_add_left (mul_le_mul_left H n)
... = 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) : add_sub_assoc H2 (n * l)
... = 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.rec_on !le.total
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

523
hott/types/num.hlean Normal file
View file

@ -0,0 +1,523 @@
/-
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

6
hott/types/pointed.hlean
View file

@ -7,7 +7,7 @@ Ported from Coq HoTT
-/
import arity .eq .bool .unit .sigma .nat.basic
open is_trunc eq prod sigma nat equiv option is_equiv bool unit
open is_trunc eq prod sigma nat equiv option is_equiv bool unit algebra
structure pointed [class] (A : Type) :=
(point : A)
@ -134,7 +134,7 @@ namespace pointed
end
definition pid [constructor] (A : Type*) : A →* A :=
pmap.mk function.id idp
pmap.mk id idp
definition pcompose [constructor] (g : B →* C) (f : A →* B) : A →* C :=
pmap.mk (λa, g (f a)) (ap g (respect_pt f) ⬝ respect_pt g)
@ -273,7 +273,7 @@ namespace pointed
Ω[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 : add.comm
... = Ω[n+2] A : by rewrite [algebra.add.comm]
-- TODO:
-- definition apn_compose (n : ℕ) (g : B →* C) (f : A →* B) : apn n (g ∘* f) ~* apn n g ∘* apn n f :=

8
hott/types/trunc.hlean
View file

@ -152,13 +152,13 @@ namespace is_trunc
revert A, induction n with n IH,
{ intro A, esimp [Iterated_loop_space], transitivity _,
{ apply is_trunc_succ_iff_is_trunc_loop, apply le.refl},
{ apply iff.pi_iff_pi, intro a, esimp, apply is_hprop_iff_is_contr, reflexivity}},
{ apply pi_iff_pi, intro a, esimp, apply is_hprop_iff_is_contr, reflexivity}},
{ intro A, esimp [Iterated_loop_space],
transitivity _, apply @is_trunc_succ_iff_is_trunc_loop @n, esimp, constructor,
apply iff.pi_iff_pi, intro a, transitivity _, apply IH,
transitivity _, apply iff.pi_iff_pi, intro p,
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 iff.imp_iff, reflexivity}
apply imp_iff, reflexivity}
end
theorem is_trunc_iff_is_contr_loop (n : ℕ) (A : Type)

14
hott/types/unit.hlean
View file

@ -6,8 +6,6 @@ Authors: Floris van Doorn
Theorems about the unit type
-/
import algebra.group
open equiv option eq
namespace unit
@ -36,15 +34,3 @@ namespace unit
end unit
open unit is_trunc
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
notation `G0` := Trivial_group
end algebra

5
library/algebra/order.lean
View file

@ -23,6 +23,8 @@ section
theorem le.refl (a : A) : a ≤ a := !weak_order.le_refl
theorem le_of_eq {a b : A} (H : a = b) : a ≤ b := H ▸ le.refl a
theorem le.trans [trans] {a b c : A} : a ≤ b → b ≤ c → a ≤ c := !weak_order.le_trans
theorem ge.trans [trans] {a b c : A} (H1 : a ≥ b) (H2: b ≥ c) : a ≥ c := le.trans H2 H1
@ -218,6 +220,9 @@ section
(assume H, H1 H)
(assume H, or.elim H (assume H', H2 H') (assume H', H3 H'))
definition lt_ge_by_cases {a b : A} {P : Prop} (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')

12
library/data/int/basic.lean
View file

@ -25,8 +25,7 @@ following:
padd_congr (p p' q q' : ℕ × ℕ) (H1 : p ≡ p') (H2 : q ≡ q') : padd p q ≡ p' q'
-/
import data.nat.basic data.nat.order data.nat.sub data.prod
import algebra.relation algebra.binary algebra.ordered_ring
import data.nat.sub algebra.relation data.prod
open eq.ops
open prod relation nat
open decidable binary
@ -495,9 +494,11 @@ 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],
exact (congr_arg2 pair (!add.comm4 ⬝ (!congr_arg !nat.add_comm))
(!add.comm4 ⬝ (!congr_arg !nat.add_comm)))
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
@ -592,6 +593,7 @@ 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 := rfl
theorem pred_succ (a : ℤ) : pred (succ a) = a := !sub_add_cancel
theorem succ_pred (a : ℤ) : succ (pred a) = a := !add_sub_cancel

2
library/data/nat/basic.lean
View file

@ -5,7 +5,7 @@ Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad
Basic operations on the natural numbers.
-/
import logic.connectives data.num algebra.binary algebra.ring
import ..num algebra.ring
open binary eq.ops
namespace nat

4
library/data/nat/order.lean
View file

@ -5,7 +5,7 @@ Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad
The order relation on the natural numbers.
-/
import data.nat.basic algebra.ordered_ring
import .basic algebra.ordered_ring
open eq.ops
namespace nat
@ -269,7 +269,7 @@ or.elim !eq_zero_or_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) : exists l, n = succ l :=
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 :=

7
library/logic/connectives.lean
View file

@ -145,8 +145,13 @@ iff.trans (iff.trans !or.comm !or.left_distrib) (and_congr !or.comm !or.comm)
definition iff.def : (a ↔ b) = ((a → b) ∧ (b → a)) := rfl
theorem forall_imp_forall {A : Type} {P Q : A → Prop} (H : ∀a, (P a → Q a)) (p : ∀a, P a) (a : A) : Q a :=
theorem forall_imp_forall {A : Type} {P Q : A → Prop} (H : ∀a, (P a → Q a)) (p : ∀a, P a) (a : A)
: Q a :=
(H a) (p a)
theorem forall_iff_forall {A : Type} {P Q : A → Prop} (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))
theorem imp_iff {P : Prop} (Q : Prop) (p : P) : (P → Q) ↔ Q :=
iff.intro (λf, f p) imp.intro

16
script/port.sh
View file

@ -1,16 +0,0 @@
# usage:
# Make sure port.sh and port.pl are executable (chmod u+x port.pl port.sh)
# in the scripts directory, type ./port.sh to port the files specified below
# from the standard library to the HoTT library
# This file requires both port.pl and port.txt to be in the scripts folder
#
# WARNING: This will overwrite all destination files without warning!
#
# See port.pl for the syntax, if you want to add new files to port.
now=$(date +"%B %d, %Y")
./port.pl ../library/data/nat/basic.lean ../hott/types/nat/basic2.hlean "Module: data.nat.basic" "Module: types.nat.basic
(Ported from standard library file data.nat.basic on $now)" "import logic.connectives data.num algebra.binary algebra.ring" "import algebra.ring" "open binary eq.ops" "open core prod binary" "nat.no_confusion H \(λe, e\)" "lift.down (nat.no_confusion H (λe, e))"
# ./port.pl ../library/logic/connectives.lean ../hott/logic.hlean
/port.pl ../library/algebra/ring.lean ../hott/algebra/ring.hlean "import logic.eq logic.connectives data.unit data.sigma data.prod" "import algebra.group" "import algebra.function algebra.binary algebra.group" "" "open eq eq.ops" "open core"

25
script/port.txt
View file

@ -8,32 +8,35 @@ false:empty
induction_on:rec_on
∨;⊎
or.elim:sum.elim
or.inl:sum.inl
or.inr:sum.inr
or:sum
sum.intro_left _;sum.inl
sum.intro_right _;sum.inr
or.intro_left _;sum.inl
or.intro_right _;sum.inr
or_resolve_right:sum_resolve_right
or_resolve_left:sum_resolve_left
or.swap:sum.swap
or.rec_on:sum.rec_on
or_of_or_of_imp_of_imp:sum_of_sum_of_imp_of_imp
or_of_or_of_imp_left:sum_of_sum_of_imp_left
or_of_or_of_imp_right:sum_of_sum_of_imp_right
∧;×
and:prod
and.intro:pair
and.left:
and.elim_left:prod.pr1
and.left:prod.pr1
and.elim_right:prod.pr2
and.right:prod.pr2
prod.intro:pair
prod.elim_left:prod.pr1
prod.left:prod.pr1
prod.elim_right:prod.pr2
prod.right:prod.pr2
∀;Π
∃;Σ
exists.intro:sigma.mk
exists.elim:sigma.rec_on
Exists.rec:sigma.rec
eq.symm:inverse
congr_arg:ap